WinAPI: SetWindowExtEx、SetViewportExtEx

相似函数: ScaleWindowExtEx、ScaleViewportExtEx

---

本例效果图:

---

代码文件:

---

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, StdCtrls;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

var
  cvs: TCanvas;
  x1,y1: Real;
  wx,wy,vx,vy: Integer;
  f: Boolean;

procedure TForm1.FormCreate(Sender: TObject);
begin
  cvs := TCanvas.Create;
  cvs.Handle := GetDC(Handle);
  wx := ClientWidth;
  wy := ClientHeight;
  vx := wx;
  vy := wy;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  f := True;
  x1 := X;
  y1 := Y;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if not f then Exit;
  x1 := X / x1;
  y1 := Y / y1;

  vx := Trunc(vx * x1);
  vy := Trunc(vy * y1);

  Repaint;

  x1 := X;
  y1 := Y;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  f := False;
end;

procedure TForm1.FormPaint(Sender: TObject);
const
  pts: array[0..2] of TPoint = ((X:60; Y:10), (X:60; Y:100), (X:10; Y:100));
begin
  SetMapMode(cvs.Handle, MM_ANISOTROPIC);
  {只能在 MM_ISOTROPIC 或 MM_ANISOTROPIC 模式下使用下面两个函数}
  SetWindowExtEx(cvs.Handle, wx, wy, nil);
  SetViewportExtEx(cvs.Handle, vx, vy, nil);

  cvs.Pen.Width := 3;
  cvs.Pen.Color := clRed;
  cvs.Brush.Style := bsCross;
  cvs.Brush.Color := clSilver;
  cvs.Polygon(pts);
  cvs.Ellipse(30, 70, 90, 130);
end;

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

end.

窗体文件:

---

object Form1: TForm1
  Left = 0
  Top = 0
  Caption = 'Form1'
  ClientHeight = 241
  ClientWidth = 302
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  Position = poDesktopCenter
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  OnMouseDown = FormMouseDown
  OnMouseMove = FormMouseMove
  OnMouseUp = FormMouseUp
  OnPaint = FormPaint
  PixelsPerInch = 96
  TextHeight = 13
end