unit1.pas

实现应用程序的界面是不规则窗体的方法。开发界面及开发环境是Delphi

//   
//      -'`"_         -'`" \
//     /     \       /      "
//    /     /\\__   /  ___   \       西安科技学院143信箱 710054
//   |      | \  -"`.-(   \   |
//   |      |  |     | \"  |  |                万  重
//   |     /  /  "-"  \  \    |
//    \___/  /  (o o)  \  (__/       电邮: [e-mail]
//         __| _     _ |__
//        (      ( )      )          网址: http://mantousoft.51.net
//         \_\.-.___.-./_/
//           __  | |  __             QQ  : 6036742
//          |  \.| |./  |
//          | '#.   .#' |
//          |__/ '"" \__|                     2001.3.1
//        -/             \-
//

unit Unit1;

interface

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

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;
    function CreateRegionA(BitMap :TBitMap; TransColor :TColor):HRGN;
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

function TForm1.CreateRegionA(BitMap :TBitMap; TransColor :TColor):HRGN;
var
    x, y :integer;
    Rgn, sRgn :HRgn;
    StartPos, EndPos :integer;
begin
    Rgn :=0;
    sRgn :=0;
    for y :=0 to Bitmap.Height-1 do
    begin
        x :=0;
        EndPos :=x;
        repeat
            StartPos :=x;
            inc(x);
            while(Bitmap.Canvas.Pixels[x,y]<>TransColor)and(x<=Bitmap.Width)do
            begin
                //Bitmap.Canvas.Pixels[x,y] :=clBlue;
                inc(x);
            end;
            EndPos :=x;
            if EndPos = Bitmap.Width then Dec(EndPos);
            if Rgn = 0 then
            begin
                Rgn :=CreateRectRgn(StartPos+1,y,EndPos,y+1);
            end
            else
            begin
                sRgn :=CreateRectRgn(StartPos+1,y,EndPos,y+1);
                if sRgn <> 0 then CombineRgn(Rgn, Rgn, sRgn, RGN_OR);
                DeleteObject(sRgn);
            end;
        until x>=Bitmap.Width-1;
    end;
    result :=Rgn;
end;

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
  Image1.Picture.LoadFromFile('mihu090703.bmp');//f505l004.bmp');
  Height :=Image1.Height;
  Width :=Image1.Width;
  
  w1:=TBitmap.Create;
  w1.Assign(image1.Picture.Bitmap);
  w2:=w1.Canvas.Pixels[0,0];
  rgn := CreateRegion(w1,w2,Handle);
  //rgn := CreateRegionA(w1,w2);
  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.