canvas01.pas

特别方便的工具程序

unit Canvas01;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, SHLOBJ;

type
  TCanForm = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Label1: TLabel;
    Button3: TButton;
    Memo1: TMemo;
    Button4: TButton;
    Button5: TButton;
    Button6: TButton;
    Button7: TButton;
    Panel1: TPanel;
    Edit1: TEdit;
    Label2: TLabel;
    Button8: TButton;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button7Click(Sender: TObject);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FormClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button8Click(Sender: TObject);
  private
    { Private declarations }
    procedure FmMouseEnter(var MSG); message CM_MouseEnter;
    procedure FmMouseLeave(var MSG); message CM_MouseLeave;
  public
    { Public declarations }
  end;

var
  CanForm: TCanForm;
  R1, R2: hRgn;
  TF: TFont;
  Fill1: Word = 0;
  Fill2: Word = 1;
  FW: integer = 0;

implementation

{$R *.DFM}

procedure TCanForm.Button1Click(Sender: TObject);
var
  H: THandle;
  DC: HDC;
  i: integer;
  MRect: TRect;
begin
  //刷新桌面
  SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_FLUSH, nil, nil);
  i := 1;
  case i of
    1: begin
        H := FindWindow('Progman', nil);
        DC := GetDC(H);
        InvalidateRect(H, nil, false);
        Sendmessage(H, wm_EraseBkGnd, DC, 0);
        Sendmessage(H, wm_Paint, DC, 0);
 //   RedrawWindow(H, nil, 0, RDW_ERASE or RDW_INVALIDATE or RDW_ALLCHILDREN);
        ReleaseDC(H, DC);
      end;
    2: begin
        H := FindWindow('Progman', nil);
        GetwindowRect(H, MRect);
        InvalidateRect(H, @MRect, False);
        DC := GetWindowDC(H);
        Sendmessage(H, wm_EraseBkGnd, DC, 0);
        SendMessage(H, wm_Paint, DC, 0);
        ReleaseDC(H, DC);
        UpdateWindow(H);
        ShowWindow(H, sw_Show);
        ValidateRect(H, @MRect);
      end; end;
end;

procedure TCanForm.Button2Click(Sender: TObject);
var
  lf: LogFont;
  C: TCanvas;
  DC: HDC;
begin
{  if FW > 2000 then FW := 0;
  FW := FW + 100;
  Panel1.Caption := inttostr(FW);
  ff := CreateFont(100,40,00,00,FW,0,0,0,0,0,0,0,0,nil);
  tf.handle := ff;
  label1.Font := tf;
  Canvas.Font.Assign(tf);
  Canvas.TextOut(80,300,'大字E');
  GetObject(tf.handle,sizeof(lf),@lf);
  if lf.lfHeight = 0 then halt;
  tf.Assign(Label1.Font);
 } GetObject(tf.handle, sizeof(lf), @lf);
  FW := FW + 100;
  if FW > 2000 then FW := 0;
  lf.lfHeight := 100;
  lf.lfWidth := 20;
  lf.lfEscapement := 0;
  lf.lfOrientation := 0;
  lf.lfQuality := PROOF_QUALITY;
  lf.lfWeight := FW;
  tf.Handle := createfontindirect(lf);
  Label1.ParenTFont := false;
  Label1.Font.Assign(tf);
  Canvas.Font.Assign(tf);
  Canvas.TextOut(80, 300, '大字A');
  Panel1.Caption := inttostr(lf.lfWeight);
  tf.Assign(Label1.Font);

  DC := GetDC(0);
  C := TCanvas.Create;
  C.Handle := DC;
  C.Font := tf;
  C.Font.Size := 20;
  TextOut(C.Handle, 0, 100, '大字B', 5);
  ReleaseDC(0, DC);
end;

procedure TCanForm.Button3Click(Sender: TObject);
type
  TIntArray = array[0..0] of integer;

var
  tm: TTextMetric;
  Widths: array[0..255] of integer;
  PNewWidths: ^TIntArray;
  i: integer;
begin
  Memo1.lines.Clear;
  if GetTextMetrics(Canvas.Handle, tm) then begin
    getCharWidth(Canvas.Handle, 0, 255, widths);
    Memo1.Hide;
    for i := ord(tm.tmFirstChar) to ord(tm.tmLastChar) do
      Memo1.lines.Add(inttostr(i) + '' + inttostr(Widths[i]));
    Memo1.Show;
  end;
  if Length(Edit1.Text) > 0 then begin
    GetMem(PNewWidths, Sizeof(integer) * length(Edit1.Text));
    for i := 0 to length(Edit1.Text) - 1 do
      PNewWidths[I] := Widths[Ord(PChar(Edit1.Text)[i])] + 2;
    ExtTextOut(Canvas.Handle, 100, 200, 0, nil,
      PChar(Edit1.Text), Length(Edit1.Text), @PNewWidths[0]);
    FreeMem(PNewWidths, Sizeof(integer) * length(Edit1.Text));
  end;
{ DrawText
  GetKerningPairs
  GetTextAlign
  SetTextAlign
  GetTextCharacterExtra
  SetTextCharacterExtra
  SetTextJustification
  TabbedTextOut
}
end;

procedure TCanForm.Button4Click(Sender: TObject);
var
  DC: HDC;
begin
  DC := Canvas.Handle;
  if DC = 0 then halt;
  DC := GetWindowDC(0);
//  SetTextJustification(DC, 2,2);
  SetTextCharacterExtra(DC, 10);
  TextOut(DC, 300, 20, PChar(Edit1.Text), Length(Edit1.Text));
end;

procedure TCanForm.Button6Click(Sender: TObject);
var
  DC: HDC;
  H: THandle;
begin
  H := Handle;
  DC := GetDC(H);
  Sendmessage(H, wm_EraseBkGnd, DC, 0);
  SendMessage(H, WM_PAINT, DC, 0);
end;

procedure TCanForm.FormDestroy(Sender: TObject);
begin
  if R1 > 0 then DeleteObject(R1);
  if R2 > 0 then DeleteObject(R2);
  if Assigned(tf) then tf.free;
end;

procedure TCanForm.Button5Click(Sender: TObject);
var
  hBrush: integer;
begin
  R1 := CreateEllipticRgn(0, 50, 100, 100);
{  R2 := SelectObject(Canvas.handle, R1);
  PatBlt(Canvas.handle, 00, 00, Width, height, 0);
  SelectObject(Canvas.handle, R2);
  PatBlt(Canvas.Handle, 00, 00, Width, height, WHITENESS);
 } hBrush := CreateSolidBrush(clBlue);
  FillRgn(Canvas.Handle, R1, hBrush);
  DeleteObject(hBrush);
  Canvas.brush.Color := clBlue;
  Canvas.Font.Color := clWhite;
  Canvas.TextOut(20, 70, '选定区域');
end;

procedure TCanForm.Button7Click(Sender: TObject);
begin
  Close;
end;

procedure TCanForm.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
  hBrush: integer;
  P: TPoint;
  stColor: integer;
  S: string;
begin
  GetCursorPos(P);
  Windows.ScreenToClient(Handle, P);
  Panel1.Caption := format('%s X:%d  Y:%d', [S, p.x, p.y]);
  if PTInRegion(R1, P.X, P.Y) then begin
    StColor := clRed;
    S := '内：';
    Fill1 := 1;

  end else begin
    StColor := ClBlue;
    S := '外：';
    Fill1 := 2;
  end;
  if R1 = 0 then exit;
  if Fill1 = Fill2 then Exit;
  hBrush := CreateSolidBrush(StColor);
  Canvas.Brush.handle := hBrush;
  PaintRgn(Canvas.Handle, R1);
//  FillRgn(Canvas.Handle, R1, hBrush);
  DeleteObject(hBrush);
  Canvas.brush.Color := stColor;
  Canvas.Font.Color := clWhite;
  Canvas.TextOut(20, 70, '选定区域');
  Fill2 := Fill1;
end;

procedure TCanForm.FmMouseEnter(var MSG);
begin
end;

procedure TCanForm.FmMouseLeave(var MSG);
begin
end;

procedure TCanForm.FormClick(Sender: TObject);
var
  P: TPoint;
begin
  GetCursorPos(P);
  Windows.ScreenToClient(Handle, P);
  if PTInRegion(R1, P.X, P.Y) then begin
    Showmessage('执行程序');
  end;
//  SetWindowRgn(Form1.Handle, R1, True);
end;

procedure TCanForm.FormCreate(Sender: TObject);
begin
  R1 := 0;
  R2 := 0;
  tf := TFont.Create;
end;

procedure TCanForm.Button8Click(Sender: TObject);
var
  C: TCanvas;
  H: THandle;
  DC: HDC;
  MAP: TBitmap;
begin
  MAP := TBitmap.Create;
  MAP.Width := 800;
  MAP.Height := 600;
  C := TCanvas.Create;
  H := FindWindow('Progman', nil);
  DC := GetDC(H);
  C.Handle := DC;

  Hide;
  SendMessage(H, wm_ErasebkGnd, DC, 0);
  SendMessage(H, wm_Paint, DC, 0);
  with MAP do begin
    Canvas.CopyRect(Rect(0, 0, Width, Height), C, Rect(0, 0, 800, 600));
  end;
  Show;
  ReleaseDC(0, C.Handle);
  C.Free;
  Image1.Picture.Bitmap := MAP;
  MAP.SaveToFile('D:\AAAA.BMP');
  MAP.Free;
end;

end.