lazarus/examples/affinetransforms/unit1.pas

unit Unit1; 

{$mode objfpc}{$H+}

interface

uses
  Classes, Types,
  LCLType, LclIntf, Forms, Controls, Graphics, StdCtrls, ExtCtrls, Themes;

type

  { TForm1 }

  TForm1 = class(TForm)
    Label1: TLabel;
    Label2: TLabel;
    PB: TPaintBox;
    RG: TRadioGroup;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure PBPaint(Sender: TObject);
    procedure RGClick(Sender: TObject);
  private

  public
    FImage: TBitmap;
  end; 

var
  Form1: TForm1; 

implementation

{$R *.lfm}

{ TForm1 }

procedure TForm1.FormCreate(Sender: TObject);
begin
  FImage := TBitmap.Create;
  FImage.LoadFromFile('./buy_64.bmp');
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FImage.Free;
end;

procedure TForm1.PBPaint(Sender: TObject);
var
  R: TRect;
  P: TSize;
begin
  with PB.Canvas do
  begin
    Brush.Color := clWhite;
    FillRect(ClientRect);
    Font.Color := clGreen;
    Font.Height := 20;
    Pen.Width := 2;
    TextOut(20,300, 'Unmapped!'); // check if font size OK
    case RG.ItemIndex of
      0:
      begin
        SetMapMode(Handle, MM_ANISOTROPIC);
        SetWindowExtEx(Handle, 400, 300, nil);
        SetViewPortExtEx(Handle, PB.ClientWidth, PB.ClientHeight, nil);
        SetViewPortOrgEx(Handle, 0, 0, nil);
      end;
      1:
      begin
        SetMapMode(Handle, MM_ISOTROPIC);
        SetWindowExtEx(Handle, 400, 300, nil);
        SetViewPortExtEx(Handle, PB.ClientWidth, PB.ClientHeight, nil);
        SetViewPortOrgEx(Handle, 0, 0, nil);
      end;
      2:
      begin
        SetMapMode(Handle, MM_LOENGLISH);
        SetViewPortOrgEx(Handle, 0, 300, nil);
      end;
      3:
      begin
        SetMapMode(Handle, MM_HIENGLISH);
        SetViewPortOrgEx(Handle, 0, 300, nil);
      end;
      4:
      begin
        SetMapMode(Handle, MM_LOMETRIC);
        SetViewPortOrgEx(Handle, 0, 300, nil);
      end;
      5:
      begin
        SetMapMode(Handle, MM_HIMETRIC);
        SetViewPortOrgEx(Handle, 0, 300, nil);
      end;
      6:
      begin
        SetMapMode(Handle, MM_TWIPS);
        SetViewPortOrgEx(Handle, 0, 300, nil);
      end;
      7:
      begin
        SetMapMode(Handle, MM_ANISOTROPIC);
        SetWindowExtEx(Handle, -400, 300, nil);
        SetViewPortExtEx(Handle, PB.ClientWidth, PB.ClientHeight, nil);
        SetViewPortOrgEx(Handle, PB.ClientWidth, 0, nil);
      end;
    end;
    GetWindowExtEx(Handle, @P);
    GetViewPortExtEx(Handle, @P);
    Brush.Color := clRed;
    FillRect(10, 10, 200, 200);
    Brush.Color := clYellow;
    Arc(200,10,400,200,20,0,400,300);
    Chord(10,10,200,200, 0,0,300,300);
    Brush.Color := clGreen;
    Ellipse(50,200,250,260);
    Brush.Color := clWhite;
    TextOut(50,50, 'Hello!');
    TextRect(Rect(50,80,200,120), 50,80, 'Clipped!');
    DrawFocusRect(Rect(10,200,400,220)); // normally quite slow on GTK2, disable for the test
    MoveTo(300, 200);
    LineTo(390, 290);
    R := Rect(10,200,100,250);
    Frame3D(R, 3, bvRaised);
    Frame(200,250,250,260);
    FrameRect(200,220,250,240);
    Rectangle(320,20,380,100);
    RoundRect(320,110,380,150,6,6);
    ThemeServices.DrawElement(Handle, ThemeServices.GetElementDetails(tbPushButtonNormal), Rect(80,50,100,75), nil);
    DrawFrameControl(Handle, Rect(50,50,70,75), DFC_BUTTON, DFCS_BUTTONPUSH);
    R := Rect(110,50,140,75);
    DrawEdge(Handle, R, BDR_RAISEDINNER, BF_RECT);
    StretchDraw(Rect(230,100, 304, 164), FImage);
    SetMapMode(Handle, MM_TEXT);
    TextOut(20,20, 'Unmapped!'); // check if font size OK
  end;
end;

procedure TForm1.RGClick(Sender: TObject);
begin
  PB.Invalidate;
end;

end.