paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-22 12:39:29 +02:00
Code Issues Packages Projects Releases Wiki Activity

TAChart: Add Windows Metafile drawing back-end

Browse Source 
git-svn-id: trunk@30239 -
This commit is contained in:
ask 2011-04-08 07:17:11 +00:00
parent af4ddf60a7
commit 1aaadaf5c9
5 changed files with 498 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -2453,6 +2453,8 @@ components/tachart/tachartbgra.pas svneol=native#text/pascal
components/tachart/tachartlazaruspkg.lpk svneol=native#text/plain
components/tachart/tachartlazaruspkg.pas svneol=native#text/plain
components/tachart/tachartutils.pas svneol=native#text/plain
components/tachart/tachartwmf.lpk svneol=native#text/plain
components/tachart/tachartwmf.pas svneol=native#text/pascal
components/tachart/tacustomseries.pas svneol=native#text/plain
components/tachart/tacustomsource.pas svneol=native#text/pascal
components/tachart/tadbsource.pas svneol=native#text/pascal
@ -2462,6 +2464,7 @@ components/tachart/tadrawercanvas.pas svneol=native#text/pascal
components/tachart/tadrawerfpcanvas.pas svneol=native#text/pascal
components/tachart/tadraweropengl.pas svneol=native#text/pascal
components/tachart/tadrawersvg.pas svneol=native#text/pascal
components/tachart/tadrawerwmf.pas svneol=native#text/pascal
components/tachart/tadrawutils.pas svneol=native#text/pascal
components/tachart/tafuncseries.pas svneol=native#text/pascal
components/tachart/tageometry.pas svneol=native#text/pascal

42
components/tachart/tachartwmf.lpk Normal file
View File

@ -0,0 +1,42 @@
<?xml version="1.0"?>
<CONFIG>
<Package Version="3">
<PathDelim Value="\"/>
<Name Value="TAChartWMF"/>
<CompilerOptions>
<Version Value="10"/>
<PathDelim Value="\"/>
<SearchPaths>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)\$(LCLWidgetType)"/>
</SearchPaths>
<Other>
<CompilerMessages>
<UseMsgFile Value="True"/>
</CompilerMessages>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Files Count="1">
<Item1>
<Filename Value="tadrawerwmf.pas"/>
<UnitName Value="TADrawerWMF"/>
</Item1>
</Files>
<Type Value="RunAndDesignTime"/>
<RequiredPkgs Count="2">
<Item1>
<PackageName Value="TAChartLazarusPkg"/>
</Item1>
<Item2>
<PackageName Value="FCL"/>
<MinVersion Major="1" Release="1" Valid="True"/>
</Item2>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
</Package>
</CONFIG>

20
components/tachart/tachartwmf.pas Normal file
View File

@ -0,0 +1,20 @@
{ This file was automatically created by Lazarus. Do not edit!
This source is only used to compile and install the package.
}
unit TAChartWMF;
interface
uses
TADrawerWMF, LazarusPackageIntf;
implementation
procedure Register;
begin
end;
initialization
RegisterPackage('TAChartWMF', @Register);
end.

2
components/tachart/tadrawercanvas.pas
View File

@ -35,11 +35,11 @@ type
TCanvasDrawer = class(
TBasicDrawer, IChartDrawer, IChartTCanvasDrawer)
private
FCanvas: TCanvas;
procedure SetBrush(ABrush: TFPCustomBrush);
procedure SetFont(AFont: TFPCustomFont);
procedure SetPen(APen: TFPCustomPen);
strict protected
FCanvas: TCanvas;
function GetFontAngle: Double; override;
function SimpleTextExtent(const AText: String): TPoint; override;
procedure SimpleTextOut(AX, AY: Integer; const AText: String); override;

432
components/tachart/tadrawerwmf.pas Normal file
View File

@ -0,0 +1,432 @@
{
*****************************************************************************
* *
* See the file COPYING.modifiedLGPL.txt, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
*****************************************************************************
Authors: Luís Rodrigues, Alexander Klenin
}
unit TADrawerWMF;
{$H+}
interface
uses
Windows, Classes, Graphics,
TADrawerCanvas;
type
{ TMetafile }
TMetafile = class(TGraphic)
private
FImageHandle: HENHMETAFILE;
FMMHeight: Integer; // are in 0.01 mm logical pixels
FMMWidth: Integer; // are in 0.01 mm logical pixels
FImagePxHeight: Integer; // in device pixels
FImagePxWidth: Integer; // in device pixels
procedure DeleteImage;
function GetAuthor: String;
function GetDescription: String;
function GetHandle: HENHMETAFILE;
procedure SetHandle(AValue: HENHMETAFILE);
procedure SetMMHeight(AValue: Integer);
procedure SetMMWidth(AValue: Integer);
protected
procedure Draw(ACanvas: TCanvas; const ARect: TRect); override;
function GetEmpty: Boolean; override;
function GetHeight: Integer; override;
function GetTransparent: Boolean; override;
function GetWidth: Integer; override;
procedure SetHeight(AValue: Integer); override;
procedure SetTransparent(AValue: Boolean); override;
procedure SetWidth(AValue: Integer); override;
public
constructor Create; override;
destructor Destroy; override;
public
procedure Assign(ASource: TPersistent); override;
procedure Clear; override;
procedure LoadFromFile(const AFileName: String); override;
procedure LoadFromStream(AStream: TStream); override;
function ReleaseHandle: HENHMETAFILE;
procedure SaveToFile(const AFileName: String); override;
procedure SaveToStream(AStream: TStream); override;
property CreatedBy: String read GetAuthor;
property Description: String read GetDescription;
property Empty: boolean read GetEmpty;
property Handle: HENHMETAFILE read GetHandle write SetHandle;
property MMHeight: Integer read FMMHeight write SetMMHeight;
property MMWidth: Integer read FMMWidth write SetMMWidth;
end;
{ TMetafileCanvas }
TMetafileCanvas = class(TCanvas)
strict private
FMetafile: TMetafile;
public
constructor Create(AMetafile: TMetafile; AReferenceDevice: HDC);
constructor CreateWithComment(
AMetafile: TMetafile; AReferenceDevice: HDC;
const ACreatedBy, ADescription: String);
destructor Destroy; override;
end;
{ TWindowsMetafileDrawer }
TWindowsMetafileDrawer = class(TCanvasDrawer)
strict private
FFileName: String;
FMetafile: TMetafile;
FMetafileCanvas: TMetafileCanvas;
public
constructor Create(const AFileName: String); reintroduce;
destructor Destroy; override;
public
procedure DrawingBegin(const ABoundingBox: TRect); override;
procedure DrawingEnd; override;
end;
implementation
uses
SysUtils, TAChartUtils;
{ TWindowsMetafileDrawer }
constructor TWindowsMetafileDrawer.Create(const AFileName: String);
begin
FFileName := AFileName;
FMetafile := TMetafile.Create;
inherited Create(nil);
end;
destructor TWindowsMetafileDrawer.Destroy;
begin
FreeAndNil(FCanvas);
FreeAndNil(FMetafile);
inherited Destroy;
end;
procedure TWindowsMetafileDrawer.DrawingBegin(const ABoundingBox: TRect);
begin
inherited DrawingBegin(ABoundingBox);
FCanvas := TMetafileCanvas.Create(FMetafile, 0);
end;
procedure TWindowsMetafileDrawer.DrawingEnd;
begin
FreeAndNil(FCanvas);
FMetafile.SaveToFile(FFileName);
end;
{ TMetafile }
procedure TMetafile.DeleteImage;
begin
if FImageHandle <> 0 then
DeleteEnhMetafile(FImageHandle);
FImageHandle := 0;
end;
function TMetafile.GetAuthor: String;
var
authorLength: Integer;
begin
Result := '';
if FImageHandle = 0 then exit;
authorLength := GetEnhMetafileDescription(FImageHandle, 0, nil);
if authorLength <= 0 then exit;
SetLength(Result, authorLength);
GetEnhMetafileDescription(FImageHandle, authorLength, PChar(Result));
SetLength(Result, StrLen(PChar(Result)));
end;
function TMetafile.GetDescription: String;
var
descLength: Integer;
begin
Result := '';
if FImageHandle = 0 then Exit;
descLength := GetEnhMetafileDescription(FImageHandle, 0, nil);
if descLength <= 0 then exit;
SetLength(Result, descLength);
GetEnhMetafileDescription(FImageHandle, descLength, PChar(Result));
SetLength(Result, StrLen(PChar(Result)));
end;
function TMetafile.GetEmpty: Boolean;
begin
Result := FImageHandle = 0;
end;
function TMetafile.GetHandle: HENHMETAFILE;
begin
Result := FImageHandle;
end;
procedure TMetafile.SetHandle(AValue: HENHMETAFILE);
var
emfHeader: TEnhMetaHeader;
begin
if
(AValue <> 0) and
(GetEnhMetafileHeader(AValue, sizeof(emfHeader), @emfHeader) = 0)
then
raise EInvalidImage.Create('Invalid Metafile');;
if FImageHandle <> 0 then DeleteImage;
FImageHandle := AValue;
FImagePxWidth := 0;
FImagePxHeight := 0;
FMMWidth := emfHeader.rclFrame.Right - emfHeader.rclFrame.Left;
FMMHeight := emfHeader.rclFrame.Bottom - emfHeader.rclFrame.Top;
end;
procedure TMetafile.SetMMHeight(AValue: Integer);
begin
FImagePxHeight := 0;
if FMMHeight <> AValue then FMMHeight := AValue;
end;
procedure TMetafile.SetMMWidth(AValue: Integer);
begin
FImagePxWidth := 0;
if FMMWidth <> AValue then FMMWidth := AValue;
end;
procedure TMetafile.SetTransparent(AValue: Boolean);
begin
if AValue then
raise EComponentError.Create('Not implemented');
end;
procedure TMetafile.Draw(ACanvas: TCanvas; const ARect: TRect);
var
r: TRect;
begin
if FImageHandle = 0 then exit;
r := ARect;
PlayEnhMetaFile(ACanvas.Handle, FImageHandle, r);
end;
function TMetafile.GetHeight: Integer;
var
emfHeader: TEnhMetaHeader;
begin
if FImageHandle = 0 then
exit(FImagePxHeight);
// convert 0.01mm units to device pixels
GetEnhMetaFileHeader(FImageHandle, Sizeof(emfHeader), @emfHeader);
Result := MulDiv(
FMMHeight, // metafile height in 0.01mm
emfHeader.szlDevice.cy, // device height in pixels
emfHeader.szlMillimeters.cy * 100); // device height in mm
end;
function TMetafile.GetTransparent: Boolean;
begin
Result := false;
end;
function TMetafile.GetWidth: Integer;
var
emfHeader: TEnhMetaHeader;
begin
if FImageHandle = 0 then
exit(FImagePxWidth);
// convert 0.01mm units to device pixels
GetEnhMetaFileHeader(FImageHandle, Sizeof(emfHeader), @emfHeader);
Result := MulDiv(
FMMWidth, // metafile width in 0.01mm
emfHeader.szlDevice.cx, // device width in pixels
emfHeader.szlMillimeters.cx * 100); // device width in 0.01mm
end;
procedure TMetafile.SetHeight(AValue: Integer);
var
emfHeader: TEnhMetaHeader;
begin
if FImageHandle = 0 then
FImagePxHeight := AValue
else begin // convert device pixels to 0.01mm units
GetEnhMetaFileHeader(FImageHandle, Sizeof(emfHeader), @emfHeader);
MMHeight := MulDiv(AValue, // metafile height in pixels
emfHeader.szlMillimeters.cy * 100, // device height in 0.01mm
emfHeader.szlDevice.cy); // device height in pixels
end;
end;
procedure TMetafile.SetWidth(AValue: Integer);
var
emfHeader: TEnhMetaHeader;
begin
if FImageHandle = 0 then
FImagePxWidth := AValue
else begin // convert device pixels to 0.01mm units
GetEnhMetaFileHeader(FImageHandle, Sizeof(emfHeader), @emfHeader);
MMWidth := MulDiv(AValue, // metafile width in pixels
emfHeader.szlMillimeters.cx * 100, // device width in mm
emfHeader.szlDevice.cx); // device width in pixels
end;
end;
constructor TMetafile.Create;
begin
inherited Create;
FImageHandle := 0;
end;
destructor TMetafile.Destroy;
begin
DeleteImage;
inherited Destroy;
end;
procedure TMetafile.Assign(ASource: TPersistent);
begin
if (ASource = nil) or (ASource is TMetafile) then begin
if FImageHandle <> 0 then
DeleteImage;
if Assigned(ASource) then begin
FImageHandle := TMetafile(ASource).Handle;
FMMWidth := TMetafile(ASource).MMWidth;
FMMHeight := TMetafile(ASource).MMHeight;
FImagePxWidth := TMetafile(ASource).Width;
FImagePxHeight := TMetafile(ASource).Height;
end
end
else
inherited Assign(ASource);
end;
procedure TMetafile.Clear;
begin
DeleteImage;
end;
procedure TMetafile.LoadFromFile(const AFileName: String);
begin
Unused(AFileName);
raise EComponentError.Create('Not Implemented');
end;
procedure TMetafile.SaveToFile(const AFileName: String);
var
outFile: HENHMETAFILE;
begin
if FImageHandle = 0 then exit;
outFile := CopyEnhMetaFile(FImageHandle, PChar(AFileName));
if outFile = 0 then
RaiseLastWin32Error;
DeleteEnhMetaFile(outFile);
end;
procedure TMetafile.LoadFromStream(AStream: TStream);
begin
Unused(AStream);
raise EComponentError.Create('Not Implemented');
end;
procedure TMetafile.SaveToStream(AStream: TStream);
begin
Unused(AStream);
raise EComponentError.Create('Not Implemented');
end;
function TMetafile.ReleaseHandle: HENHMETAFILE;
begin
DeleteImage;
Result := FImageHandle;
FImageHandle := 0;
end;
{ TMetafileCanvas }
constructor TMetafileCanvas.Create(AMetafile: TMetafile; AReferenceDevice: HDC);
begin
CreateWithComment(
AMetafile, AReferenceDevice, AMetafile.CreatedBy, AMetafile.Description);
end;
constructor TMetafileCanvas.CreateWithComment(
AMetafile: TMetafile; AReferenceDevice: HDC;
const ACreatedBy, ADescription: String);
var
refDC: HDC;
r: TRect;
temp: HDC;
p: PChar;
w, h: Integer;
begin
inherited Create;
FMetafile := AMetafile;
refDC := AReferenceDevice;
if refDC = 0 then
refDC := GetDC(0);
try
if FMetafile.MMWidth = 0 then begin
w := GetDeviceCaps(refDC, HORZSIZE) * 100;
if FMetafile.Width = 0 then // if no width get refDC width
FMetafile.MMWidth := w
else // else convert
FMetafile.MMWidth := MulDiv(
FMetafile.Width, w, GetDeviceCaps(refDC, HORZRES));
end;
if FMetafile.MMHeight = 0 then begin
h := GetDeviceCaps(refDC, VERTSIZE) * 100;
if FMetafile.Height = 0 then // if no height get refDC height
FMetafile.MMHeight := h
else // else convert
FMetafile.MMHeight := MulDiv(
FMetafile.Height, h, GetDeviceCaps(refDC, VERTRES));
end;
r := Rect(0, 0, FMetafile.MMWidth, FMetafile.MMHeight);
// lpDescription stores both author and description
if (Length(ACreatedBy) > 0) or (Length(ADescription) > 0) then
p := PChar(ACreatedBy+#0+ADescription+#0#0)
else
p := nil;
temp := CreateEnhMetafile(refDC, nil, @r, p);
if temp = 0 then
raise EOutOfResources.Create('Out of Resources');;
Handle := temp;
finally
if AReferenceDevice = 0 then
ReleaseDC(0, refDC);
end;
end;
destructor TMetafileCanvas.Destroy;
begin
FMetafile.Handle := CloseEnhMetafile(Handle);
inherited Destroy;
end;
end.