unit Dpi.Graphics; interface uses Classes, SysUtils, Math, Graphics, LCLType, GraphType, Types; const clBlack = TColor($000000); clWhite = TColor($ffffff); type TColor = Graphics.TColor; TPixelFormat = Graphics.TPixelFormat; TFontStyle = Graphics.TFontStyle; { TFont } TFont = class(TPersistent) private FNativeFont: Graphics.TFont; FNativeFontFree: Boolean; FOnChange: TNotifyEvent; FSize: Integer; FHeight: Integer; FPixelsPerInch: Integer; FColor: TColor; function GetCharSet: TFontCharSet; function GetColor: TColor; function GetHeight: Integer; function GetName: string; function GetPixelsPerInch: Integer; function GetSize: Integer; function GetStyle: TFontStyles; function IsNameStored: Boolean; procedure SetCharSet(AValue: TFontCharSet); procedure SetColor(AValue: TColor); procedure SetHeight(AValue: Integer); procedure SetName(AValue: string); procedure SetNativeFont(AValue: Graphics.TFont); procedure SetPixelsPerInch(AValue: Integer); procedure SetSize(AValue: Integer); procedure DoChange; procedure SetStyle(AValue: TFontStyles); procedure UpdateFont; protected function GetNativeFont: Graphics.TFont; virtual; public procedure ScreenChanged; property NativeFont: Graphics.TFont read FNativeFont write SetNativeFont; constructor Create; destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure GetTextSize(Text: string; var w, h: Integer); function GetTextHeight(Text: string): Integer; function GetTextWidth(Text: string): Integer; published property CharSet: TFontCharSet read GetCharSet write SetCharSet default DEFAULT_CHARSET; property Color: TColor read GetColor write SetColor; property Name: string read GetName write SetName stored IsNameStored; property Style: TFontStyles read GetStyle write SetStyle default []; property Size: Integer read GetSize write SetSize stored false; property PixelsPerInch: Integer read GetPixelsPerInch write SetPixelsPerInch; property Height: Integer read GetHeight write SetHeight default 0; property OnChange: TNotifyEvent read FOnChange write FOnChange; end; { TPen } TPen = class FWidth: Integer; FNativePen: Graphics.TPen; FNativePenFree: Boolean; private function GetColor: TColor; function GetStyle: TPenStyle; function GetWidth: Integer; procedure SetColor(AValue: TColor); procedure SetNativePen(AValue: Graphics.TPen); procedure SetStyle(AValue: TPenStyle); procedure SetWidth(AValue: Integer); public constructor Create; destructor Destroy; override; function GetNativePen: Graphics.TPen; procedure Assign(Source: TPen); property NativePen: Graphics.TPen read FNativePen write SetNativePen; published property Color: TColor read GetColor write SetColor default clBlack; property Style : TPenStyle read GetStyle write SetStyle default psSolid; property Width: Integer read GetWidth write SetWidth default 1; end; TBrushStyle = Graphics.TBrushStyle; TPenStyle = Graphics.TPenStyle; { TBrush } TBrush = class private FNativeBrush: Graphics.TBrush; FNativeBrushFree: Boolean; function GetColor: TColor; function GetStyle: TBrushStyle; procedure SetColor(AValue: TColor); function GetNativeBrush: Graphics.TBrush; procedure SetNativeBrush(AValue: Graphics.TBrush); procedure SetStyle(AValue: TBrushStyle); public constructor Create; destructor Destroy; override; procedure Assign(Source: TBrush); property NativeBrush: Graphics.TBrush read FNativeBrush write SetNativeBrush; published property Color: TColor read GetColor write SetColor default clWhite; property Style: TBrushStyle read GetStyle write SetStyle default bsSolid; end; TGraphic = class; { TCanvas } TCanvas = class private FBrush: TBrush; FBrushFree: Boolean; FPen: TPen; FPenFree: Boolean; FFont: TFont; FFontFree: Boolean; FNativeCanvas: Graphics.TCanvas; FNativeCanvasFree: Boolean; function GetHandle: HDC; function GetPixel(X, Y: Integer): TColor; function GetTextStyle: TTextStyle; procedure SetBrush(AValue: TBrush); procedure SetFont(AValue: TFont); procedure SetHandle(AValue: HDC); procedure SetPen(AValue: TPen); procedure SetPixel(X, Y: Integer; AValue: TColor); procedure SetNativeCanvas(AValue: Graphics.TCanvas); procedure SetTextStyle(AValue: TTextStyle); protected procedure DoLine(X1, Y1, X2, Y2: Integer); virtual; procedure DoTextOut(X, Y: Integer; Text: string); virtual; procedure DoRectangle(const Bounds: TRect); virtual; procedure DoRectangleFill(const Bounds: TRect); virtual; procedure DoPolygon(const Points: array of TPoint); virtual; procedure CreateHandle; virtual; procedure DoEllipse(const Bounds: TRect); virtual; procedure DoMoveTo(X, Y: Integer); virtual; procedure DoLineTo(X, Y: Integer); virtual; procedure DoPolyline(const Points: array of TPoint); virtual; procedure DoPolyBezier(Points: PPoint; NumPts: Integer; Filled: Boolean = False; Continuous: Boolean = False); virtual; procedure SetHeight(AValue: Integer); virtual; procedure SetWidth(AValue: Integer); virtual; function GetWidth: Integer; virtual; function GetHeight: Integer; virtual; function GetNativeCanvas: Graphics.TCanvas; virtual; public property NativeCanvas: Graphics.TCanvas read FNativeCanvas write SetNativeCanvas; procedure RoundRect(const Rect: TRect; RX, RY: Integer); overload; procedure RoundRect(X1, Y1, X2, Y2: Integer; RX,RY: Integer); overload; virtual; procedure Polygon(const Points: array of TPoint; Winding: Boolean; StartIndex: Integer = 0; NumPts: Integer = -1); overload; procedure Polygon(Points: PPoint; NumPts: Integer; Winding: Boolean = False); virtual; overload; procedure Polygon(const Points: array of TPoint); overload; procedure PolyBezier(const Points: array of TPoint; Filled: Boolean = False; Continuous: boolean = True); overload; procedure PolyBezier(Points: PPoint; NumPts: Integer; Filled: Boolean = False; Continuous: Boolean = True); virtual; overload; procedure Polyline(const Points: array of TPoint); overload; procedure Polyline(Points: PPoint; NumPts: Integer); virtual; overload; procedure Ellipse(x1, y1, x2, y2: Integer); virtual; overload; procedure Ellipse(const ARect: TRect); virtual; overload; // procedure StretchDraw(const DestRect: TRect; SrcGraphic: Graphics.TGraphic); virtual; overload; procedure StretchDraw(const DestRect: TRect; SrcGraphic: TGraphic); virtual; overload; procedure Pie(EllipseX1, EllipseY1, EllipseX2, EllipseY2, StartX, StartY, EndX, EndY: Integer); virtual; procedure FrameRect(Rect: TRect); procedure Rectangle(X1, Y1, X2, Y2: Integer); overload; procedure Rectangle(const ARect: TRect); overload; function TextWidth(const Text: string): Integer; function TextHeight(const Text: string): Integer; function TextExtent(const Text: string): TSize; virtual; procedure TextOut(X, Y: Integer; const Text: string); virtual; procedure TextRect(ARect: TRect; X, Y: Integer; Text: string); overload; procedure TextRect(ARect: TRect; X, Y: integer; const Text: string; const Style: TTextStyle); overload; procedure MoveTo(X, Y: Integer); procedure LineTo(X, Y: Integer); procedure Line(const p1, p2: TPoint); procedure FillRect(const ARect: TRect); virtual; overload; procedure FillRect(X1, Y1, X2, Y2: Integer); overload; procedure Draw(X, Y: Integer; Source: TGraphic); procedure CopyRect(Dest: TRect; SrcCanvas: TCanvas; Source: TRect); constructor Create; destructor Destroy; override; property Handle: HDC read GetHandle write SetHandle; property Pixels[X, Y: Integer]: TColor read GetPixel write SetPixel; property Width: Integer read GetWidth; property Height: Integer read GetHeight; property TextStyle: TTextStyle read GetTextStyle write SetTextStyle; published property Brush: TBrush read FBrush write SetBrush; property Pen: TPen read FPen write SetPen; property Font: TFont read FFont write SetFont; end; { TGraphic } TGraphic = class(TPersistent) protected FDpi: Integer; function GetNativeGraphic: Graphics.TGraphic; virtual; function GetWidth: Integer; virtual; abstract; function GetHeight: Integer; virtual; abstract; procedure SetWidth(Value: Integer); virtual; abstract; procedure SetHeight(Value: Integer); virtual; abstract; procedure ScreenChanged; virtual; procedure SetDpi(AValue: Integer); virtual; function GetDpi: Integer; virtual; public NativeGraphicClass: TGraphicClass; constructor Create; virtual; procedure LoadFromFile(const Filename: string); virtual; procedure SaveToFile(const Filename: string); virtual; property Width: Integer read GetWidth write SetWidth; property Height: Integer read GetHeight write SetHeight; property Dpi: Integer read GetDpi write SetDpi; end; { TRasterImage } TRasterImage = class(TGraphic) private FCanvas: TCanvas; function GetCanvas: TCanvas; function GetRawImage: TRawImage; protected function GetHeight: Integer; override; function GetWidth: Integer; override; function GetPixelFormat: TPixelFormat; virtual; abstract; procedure SetWidth(Value: Integer); override; procedure SetHeight(Value: Integer); override; procedure SetSize(AWidth, AHeight: Integer); virtual; abstract; procedure SetPixelFormat(AValue: TPixelFormat); virtual; abstract; function GetNativeGraphic: Graphics.TGraphic; override; function GetNativeRasterImage: Graphics.TRasterImage; virtual; procedure SetNativeRasterImage(CustomBitmap: Graphics.TRasterImage); virtual; abstract; public constructor Create; override; destructor Destroy; override; procedure BeginUpdate(ACanvasOnly: Boolean = False); procedure EndUpdate(AStreamIsValid: Boolean = False); property Canvas: TCanvas read GetCanvas; property RawImage: TRawImage read GetRawImage; property PixelFormat: TPixelFormat read GetPixelFormat write SetPixelFormat; end; { TCustomBitmap } TCustomBitmap = class(TRasterImage) private FWidth: Integer; FHeight: Integer; protected function GetHeight: Integer; override; function GetWidth: Integer; override; function GetPixelFormat: TPixelFormat; override; procedure SetPixelFormat(AValue: TPixelFormat); override; function GetNativeCustomBitmap: Graphics.TCustomBitmap; virtual; function GetNativeRasterImage: Graphics.TRasterImage; override; procedure SetNativeRasterImage(RasterImage: Graphics.TRasterImage); override; procedure SetNativeCustomBitmap(CustomBitmap: Graphics.TCustomBitmap); virtual; abstract; procedure ScreenChanged; override; public procedure Assign(Source: TPersistent); override; procedure SetSize(AWidth, AHeight: Integer); override; end; { TBitmap } TBitmap = class(TCustomBitmap) private function GetScanLine(Row: Integer): Pointer; function GetTransparent: Boolean; function GetTransparentColor: TColor; procedure SetTransparent(AValue: Boolean); procedure SetTransparentColor(AValue: TColor); protected function GetNativeBitmap: Graphics.TBitmap; virtual; function GetNativeCustomBitmap: Graphics.TCustomBitmap; override; procedure SetNativeBitmap(ANativeBitmap: Graphics.TBitmap); virtual; procedure SetNativeCustomBitmap(CustomBitmap: Graphics.TCustomBitmap); override; public NativeBitmap: Graphics.TBitmap; constructor Create; override; destructor Destroy; override; property ScanLine[Row: Integer]: Pointer read GetScanLine; published property TransparentColor: TColor read GetTransparentColor write SetTransparentColor default clDefault; property Transparent: Boolean read GetTransparent write SetTransparent default False; end; { TJpegImage } TJpegImage = class(TCustomBitmap) protected function GetNativeCustomBitmap: Graphics.TCustomBitmap; override; function GetNativeJpeg: Graphics.TJPEGImage; virtual; procedure SetNativeCustomBitmap(CustomBitmap: Graphics.TCustomBitmap); override; procedure SetNativeJpeg(Jpeg: Graphics.TJPEGImage); virtual; public NativeJpeg: Graphics.TJPEGImage; constructor Create; override; destructor Destroy; override; end; { TPortableNetworkGraphic } TPortableNetworkGraphic = class(TCustomBitmap) protected function GetNativeCustomBitmap: Graphics.TCustomBitmap; override; function GetNativePng: Graphics.TPortableNetworkGraphic; virtual; procedure SetNativeCustomBitmap(CustomBitmap: Graphics.TCustomBitmap); override; procedure SetNativePng(Png: Graphics.TPortableNetworkGraphic); virtual; public NativePng: Graphics.TPortableNetworkGraphic; constructor Create; override; destructor Destroy; override; end; { TPicture } TPicture = class(TPersistent) private FBitmap: TBitmap; procedure SetBitmap(AValue: TBitmap); published procedure LoadFromFile(FileName: string); property Bitmap: TBitmap read FBitmap write SetBitmap; end; { TScreenInfo } TScreenInfo = record private FDpi: Integer; procedure SetDpi(AValue: Integer); public ToNative: Double; FromNative: Double; LookupToNative: array[-10000..10000] of Integer; // Should be sufficient for 8K screens LookupFromNative: array[-10000..10000] of Integer; // Should be sufficient for 8K screens property Dpi: Integer read FDpi write SetDpi; end; var ScreenInfo: TScreenInfo; implementation uses Dpi.Common, NativePixelPointer; { TCustomBitmap } function TCustomBitmap.GetHeight: Integer; begin Result := FHeight; end; function TCustomBitmap.GetWidth: Integer; begin Result := FWidth; end; function TCustomBitmap.GetPixelFormat: TPixelFormat; begin Result := GetNativeCustomBitmap.PixelFormat; end; procedure TCustomBitmap.SetPixelFormat(AValue: TPixelFormat); begin GetNativeCustomBitmap.PixelFormat := AValue; end; function TCustomBitmap.GetNativeCustomBitmap: Graphics.TCustomBitmap; begin Result := nil; end; function TCustomBitmap.GetNativeRasterImage: Graphics.TRasterImage; begin Result := GetNativeCustomBitmap; end; procedure TCustomBitmap.SetNativeRasterImage(RasterImage: Graphics.TRasterImage ); begin SetNativeCustomBitmap(Graphics.TCustomBitmap(RasterImage)); end; procedure TCustomBitmap.ScreenChanged; var Bitmap: Graphics.TCustomBitmap; NewWidth: Integer; NewHeight: Integer; begin NewWidth := ScaleToNative(Width); NewHeight := ScaleToNative(Height); if Assigned(GetNativeCustomBitmap) and ((NewWidth <> GetNativeCustomBitmap.Width) or (NewHeight <> GetNativeCustomBitmap.Height)) then begin // Rescale bitmap to new size if NativeGraphicClass = Graphics.TBitmap then Bitmap := Graphics.TBitmap.Create else if NativeGraphicClass = Graphics.TPortableNetworkGraphic then Bitmap := Graphics.TPortableNetworkGraphic.Create else if NativeGraphicClass = Graphics.TJPEGImage then Bitmap := Graphics.TJPEGImage.Create else raise Exception.Create('Unsupported image class'); Bitmap.SetSize(NewWidth, NewHeight); Bitmap.PixelFormat := GetNativeCustomBitmap.PixelFormat; Bitmap.Canvas.StretchDraw(Bounds(0, 0, NewWidth, NewHeight), GetNativeCustomBitmap); GetNativeCustomBitmap.Free; SetNativeCustomBitmap(Bitmap); Canvas.NativeCanvas := GetNativeCustomBitmap.Canvas; end; end; procedure TCustomBitmap.Assign(Source: TPersistent); begin if Source is TCustomBitmap then begin GetNativeCustomBitmap.Assign(TCustomBitmap(Source).GetNativeCustomBitmap); FWidth := TCustomBitmap(Source).FWidth; FHeight := TCustomBitmap(Source).FHeight end else inherited; end; procedure TCustomBitmap.SetSize(AWidth, AHeight: Integer); begin FWidth := AWidth; FHeight := AHeight; GetNativeCustomBitmap.SetSize(ScaleToNative(AWidth), ScaleToNative(AHeight)); end; { TFont } procedure TFont.SetSize(AValue: Integer); begin if FSize = AValue then Exit; FSize := AValue; FHeight := -MulDiv(FSize, FPixelsPerInch, 72); UpdateFont; DoChange; end; procedure TFont.DoChange; begin if Assigned(FOnChange) then FOnChange(Self); end; procedure TFont.SetStyle(AValue: TFontStyles); begin GetNativeFont.Style := AValue; end; procedure TFont.UpdateFont; begin if Assigned(GetNativeFont) then begin GetNativeFont.PixelsPerInch := FPixelsPerInch; GetNativeFont.Size := FSize; end; end; procedure TFont.ScreenChanged; begin DoChange; end; function TFont.GetNativeFont: Graphics.TFont; begin Result := NativeFont; end; procedure TFont.SetPixelsPerInch(AValue: Integer); begin FPixelsPerInch := PixelsPerInch; FHeight := -MulDiv(FSize, FPixelsPerInch, 72); UpdateFont; end; function TFont.GetName: string; begin Result := GetNativeFont.Name; end; function TFont.GetColor: TColor; begin Result := FColor; end; function TFont.GetCharSet: TFontCharSet; begin Result := GetNativeFont.CharSet; end; function TFont.GetHeight: Integer; begin Result := GetNativeFont.Height; end; function TFont.GetPixelsPerInch: Integer; begin Result := FPixelsPerInch; end; function TFont.GetSize: Integer; begin Result := FSize; end; function TFont.GetStyle: TFontStyles; begin Result := GetNativeFont.Style; end; function TFont.IsNameStored: Boolean; begin Result := GetNativeFont.Name <> 'default'; end; procedure TFont.SetCharSet(AValue: TFontCharSet); begin GetNativeFont.CharSet := AValue; end; procedure TFont.SetColor(AValue: TColor); begin if FColor = AValue then Exit; FColor := AValue; GetNativeFont.Color := AValue; end; procedure TFont.SetHeight(AValue: Integer); begin FHeight := AValue; FSize := MulDiv(-FHeight, 72, FPixelsPerInch); UpdateFont; end; procedure TFont.SetName(AValue: string); begin GetNativeFont.Name := AValue; end; procedure TFont.SetNativeFont(AValue: Graphics.TFont); begin if FNativeFont = AValue then Exit; if FNativeFontFree then FreeAndNil(FNativeFont); FNativeFontFree := False; FNativeFont := AValue; end; constructor TFont.Create; begin FNativeFont := Graphics.TFont.Create; FNativeFontFree := True; FPixelsPerInch := ScreenInfo.Dpi; Size := 8; Color := clDefault; end; destructor TFont.Destroy; begin if FNativeFontFree then FreeAndNil(FNativeFont); inherited; end; procedure TFont.Assign(Source: TPersistent); begin if Source is TFont then begin GetNativeFont.Assign((Source as TFont).GetNativeFont); Size := (Source as TFont).Size; Height := (Source as TFont).Height; PixelsPerInch := (Source as TFont).PixelsPerInch; FOnChange := (Source as TFont).FOnChange; Color := (Source as TFont).Color; end; end; procedure TFont.GetTextSize(Text: string; var w, h: Integer); begin W := GetTextWidth(Text); H := GetTextHeight(Text); end; function TFont.GetTextHeight(Text: string): Integer; begin Result := ScaleFromNative(GetNativeFont.GetTextHeight(Text)); end; function TFont.GetTextWidth(Text: string): Integer; begin Result := ScaleFromNative(GetNativeFont.GetTextWidth(Text)); end; { TRasterImage } function TRasterImage.GetCanvas: TCanvas; begin Result := FCanvas; end; function TRasterImage.GetRawImage: TRawImage; begin Result := GetNativeRasterImage.RawImage; end; function TRasterImage.GetHeight: Integer; begin Result := ScaleFromNative(GetNativeRasterImage.Height); end; function TRasterImage.GetWidth: Integer; begin Result := ScaleFromNative(GetNativeRasterImage.Width); end; procedure TRasterImage.SetWidth(Value: Integer); begin SetSize(Value, Height); end; procedure TRasterImage.SetHeight(Value: Integer); begin SetSize(Width, Value); end; function TRasterImage.GetNativeRasterImage: Graphics.TRasterImage; begin Result := nil; end; constructor TRasterImage.Create; begin inherited; FCanvas := TCanvas.Create; FCanvas.NativeCanvas := GetNativeRasterImage.Canvas; end; destructor TRasterImage.Destroy; begin FreeAndNil(FCanvas); inherited; end; procedure TRasterImage.BeginUpdate(ACanvasOnly: Boolean); begin GetNativeRasterImage.BeginUpdate(ACanvasOnly); end; procedure TRasterImage.EndUpdate(AStreamIsValid: Boolean); begin GetNativeRasterImage.EndUpdate(AStreamIsValid); end; function TRasterImage.GetNativeGraphic: Graphics.TGraphic; begin Result := GetNativeRasterImage; end; { TGraphic } function TGraphic.GetNativeGraphic: Graphics.TGraphic; begin Result := nil; end; procedure TGraphic.ScreenChanged; begin end; procedure TGraphic.SetDpi(AValue: Integer); begin FDpi := AValue; ScreenChanged; end; function TGraphic.GetDpi: Integer; begin Result := FDpi; end; constructor TGraphic.Create; begin Dpi := ScreenInfo.Dpi; end; procedure StretchDrawBitmap(Src: Graphics.TRasterImage; Dst: Graphics.TCustomBitmap); var SrcPtr: TPixelPointer; DstPtr: TPixelPointer; XX, YY: Integer; DstPixelX, DstPixelY: Integer; DstPixelWidth, DstPixelHeight: Integer; begin Dst.BeginUpdate; SrcPtr := TPixelPointer.Create(Src, 0, 0); DstPtr := TPixelPointer.Create(Dst, 0, 0); for YY := 0 to Src.Height - 1 do begin DstPixelHeight := ScaleToNative(YY + 1) - ScaleToNative(YY); for DstPixelY := 0 to DstPixelHeight - 1 do begin for XX := 0 to Src.Width - 1 do begin DstPixelWidth := ScaleToNative(XX + 1) - ScaleToNative(XX); for DstPixelX := 0 to DstPixelWidth - 1 do begin DstPtr.PixelRGB := SrcPtr.PixelRGB; DstPtr.NextPixel; end; SrcPtr.NextPixel; end; DstPtr.NextLine; SrcPtr.SetX(0); end; SrcPtr.NextLine; end; Dst.EndUpdate; end; procedure TGraphic.LoadFromFile(const Filename: string); var Bitmap: Graphics.TGraphic; begin Bitmap := NativeGraphicClass.Create; try Bitmap.LoadFromFile(FileName); if Self is TRasterImage then begin TRasterImage(Self).SetSize(Bitmap.Width, Bitmap.Height); end else begin Width := Bitmap.Width; Height := Bitmap.Height; end; if Self is TCustomBitmap then begin StretchDrawBitmap(Graphics.TRasterImage(Bitmap), Graphics.TCustomBitmap(GetNativeGraphic)); //Graphics.TBitmap(GetNativeGraphic).Canvas.StretchDraw(Bounds(0, 0, //Graphics.TBitmap(GetNativeGraphic).Width, TBitmap(GetNativeGraphic).Height), Bitmap); end else raise Exception.Create('Unsupported class ' + Self.ClassName); finally FreeAndNil(Bitmap); end; end; procedure TGraphic.SaveToFile(const Filename: string); var Bitmap: Graphics.TGraphic; begin Bitmap := NativeGraphicClass.Create; try Bitmap.Width := Width; Bitmap.Height := Height; if Self is TBitmap then begin if Bitmap is Graphics.TRasterImage then (Bitmap as Graphics.TRasterImage).Canvas.StretchDraw(Bounds(0, 0, Bitmap.Width, Bitmap.Height), Graphics.TBitmap(GetNativeGraphic)) else raise Exception.Create('Expected TRasterImage but got ' + Bitmap.ClassName); end else raise Exception.Create('Unsupported class ' + Self.ClassName); Bitmap.SaveToFile(FileName); finally FreeAndNil(Bitmap); end; end; { TBitmap } function TBitmap.GetScanLine(Row: Integer): Pointer; begin Result := GetNativeBitmap.ScanLine[Row]; end; function TBitmap.GetTransparent: Boolean; begin Result := GetNativeBitmap.Transparent; end; function TBitmap.GetTransparentColor: TColor; begin Result := GetNativeBitmap.TransparentColor; end; procedure TBitmap.SetTransparent(AValue: Boolean); begin GetNativeBitmap.Transparent := AValue; end; procedure TBitmap.SetTransparentColor(AValue: TColor); begin GetNativeBitmap.TransparentColor := AValue; end; function TBitmap.GetNativeBitmap: Graphics.TBitmap; begin Result := NativeBitmap; end; function TBitmap.GetNativeCustomBitmap: Graphics.TCustomBitmap; begin Result := GetNativeBitmap; end; procedure TBitmap.SetNativeBitmap(ANativeBitmap: Graphics.TBitmap); begin NativeBitmap := ANativeBitmap; end; procedure TBitmap.SetNativeCustomBitmap(CustomBitmap: Graphics.TCustomBitmap); begin SetNativeBitmap(Graphics.TBitmap(CustomBitmap)); end; constructor TBitmap.Create; begin NativeGraphicClass := Graphics.TBitmap; NativeBitmap := Graphics.TBitmap.Create; inherited; end; destructor TBitmap.Destroy; begin FreeAndNil(FCanvas); FreeAndNil(NativeBitmap); inherited; end; { TPen } function TPen.GetColor: TColor; begin Result := GetNativePen.Color; end; function TPen.GetStyle: TPenStyle; begin Result := GetNativePen.Style; end; function TPen.GetWidth: Integer; begin Result := FWidth; end; procedure TPen.SetColor(AValue: TColor); begin GetNativePen.Color := AValue; end; procedure TPen.SetNativePen(AValue: Graphics.TPen); begin if FNativePen = AValue then Exit; if FNativePenFree then FreeAndNil(FNativePen); FNativePenFree := False; FNativePen := AValue; SetWidth(FWidth); end; procedure TPen.SetStyle(AValue: TPenStyle); begin GetNativePen.Style := AValue; end; procedure TPen.SetWidth(AValue: Integer); begin GetNativePen.Width := ScaleToNative(AValue); FWidth := AValue; end; constructor TPen.Create; begin FNativePen := Graphics.TPen.Create; FNativePenFree := True; FWidth := 1; end; destructor TPen.Destroy; begin if FNativePenFree then FreeAndNil(FNativePen); inherited; end; function TPen.GetNativePen: Graphics.TPen; begin Result := FNativePen; end; procedure TPen.Assign(Source: TPen); begin FWidth := Source.FWidth; GetNativePen.Assign(Source.GetNativePen); end; { TBrush } function TBrush.GetColor: TColor; begin Result := GetNativeBrush.Color; end; function TBrush.GetStyle: TBrushStyle; begin Result := GetNativeBrush.Style; end; procedure TBrush.SetColor(AValue: TColor); begin GetNativeBrush.Color := AValue; end; function TBrush.GetNativeBrush: Graphics.TBrush; begin Result := FNativeBrush; end; procedure TBrush.SetNativeBrush(AValue: Graphics.TBrush); begin if FNativeBrush = AValue then Exit; if FNativeBrushFree then FreeAndNil(FNativeBrush); FNativeBrushFree := False; FNativeBrush := AValue; end; procedure TBrush.SetStyle(AValue: TBrushStyle); begin GetNativeBrush.Style := AValue; end; constructor TBrush.Create; begin FNativeBrush := Graphics.TBrush.Create; FNativeBrushFree := True; end; destructor TBrush.Destroy; begin if FNativeBrushFree then FreeAndNil(FNativeBrush); inherited; end; procedure TBrush.Assign(Source: TBrush); begin GetNativeBrush.Assign(Source.GetNativeBrush); end; { TCanvas } function TCanvas.GetHandle: HDC; begin Result := GetNativeCanvas.Handle; end; function TCanvas.GetHeight: Integer; begin Result := ScaleFromNative(GetNativeCanvas.Height); end; function TCanvas.GetPixel(X, Y: Integer): TColor; begin Result := GetNativeCanvas.Pixels[ScaleToNative(X), ScaleToNative(Y)]; end; function TCanvas.GetTextStyle: TTextStyle; begin Result := GetNativeCanvas.TextStyle; end; function TCanvas.GetWidth: Integer; begin Result := ScaleFromNative(GetNativeCanvas.Width); end; procedure TCanvas.SetBrush(AValue: TBrush); begin if FBrush = AValue then Exit; if FBrushFree then FreeAndNil(FBrush); FBrushFree := False; FBrush := AValue; end; procedure TCanvas.SetFont(AValue: TFont); begin if FFont = AValue then Exit; if FFontFree then FreeAndNil(FFont); FFontFree := False; FFont := AValue; end; procedure TCanvas.SetHandle(AValue: HDC); begin GetNativeCanvas.Handle := AValue; end; procedure TCanvas.SetHeight(AValue: Integer); begin GetNativeCanvas.Height; end; procedure TCanvas.SetWidth(AValue: Integer); begin end; procedure TCanvas.SetPen(AValue: TPen); begin if FPen = AValue then Exit; if FPenFree then FreeAndNil(FPen); FPenFree := False; FPen := AValue; end; procedure TCanvas.SetPixel(X, Y: Integer; AValue: TColor); var BrushStyle: TBrushStyle; BrushColor: TColor; begin { BrushStyle := GetNativeCanvas.Brush.Style; BrushColor := GetNativeCanvas.Brush.Color; GetNativeCanvas.Brush.Color := AValue; GetNativeCanvas.Brush.Style := bsClear; GetNativeCanvas.FillRect(ScaleToNative(X), ScaleToNative(Y), ScaleToNative(X + 1) - 1, ScaleToNative(Y + 1) - 1); GetNativeCanvas.Brush.Style := BrushStyle; GetNativeCanvas.Brush.Color := BrushColor; } GetNativeCanvas.Pixels[ScaleToNative(X), ScaleToNative(Y)] := AValue; end; procedure TCanvas.SetNativeCanvas(AValue: Graphics.TCanvas); begin if FNativeCanvas = AValue then Exit; if FNativeCanvasFree then FreeAndNil(FNativeCanvas); FNativeCanvasFree := False; FNativeCanvas := AValue; if Assigned(FNativeCanvas) then begin FFont.NativeFont := FNativeCanvas.Font; FBrush.NativeBrush := FNativeCanvas.Brush; FPen.NativePen := FNativeCanvas.Pen; end; end; procedure TCanvas.SetTextStyle(AValue: TTextStyle); begin GetNativeCanvas.TextStyle := AValue; end; procedure TCanvas.DoLine(X1, Y1, X2, Y2: Integer); begin raise ENotImplemented.Create(SNotImplemented); end; procedure TCanvas.DoTextOut(X, Y: Integer; Text: string); begin raise ENotImplemented.Create(SNotImplemented); end; procedure TCanvas.DoRectangle(const Bounds: TRect); begin raise ENotImplemented.Create(SNotImplemented); end; procedure TCanvas.DoRectangleFill(const Bounds: TRect); begin raise ENotImplemented.Create(SNotImplemented); end; procedure TCanvas.DoPolygon(const Points: array of TPoint); begin raise ENotImplemented.Create(SNotImplemented); end; procedure TCanvas.CreateHandle; begin raise ENotImplemented.Create(SNotImplemented); end; procedure TCanvas.DoEllipse(const Bounds: TRect); begin raise ENotImplemented.Create(SNotImplemented); end; procedure TCanvas.DoMoveTo(X, Y: Integer); begin raise ENotImplemented.Create(SNotImplemented); end; procedure TCanvas.DoLineTo(X, Y: Integer); begin raise ENotImplemented.Create(SNotImplemented); end; procedure TCanvas.DoPolyline(const Points: array of TPoint); begin raise ENotImplemented.Create(SNotImplemented); end; procedure TCanvas.DoPolyBezier(Points: PPoint; NumPts: Integer; Filled: Boolean; Continuous: Boolean); begin raise ENotImplemented.Create(SNotImplemented); end; function TCanvas.GetNativeCanvas: Graphics.TCanvas; begin Result := NativeCanvas; end; procedure TCanvas.RoundRect(const Rect: TRect; RX, RY: Integer); begin GetNativeCanvas.RoundRect(Rect, RX, RY); end; procedure TCanvas.RoundRect(X1, Y1, X2, Y2: Integer; RX, RY: Integer); begin GetNativeCanvas.RoundRect(X1, Y1, X2, Y2, RX, RY); end; procedure TCanvas.Polygon(const Points: array of TPoint; Winding: Boolean; StartIndex: Integer; NumPts: Integer); begin GetNativeCanvas.Polygon(Points, Winding, StartIndex, NumPts); end; procedure TCanvas.Polygon(Points: PPoint; NumPts: Integer; Winding: Boolean); begin GetNativeCanvas.Polygon(Points, NumPts, Winding); end; procedure TCanvas.Polygon(const Points: array of TPoint); begin GetNativeCanvas.Polygon(Points); end; procedure TCanvas.PolyBezier(const Points: array of TPoint; Filled: Boolean; Continuous: boolean); begin GetNativeCanvas.Polyline(Points); end; procedure TCanvas.PolyBezier(Points: PPoint; NumPts: Integer; Filled: Boolean; Continuous: Boolean); begin GetNativeCanvas.PolyBezier(Points, NumPts, Filled, Continuous); end; procedure TCanvas.Polyline(const Points: array of TPoint); begin GetNativeCanvas.Polyline(Points); end; procedure TCanvas.Polyline(Points: PPoint; NumPts: Integer); begin GetNativeCanvas.Polyline(Points, NumPts); end; procedure TCanvas.Ellipse(x1, y1, x2, y2: Integer); begin GetNativeCanvas.Ellipse(X1, Y1, X2, Y2); end; procedure TCanvas.Ellipse(const ARect: TRect); begin Ellipse(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom); end; {procedure TCanvas.StretchDraw(const DestRect: TRect; SrcGraphic: Graphics.TGraphic); begin GetNativeCanvas.StretchDraw(DestRect, SrcGraphic); end; } procedure TCanvas.Pie(EllipseX1, EllipseY1, EllipseX2, EllipseY2, StartX, StartY, EndX, EndY: Integer); begin GetNativeCanvas.Pie(EllipseX1, EllipseY1, EllipseX2, EllipseY2, StartX, StartY, EndX, EndY); end; procedure TCanvas.StretchDraw(const DestRect: TRect; SrcGraphic: TGraphic ); begin GetNativeCanvas.StretchDraw(ScaleRectToNative(DestRect), SrcGraphic.GetNativeGraphic); end; procedure TCanvas.FrameRect(Rect: TRect); begin GetNativeCanvas.FrameRect(ScaleRectToNative(Rect)); end; procedure TCanvas.Rectangle(X1, Y1, X2, Y2: Integer); begin GetNativeCanvas.Rectangle(ScaleToNative(X1), ScaleToNative(Y1), ScaleToNative(X2), ScaleToNative(Y2)); end; procedure TCanvas.Rectangle(const ARect: TRect); begin Rectangle(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom); end; function TCanvas.TextWidth(const Text: string): Integer; begin Result := ScaleFromNative(GetNativeCanvas.TextWidth(Text)); end; function TCanvas.TextHeight(const Text: string): Integer; begin Result := ScaleFromNative(GetNativeCanvas.TextHeight(Text)); end; function TCanvas.TextExtent(const Text: string): TSize; begin Result := ScaleSizeFromNative(GetNativeCanvas.TextExtent(Text)); end; procedure TCanvas.TextOut(X, Y: Integer; const Text: string); begin GetNativeCanvas.TextOut(ScaleToNative(X), ScaleToNative(Y), Text); end; procedure TCanvas.TextRect(ARect: TRect; X, Y: Integer; Text: string); begin GetNativeCanvas.TextRect(ScaleRectToNative(ARect), ScaleToNative(X), ScaleToNative(Y), Text); end; procedure TCanvas.TextRect(ARect: TRect; X, Y: integer; const Text: string; const Style: TTextStyle); begin GetNativeCanvas.TextRect(ScaleRectToNative(ARect), ScaleToNative(X), ScaleToNative(Y), Text, TextStyle); end; procedure TCanvas.MoveTo(X, Y: Integer); begin GetNativeCanvas.MoveTo(ScaleToNative(X), ScaleToNative(Y)); end; procedure TCanvas.LineTo(X, Y: Integer); begin GetNativeCanvas.LineTo(ScaleToNative(X), ScaleToNative(Y)); end; procedure TCanvas.Line(const p1, p2: TPoint); begin GetNativeCanvas.Line(P1, P2); end; procedure TCanvas.FillRect(const ARect: TRect); begin GetNativeCanvas.FillRect(ScaleRectToNative(ARect)); end; procedure TCanvas.FillRect(X1, Y1, X2, Y2: Integer); begin GetNativeCanvas.FillRect(ScaleToNative(X1), ScaleToNative(Y1), ScaleToNative(X2), ScaleToNative(Y2)); end; procedure TCanvas.Draw(X, Y: Integer; Source: TGraphic); begin GetNativeCanvas.Draw(ScaleToNative(X), ScaleToNative(Y), Source.GetNativeGraphic); end; procedure TCanvas.CopyRect(Dest: TRect; SrcCanvas: TCanvas; Source: TRect); begin GetNativeCanvas.CopyRect(Dest, SrcCanvas.NativeCanvas, ScaleRectToNative(Source)); end; constructor TCanvas.Create; begin FNativeCanvas := nil; FFont := TFont.Create; FFontFree := True; FPen := TPen.Create; FPenFree := True; FBrush := TBrush.Create; FBrushFree := True; end; destructor TCanvas.Destroy; begin if FFontFree then FreeAndNil(FFont); if FBrushFree then FreeAndNil(FBrush); if FPenFree then FreeAndNil(FPen); if FNativeCanvasFree then FreeAndNil(FNativeCanvasFree); inherited; end; { TJpegImage } function TJpegImage.GetNativeCustomBitmap: Graphics.TCustomBitmap; begin Result := GetNativeJpeg; end; function TJpegImage.GetNativeJpeg: Graphics.TJPEGImage; begin Result := NativeJpeg; end; procedure TJpegImage.SetNativeCustomBitmap(CustomBitmap: Graphics.TCustomBitmap ); begin SetNativeJpeg(Graphics.TJpegImage(CustomBitmap)); end; procedure TJpegImage.SetNativeJpeg(Jpeg: Graphics.TJPEGImage); begin NativeJpeg := Jpeg; end; constructor TJpegImage.Create; begin NativeJpeg := Graphics.TJPEGImage.Create; NativeGraphicClass := Graphics.TJPEGImage; inherited; end; destructor TJpegImage.Destroy; begin FreeAndNil(NativeJpeg); inherited; end; { TPicture } procedure TPicture.SetBitmap(AValue: TBitmap); begin if FBitmap = AValue then Exit; FBitmap := AValue; end; procedure TPicture.LoadFromFile(FileName: string); begin end; { TScreenInfo } procedure TScreenInfo.SetDpi(AValue: Integer); var I: Integer; begin if FDpi = AValue then Exit; FDpi := AValue; // Precalculate scaling coefficients ToNative := ScreenInfo.Dpi / 96; for I := Low(LookupToNative) to High(LookupToNative) do LookupToNative[I] := Ceil(I * ToNative); FromNative := 96 / ScreenInfo.Dpi; for I := Low(LookupFromNative) to High(LookupFromNative) do LookupFromNative[I] := Floor(I * FromNative); end; { TPortableNetworkGraphic } function TPortableNetworkGraphic.GetNativeCustomBitmap: Graphics.TCustomBitmap; begin Result := GetNativePng; end; function TPortableNetworkGraphic.GetNativePng: Graphics.TPortableNetworkGraphic; begin Result := NativePng; end; procedure TPortableNetworkGraphic.SetNativeCustomBitmap( CustomBitmap: Graphics.TCustomBitmap); begin SetNativePng(Graphics.TPortableNetworkGraphic(CustomBitmap)); end; procedure TPortableNetworkGraphic.SetNativePng( Png: Graphics.TPortableNetworkGraphic); begin NativePng := Png; end; constructor TPortableNetworkGraphic.Create; begin NativePng := Graphics.TPortableNetworkGraphic.Create; NativeGraphicClass := Graphics.TPortableNetworkGraphic; inherited; end; destructor TPortableNetworkGraphic.Destroy; begin Canvas.NativeCanvas := nil; FreeAndNil(NativePng); inherited; end; end.