Delphi编程实现绘出绘图形状一样的窗体

减小字体 增大字体 作者:佚名  来源:转载  发布时间:2010-10-31 20:39:29

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Image1: TImage;
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    function CreateRegion(wMask: TBitmap; wColor: TColor;
      hControl: THandle): HRGN;
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

function TForm1.CreateRegion(wMask: TBitmap; wColor: TColor;
  hControl: THandle): HRGN;
var
  dc, dc_c: HDC;
  rgn: HRGN;
  X, Y: Integer;
  coord: TPoint;
  line: boolean;
  color: TColor;
begin
  dc := GetWindowDC(hControl);
  dc_c := CreateCompatibleDC(dc);
  SelectObject(dc_c, wMask.Handle);
  BeginPath(dc);
  for X := 0 to wMask.Width - 1 do
  begin
    line := false;
    for Y := 0 to wMask.Height - 1 do
    begin
      color := GetPixel(dc_c, X, Y);
      if not(color = wColor) then
      begin
        if not line then
        begin
          line := true;
          coord.X := X;
          coord.Y := Y;
        end;
      end;
      if (color = wColor) or (Y = wMask.Height - 1) then
      begin
        if line then
        begin
          line := false;
          MoveToEx(dc, coord.X, coord.Y, nil);
          LineTo(dc, coord.X, Y);
          LineTo(dc, coord.X + 1, Y);
          LineTo(dc, coord.X + 1, coord.Y);
          CloseFigure(dc);
        end;
      end;
    end;
  end;
  EndPath(dc);
  rgn := PathToRegion(dc);
  ReleaseDC(hControl, dc);
  Result := rgn;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  w1: TBitmap;
  w2: TColor;
  rgn: HRGN;
begin
  w1 := TBitmap.Create;
  w1.Assign(Image1.Picture.Bitmap);
  w2 := w1.Canvas.Pixels[0, 0];
  rgn := CreateRegion(w1, w2, Handle);
  if rgn <> 0 then
  begin
    SetWindowRgn(Handle, rgn, true);
  end;
  w1.Free;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Close;
end;

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  ReleaseCapture;
  SendMessage(Handle, WM_SYSCOMMAND, $F012, 0);
end;

end.

Tags:

作者:佚名
  • 好的评价 如果您觉得此文章好,就请您
      0%(0)
  • 差的评价 如果您觉得此文章差,就请您
      0%(0)

文章评论评论内容只代表网友观点,与本站立场无关!

   评论摘要(共 0 条,得分 0 分,平均 0 分) 查看完整评论

广告位置B