main.pas

在深度历险网站上发布的所有delphi程序原码。对初学delphi者很有用。

unit main;

interface

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

type
  TMainForm = class(TForm)
    pnlRight: TPanel;
    grdColor: TColorGrid;
    imgMain: TImage;
    procedure FormKeyPress(Sender: TObject; var Key: Char);
    procedure imgMainMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FormCreate(Sender: TObject);
    procedure imgMainMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure imgMainMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure pnlRightResize(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure grdColorChange(Sender: TObject);
  private
    FDrawing: Boolean;
    
    FCursorBits, FDesktopBits: TBitmap;
    FCursorPos: TPoint;
    
    procedure GrabScreenImage;
    
    procedure WMSetFocus(var message: TWMSetFocus); message WM_SETFOCUS;
    procedure WMKillFocus(var message: TWMSetFocus); message WM_KILLFOCUS;
  public
    { Public declarations }
  end;
  
const
  DOT_SIZE = 20;
  
var
  MainForm: TMainForm;
  
implementation

{$R *.DFM}

uses ScreenCanvas;

procedure TMainForm.GrabScreenImage;
begin
  with FDesktopBits do
  begin
    width := clientwidth;
    height := clientheight;
  end;
  
  with TScreenCanvas.Create do
    try
      BitBlt(FDesktopBits.Canvas.Handle, 0, 0, clientwidth,
        clientheight, Handle, 0, 0, SRCCOPY);

      imgMain.Picture.Bitmap.Assign(FDesktopBits);
    finally
      Free;
    end;
end;

procedure TMainForm.FormKeyPress(Sender: TObject; var Key: Char);
begin
  if Key = #27 then Close;
end;

procedure TMainForm.WMKillFocus(var message: TWMSetFocus);
begin
  ShowCursor(true);
end;

procedure TMainForm.WMSetFocus(var message: TWMSetFocus);
begin
  ShowCursor(false);
end;

procedure TMainForm.imgMainMouseMove(Sender: TObject; Shift: TShiftState;
    X, Y: Integer);
var
  Pt: TPoint;
  R : TRect;
begin
  GetCursorPos(Pt);

  if (Pt.X <> FCursorPos.X) or (Pt.Y <> FCursorPos.Y) then
  begin
    R := Rect(0, 0, FCursorBits.width, FCursorBits.height);
    OffsetRect(R, FCursorPos.X, FCursorPos.Y);
    imgMain.Canvas.CopyRect(R, FDesktopBits.Canvas, R);

    if FDrawing then
    begin
      R := Rect(Pt.X, Pt.Y, Pt.X + DOT_SIZE, Pt.Y + DOT_SIZE);
      with FDesktopBits.Canvas do
        Ellipse(Pt.X, Pt.Y, Pt.X + DOT_SIZE, Pt.Y + DOT_SIZE);
      with imgMain.Canvas do
        CopyRect(R, FDesktopBits.Canvas, R);
    end;

    imgMain.Canvas.draw(Pt.X, Pt.Y, FCursorBits);

    FCursorPos := Pt;
  end;
end;

procedure TMainForm.FormCreate(Sender: TObject);
begin
  FDrawing := false;

  FCursorBits := TBitmap.Create;
  FCursorBits.loadfromfile('hammer.bmp');
  FCursorBits.Transparent := true;
  FCursorBits.TransparentMode := tmAuto;

  FDesktopBits := TBitmap.Create;

  with grdColor do
  begin
    ForegroundIndex := ColorToIndex(clRed);
    grdColorChange(grdColor);
  end;
end;

procedure TMainForm.imgMainMouseUp(Sender: TObject; Button: TMouseButton;
    Shift: TShiftState; X, Y: Integer);
begin
  FDrawing := false;
end;

procedure TMainForm.imgMainMouseDown(Sender: TObject; Button: TMouseButton;
    Shift: TShiftState; X, Y: Integer);
begin
  FDrawing := true;
end;

procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  FCursorBits.Free;
end;

procedure TMainForm.pnlRightResize(Sender: TObject);
begin
  grdColor.width := pnlRight.clientwidth;
  grdColor.height := pnlRight.clientheight;
end;

procedure TMainForm.FormActivate(Sender: TObject);
begin
  GrabScreenImage;
end;

procedure TMainForm.grdColorChange(Sender: TObject);
begin
  with grdColor do
  begin
    imgMain.Canvas.Brush.Color := ForegroundColor;
    FDesktopBits.Canvas.Brush.Color := ForegroundColor;
    FDesktopBits.Canvas.Pen.Color := ForegroundColor;
  end;
end;

end.