635ebf4a4e
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@995 8e941d3f-bd1b-0410-a28a-d453659cc2b4
445 lines
14 KiB
ObjectPascal
445 lines
14 KiB
ObjectPascal
{Version 9.45}
|
|
|
|
{$i htmlcons.inc}
|
|
|
|
unit GDIPL2A;
|
|
|
|
interface
|
|
|
|
uses
|
|
{$IFNDEF LCL} Windows, ActiveX, {$ELSE} LclIntf, LclType, Types, DynLibs, HtmlMisc, {$ENDIF}
|
|
SysUtils, Graphics;
|
|
|
|
var
|
|
GDIPlusActive: boolean;
|
|
|
|
type
|
|
TGpImage = class(TObject)
|
|
private
|
|
fHandle: integer;
|
|
fWidth, fHeight: integer;
|
|
fFilename: string;
|
|
function GetHeight: integer;
|
|
function GetWidth: integer;
|
|
public
|
|
constructor Create(Filename: string; TmpFile: boolean = False); overload;
|
|
constructor Create(IStr: IStream); overload;
|
|
destructor Destroy; override;
|
|
function GetTBitmap: TBitmap;
|
|
property Height: integer read GetHeight;
|
|
property Width: integer read GetWidth;
|
|
end;
|
|
|
|
TGpGraphics = class;
|
|
|
|
TGpBitmap = class(TGpImage)
|
|
public
|
|
constructor Create(W, H: integer); overload;
|
|
constructor Create(IStr: IStream); overload;
|
|
constructor Create(W, H: integer; Graphics: TGpGraphics); overload;
|
|
function GetPixel(X, Y: integer): DWord;
|
|
procedure SetPixel(X, Y: integer; Color: DWord);
|
|
end;
|
|
|
|
TGpGraphics = class(TObject)
|
|
private
|
|
fGraphics: integer;
|
|
procedure DrawSmallStretchedImage (Image: TGPImage; X, Y, Width, Height: Integer);
|
|
public
|
|
constructor Create(Handle: HDC); overload;
|
|
constructor Create(Image: TGpImage); overload;
|
|
destructor Destroy; override;
|
|
procedure DrawImage (Image: TGPImage; X, Y: Integer); overload;
|
|
procedure DrawImage (Image: TGPImage; X, Y, Width, Height: Integer); overload;
|
|
procedure DrawImage(Image: TGpImage; x, y, srcx, srcy, srcwidth, srcheight: integer); overload;
|
|
procedure DrawImage(Image: TGpImage; dx, dy, dw, dh, sx, sy, sw, sh: integer); overload;
|
|
procedure Clear(Color: Cardinal);
|
|
procedure ScaleTransform(sx, sy: Single);
|
|
end;
|
|
|
|
procedure CheckInitGDIPlus;
|
|
procedure CheckExitGDIPlus;
|
|
|
|
implementation
|
|
|
|
const
|
|
GdiPlusLib = 'GdiPlus.dll';
|
|
|
|
type
|
|
EGDIPlus = class (Exception);
|
|
TRectF = record
|
|
X: Single;
|
|
Y: Single;
|
|
Width: Single;
|
|
Height: Single;
|
|
end;
|
|
|
|
ImageCodecInfo = packed record
|
|
Clsid : TGUID;
|
|
FormatID : TGUID;
|
|
CodecName : PWCHAR;
|
|
DllName : PWCHAR;
|
|
FormatDescription : PWCHAR;
|
|
FilenameExtension : PWCHAR;
|
|
MimeType : PWCHAR;
|
|
Flags : DWORD;
|
|
Version : DWORD;
|
|
SigCount : DWORD;
|
|
SigSize : DWORD;
|
|
SigPattern : PBYTE;
|
|
SigMask : PBYTE;
|
|
end;
|
|
TImageCodecInfo = ImageCodecInfo;
|
|
PImageCodecInfo = ^TImageCodecInfo;
|
|
|
|
var
|
|
{$ifndef NoGDIPlus}
|
|
GdiplusStartup: function(var Token: DWord; const Input, Output: Pointer): Integer; stdcall;
|
|
GdiplusShutdown: procedure(Token: DWord); stdcall;
|
|
GdipDrawImageI: function(Graphics, Image, X, Y: Integer): Integer; stdcall;
|
|
GdipCreateHBITMAPFromBitmap: function(bitmap: integer; out hbmReturn: HBITMAP;
|
|
background: DWord): integer; stdcall;
|
|
GdipGetInterpolationMode: function(graphics: integer; var interpolationMode: integer): integer; stdcall;
|
|
{$endif$}
|
|
GdipDeleteGraphics: function(Graphics: Integer): Integer; stdcall;
|
|
GdipCreateFromHDC: function(hdc: HDC; var Graphics: Integer): Integer; stdcall;
|
|
GdipDrawImageRectI: function (Graphics, Image, X, Y, Width, Height: Integer): Integer; stdcall;
|
|
GdipLoadImageFromFile: function (const FileName: PWideChar; var Image: Integer): Integer; stdcall;
|
|
GdipLoadImageFromStream: function(stream: ISTREAM;
|
|
out image: integer): integer; stdcall;
|
|
GdipCreateBitmapFromStream: function(stream: ISTREAM; out bitmap: integer): integer; stdcall;
|
|
GdipDisposeImage: function (Image: Integer): Integer; stdcall;
|
|
GdipGetImageWidth: function (Image: Integer; var Width: Integer): Integer; stdcall;
|
|
|
|
GdipGetImageHeight: function(Image: Integer; var Height: Integer): Integer; stdcall;
|
|
GdipGetImageGraphicsContext: function(Image: integer; out graphics: integer): integer; stdcall;
|
|
GdipGraphicsClear: function(Graphics: Integer; Color: Cardinal): Integer; stdcall;
|
|
GdipCreateBitmapFromScan0: function(width: Integer; height: Integer;
|
|
stride: Integer; pixelformat: dword; scan0: Pointer;
|
|
out bitmap: integer): integer; stdcall;
|
|
GdipDrawImagePointRect: function(graphics: integer; image: integer;
|
|
x: Single; y: Single; srcx: Single; srcy: Single; srcwidth: Single;
|
|
srcheight: Single; srcUnit: integer): integer; stdcall;
|
|
GdipScaleWorldTransform: function(graphics: integer; sx: Single; sy: Single;
|
|
order: integer): integer; stdcall;
|
|
GdipCreateBitmapFromGraphics: function(width, height: Integer;
|
|
Graphics: integer; out Bitmap: integer): integer; stdcall;
|
|
GdipBitmapGetPixel: function(bitmap, x, y: Integer; var color: DWord): integer; stdcall;
|
|
GdipDrawImageRectRectI: function(graphics, image,
|
|
dstx, dsty, dstwidth, dstheight, srcx, srcy, srcwidth, srcheight,
|
|
srcUnit, imageAttributes: integer;
|
|
callback: Pointer; callbackData: integer): integer; stdcall;
|
|
|
|
GdipSetInterpolationMode: function(graphics, interpolationMode: integer): integer; stdcall;
|
|
GdipBitmapSetPixel: function(bitmap, x, y: Integer; color: DWord): Integer; stdcall;
|
|
|
|
type
|
|
TGDIStartup = packed record
|
|
Version: Integer; // Must be one
|
|
DebugEventCallback: Pointer; // Only for debug builds
|
|
SuppressBackgroundThread: Bool; // True if replacing GDI+ background processing
|
|
SuppressExternalCodecs: Bool; // True if only using internal codecs
|
|
end;
|
|
|
|
var
|
|
Err: Integer;
|
|
|
|
{ TGpGraphics }
|
|
|
|
constructor TGpGraphics.Create(Handle: HDC);
|
|
var
|
|
err: integer;
|
|
begin
|
|
inherited Create;
|
|
err := GdipCreateFromHDC (Handle, fGraphics);
|
|
if err <> 0 then
|
|
raise EGDIPlus.Create('Can''t Create Graphics');
|
|
end;
|
|
|
|
constructor TGpGraphics.Create(Image: TGpImage);
|
|
var
|
|
err: integer;
|
|
begin
|
|
inherited Create;
|
|
err := GdipGetImageGraphicsContext(image.fHandle, fgraphics);
|
|
if err <> 0 then
|
|
raise EGDIPlus.Create('Can''t Create Graphics');
|
|
end;
|
|
|
|
destructor TGpGraphics.Destroy;
|
|
begin
|
|
if fGraphics <> 0 then
|
|
GdipDeleteGraphics (fGraphics);
|
|
inherited;
|
|
end;
|
|
|
|
procedure TGpGraphics.DrawImage(Image: TGPImage; X, Y, Width, Height: Integer);
|
|
begin
|
|
if ((Image.Width <= 10) and (Width > Image.Width)) or
|
|
((Image.Height <= 10) and (Height > Image.Height)) then
|
|
DrawSmallStretchedImage(Image, X, Y, Width, Height)
|
|
else
|
|
GdipDrawImageRectI (fGraphics, Image.fHandle, X, Y, Width, Height);
|
|
end;
|
|
|
|
procedure TGpGraphics.DrawSmallStretchedImage (Image: TGPImage; X, Y, Width, Height: Integer);
|
|
{when a small image is getting enlarged, add a row and column to it copying
|
|
the last row/column to the new row/column. This gives much better interpolation.}
|
|
const
|
|
NearestNeighbor = 5;
|
|
var
|
|
g1, g2: TGpGraphics;
|
|
BM1, BM2: TGpBitmap;
|
|
W, H: integer;
|
|
Pixel: DWord;
|
|
begin
|
|
W := Image.Width+1; {new dimensions}
|
|
H := Image.Height+1;
|
|
BM1 := TGpBitmap.Create(W, H); {new bitmap with extra row and column}
|
|
try
|
|
g1 := TGpGraphics.Create(BM1);
|
|
try
|
|
g1.DrawImage(Image, 0, 0); {draw the original image}
|
|
g1.DrawImage(Image, W-1, 0, 1, H, {copy the column, then the row}
|
|
W-2, 0, 1, H);
|
|
g1.DrawImage(Image, 0, H-1, W, 1,
|
|
0, H-2, W, 1);
|
|
Pixel := BM1.GetPixel(W-2, H-2); {for some reason also need to set the lower right pixel}
|
|
BM1.SetPixel(W-1, H-1, Pixel);
|
|
BM2 := TGpBitmap.Create(Width, Height);
|
|
try
|
|
g2 := TGpGraphics.Create(BM2);
|
|
try
|
|
GdipSetInterpolationMode(g2.fGraphics, NearestNeighbor);
|
|
g2.DrawImage(BM1, 0, 0, Width, Height, {now draw the image stretched where needed}
|
|
0, 0, Image.Width, Image.Height);
|
|
DrawImage(BM2, X, Y); {now draw the image stretched where needed}
|
|
finally
|
|
g2.Free;
|
|
end;
|
|
finally
|
|
BM2.Free;
|
|
end;
|
|
finally
|
|
g1.Free;
|
|
end;
|
|
finally
|
|
BM1.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TGpGraphics.DrawImage(Image: TGPImage; X, Y: Integer);
|
|
begin
|
|
GdipDrawImageRectI (fGraphics, Image.fHandle, X, Y, Image.Width, Image.Height);
|
|
end;
|
|
|
|
procedure TGPGraphics.DrawImage(Image: TGpImage; x, y,
|
|
srcx, srcy, srcwidth, srcheight: integer);
|
|
const
|
|
UnitPixel = 2;
|
|
begin
|
|
GdipDrawImagePointRect(fGraphics, Image.fHandle, x, y,
|
|
srcx, srcy, srcwidth, srcheight, UnitPixel);
|
|
end;
|
|
|
|
procedure TGPGraphics.DrawImage(Image: TGpImage; dx, dy, dw, dh, sx, sy, sw, sh: integer);
|
|
const
|
|
UnitPixel = 2;
|
|
begin
|
|
GdipDrawImageRectRectI(fGraphics, Image.fHandle, dx, dy, dw, dh,
|
|
sx, sy, sw, sh, UnitPixel, 0, Nil, 0);
|
|
|
|
end;
|
|
|
|
procedure TGpGraphics.Clear (Color: Cardinal);
|
|
begin
|
|
GdipGraphicsClear (fGraphics, Color);
|
|
end;
|
|
|
|
procedure TGPGraphics.ScaleTransform(sx, sy: Single);
|
|
const
|
|
MatrixOrderPrepend = 0;
|
|
begin
|
|
GdipScaleWorldTransform(fGraphics, sx, sy, MatrixOrderPrepend);
|
|
end;
|
|
|
|
{ TGpImage }
|
|
|
|
constructor TGpImage.Create(Filename: string; TmpFile: boolean = False);
|
|
var
|
|
err: Integer;
|
|
Buffer: array [0..511] of WideChar;
|
|
begin
|
|
Inherited Create;
|
|
if not FileExists (FileName) then
|
|
raise EGDIPlus.Create (Format ('Image file %s not found.', [FileName]));
|
|
err := GdipLoadImageFromFile (StringToWideChar (FileName, Buffer, sizeof (Buffer)), fHandle);
|
|
if err <> 0 then
|
|
raise EGDIPlus.Create(Format ('Can''t load image file %s.', [FileName]));
|
|
if TmpFile then
|
|
fFilename := Filename;
|
|
end;
|
|
|
|
constructor TGpImage.Create(IStr: IStream);
|
|
var
|
|
err: Integer;
|
|
begin
|
|
Inherited Create;
|
|
err := GdipLoadImageFromStream(IStr, fHandle);
|
|
if err <> 0 then
|
|
raise EGDIPlus.Create('Can''t load image stream');
|
|
end;
|
|
|
|
destructor TGpImage.Destroy;
|
|
begin
|
|
GdipDisposeImage (fHandle);
|
|
if Length(fFilename) > 0 then
|
|
try
|
|
DeleteFile(fFilename);
|
|
except
|
|
end;
|
|
inherited;
|
|
end;
|
|
|
|
function TGpImage.GetWidth: integer;
|
|
begin
|
|
if fWidth = 0 then
|
|
GdipGetImageWidth (fHandle, fWidth);
|
|
Result := fWidth;
|
|
end;
|
|
|
|
function TGpImage.GetHeight: integer;
|
|
begin
|
|
if fHeight = 0 then
|
|
GdipGetImageHeight (fHandle, fHeight);
|
|
Result := fHeight;
|
|
end;
|
|
|
|
function TGpImage.GetTBitmap: TBitmap;
|
|
var
|
|
g: TGpGraphics;
|
|
begin
|
|
Result := TBitmap.Create;
|
|
Result.Width := GetWidth;
|
|
Result.Height := GetHeight;
|
|
PatBlt(Result.Canvas.Handle, 0, 0, Result.Width, Result.Height, Whiteness);
|
|
g := TGpGraphics.Create(Result.Canvas.Handle);
|
|
g.DrawImage(Self, 0, 0, Result.Width, Result.Height);
|
|
g.Free;
|
|
end;
|
|
|
|
constructor TGpBitmap.Create(W, H: integer);
|
|
const
|
|
PixelFormatGDI = $00020000; // Is a GDI-supported format
|
|
PixelFormatAlpha = $00040000; // Has an alpha component
|
|
PixelFormatCanonical = $00200000;
|
|
PixelFormat32bppARGB = (10 or (32 shl 8) or PixelFormatAlpha or PixelFormatGDI
|
|
or PixelFormatCanonical);
|
|
var
|
|
err: integer;
|
|
begin
|
|
inherited Create;
|
|
err := GdipCreateBitmapFromScan0(W, H, 0, PixelFormat32bppARGB, nil, fHandle);
|
|
if err <> 0 then
|
|
raise EGDIPlus.Create('Can''t create bitmap');
|
|
end;
|
|
|
|
constructor TGpBitmap.Create(IStr: IStream);
|
|
var
|
|
err: integer;
|
|
begin
|
|
inherited Create;
|
|
err := GdipCreateBitmapFromStream(IStr, fHandle);
|
|
if err <> 0 then
|
|
raise EGDIPlus.Create('Can''t create bitmap');
|
|
end;
|
|
|
|
constructor TGpBitmap.Create(W, H: integer; Graphics: TGpGraphics);
|
|
begin
|
|
inherited Create;
|
|
err := GdipCreateBitmapFromGraphics(W, H, Graphics.fGraphics, fHandle);
|
|
if err <> 0 then
|
|
raise EGDIPlus.Create('Can''t create bitmap');
|
|
end;
|
|
|
|
function TGpBitmap.GetPixel(X, Y: integer): DWord;
|
|
begin
|
|
GdipBitmapGetPixel(fHandle, X, Y, Result);
|
|
end;
|
|
|
|
procedure TGpBitmap.SetPixel(X, Y: integer; Color: DWord);
|
|
begin
|
|
GdipBitmapSetPixel(fHandle, X, Y, Color);
|
|
end;
|
|
|
|
{$ifndef NoGDIPlus}
|
|
var
|
|
InitToken: DWord;
|
|
Startup: TGDIStartup;
|
|
LibHandle: THandle;
|
|
GDIPlusCount: integer;
|
|
{$endif}
|
|
|
|
procedure CheckInitGDIPlus;
|
|
begin
|
|
{$ifndef NoGDIPlus}
|
|
if GDIPlusCount = 0 then
|
|
begin
|
|
LibHandle := LoadLibrary(GdiPlusLib);
|
|
if LibHandle <> 0 then
|
|
begin
|
|
@GdiplusStartup := GetProcAddress(LibHandle, 'GdiplusStartup');
|
|
@GdiplusShutdown := GetProcAddress(LibHandle, 'GdiplusShutdown');
|
|
@GdipDeleteGraphics := GetProcAddress(LibHandle, 'GdipDeleteGraphics');
|
|
@GdipCreateFromHDC := GetProcAddress(LibHandle, 'GdipCreateFromHDC');
|
|
@GdipDrawImageI := GetProcAddress(LibHandle, 'GdipDrawImageI');
|
|
@GdipDrawImageRectI := GetProcAddress(LibHandle, 'GdipDrawImageRectI');
|
|
@GdipLoadImageFromFile := GetProcAddress(LibHandle, 'GdipLoadImageFromFile');
|
|
@GdipLoadImageFromStream := GetProcAddress(LibHandle, 'GdipLoadImageFromStream');
|
|
@GdipCreateBitmapFromStream:= GetProcAddress(LibHandle, 'GdipCreateBitmapFromStream');
|
|
@GdipDisposeImage := GetProcAddress(LibHandle, 'GdipDisposeImage');
|
|
@GdipGetImageWidth := GetProcAddress(LibHandle, 'GdipGetImageWidth');
|
|
@GdipGetImageHeight := GetProcAddress(LibHandle, 'GdipGetImageHeight');
|
|
@GdipGetImageGraphicsContext := GetProcAddress(LibHandle, 'GdipGetImageGraphicsContext');
|
|
@GdipGraphicsClear := GetProcAddress(LibHandle, 'GdipGraphicsClear');
|
|
@GdipCreateBitmapFromScan0 := GetProcAddress(LibHandle, 'GdipCreateBitmapFromScan0');
|
|
@GdipDrawImagePointRect := GetProcAddress(LibHandle, 'GdipDrawImagePointRect');
|
|
@GdipScaleWorldTransform := GetProcAddress(LibHandle, 'GdipScaleWorldTransform');
|
|
@GdipCreateBitmapFromGraphics := GetProcAddress(LibHandle, 'GdipCreateBitmapFromGraphics');
|
|
@GdipBitmapGetPixel := GetProcAddress(LibHandle, 'GdipBitmapGetPixel');
|
|
@GdipDrawImageRectRectI := GetProcAddress(LibHandle, 'GdipDrawImageRectRectI');
|
|
@GdipCreateHBITMAPFromBitmap := GetProcAddress(LibHandle, 'GdipCreateHBITMAPFromBitmap');
|
|
|
|
@GdipSetInterpolationMode := GetProcAddress(LibHandle, 'GdipSetInterpolationMode');
|
|
@GdipGetInterpolationMode := GetProcAddress(LibHandle, 'GdipGetInterpolationMode');
|
|
@GdipBitmapSetPixel := GetProcAddress(LibHandle, 'GdipBitmapSetPixel');
|
|
|
|
FillChar (Startup, sizeof (Startup), 0);
|
|
Startup.Version := 1;
|
|
Err := GdiPlusStartup (InitToken, @Startup, nil);
|
|
GDIPlusActive := Err = 0;
|
|
if not GDIPlusActive then
|
|
FreeLibrary(LibHandle);
|
|
end;
|
|
end;
|
|
Inc(GDIPlusCount);
|
|
{$endif}
|
|
end;
|
|
|
|
procedure CheckExitGDIPlus;
|
|
begin
|
|
{$ifndef NoGDIPlus}
|
|
Dec(GDIPlusCount);
|
|
if GDIPlusCount = 0 then
|
|
if GDIPlusActive then
|
|
begin
|
|
GdiplusShutdown (InitToken);
|
|
FreeLibrary(LibHandle);
|
|
GDIPlusActive := False;
|
|
end;
|
|
{$endif}
|
|
end;
|
|
|
|
end.
|
|
|