kaformimage.pas

可以用任何 bitmap 當成 form 的外型 delphi 3.0, 4.0, 5.0, 6.0, 7.0 適用

unit KAFormImage;

interface

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

type
  WBDPRC         = Procedure(var Message: TMessage) Of Object;
  TColorMatching = (Exact, Similar, ExactColorArray, SimilarColorArray);
  TKAFormImage = class(TImage)
  private
    { Private declarations }
    F_Color         : TColor;
    F_Control       : TControl;
    F_Active        : Boolean;
    F_RGNData       : Pointer;
    F_RGNSize       : Integer;
    F_Shape         : TMemoryStream;
    F_All           : Boolean;
    F_InMouse       : Boolean;
    F_OldWndProc    : WBDPRC;
    F_Invisible     : TColorRef;
    F_ColorMatching : TColorMatching;
    IPixR           : Byte;
    IPixG           : Byte;
    IPixB           : Byte;
    F_Similarity    : Integer;
    F_ColorArray    : TList;
    Function  F_Get_Picture : TPicture;
    Procedure F_Set_Picture(Value  : TPicture);
    Procedure F_Set_Color(Value  : TColor);
    Procedure F_Set_Control(Value  : TControl);
    Function  F_Get_Shape : TMemoryStream;
    Procedure F_Set_Shape(Value : TMemoryStream);
    Procedure F_Set_All(Value : Boolean);
    Procedure F_Set_ColorMatching(Value : TColorMatching);
    Procedure F_Set_Similarity(Value : Integer);
    Procedure F_Set_ColorArray(Value : TList);
    Procedure F_Set_Active(Value : Boolean);
  protected
    { Protected declarations }
    Function   IsInvisible(Color : TColorRef):Boolean;
    Function   GetFormRegion : HRGN;
    Procedure  Loaded; override;
    Procedure  Notification(AComponent: TComponent; Operation: TOperation); Override;
    procedure  DefineProperties(Filer: TFiler);Override;
    procedure  ControlWindowProc(var Message: TMessage);
    procedure  MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Override;
  public
    { Public declarations }
    BmpRepresentation : TBitmap;
    Constructor Create(AOwner: TComponent); override;
    Destructor Destroy; override;
    Procedure  SaveRGNToStream(S : TStream);
    Procedure  LoadRGNFromStream(S : TStream);
    procedure  SaveListToStream(S : TStream);
    procedure  LoadListFromStream(S : TStream);
    Procedure  ApplyFormShape;
    Property   Shape             : TMemoryStream  Read F_Get_Shape   Write F_Set_Shape;
  published
    { Published declarations }
    Property   Picture              : TPicture       Read F_Get_Picture     Write F_Set_Picture;
    Property   Color                : TColor         Read F_Color           Write F_Set_Color;
    Property   ColorArray           : TList          Read F_ColorArray      Write F_Set_ColorArray;
    Property   ColorMatching        : TColorMatching Read F_ColorMatching   Write F_Set_ColorMatching;
    Property   ColorSimilarity      : Integer        Read F_Similarity      Write F_Set_Similarity;
    Property   CaptionBarControl    : TControl       Read F_Control         Write F_Set_Control;
    Property   DragEntireArea       : Boolean        Read F_All             Write F_Set_All;
    Property   Active               : Boolean        Read F_Active          Write F_Set_Active;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('KA', [TKAFormImage]);
end;

{ TKAFormImage }

constructor TKAFormImage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  F_ColorArray       := TList.Create;
  F_Color            := clWhite;
  F_Control          := nil;
  F_Active           := True;
  F_RGNData          := Nil;
  F_OldWndProc       := Nil;
  F_RGNSize          := 0;
  F_All              := False;
  F_InMouse          := False;
  F_Shape            := TMemoryStream.Create;
  F_ColorMatching    := Exact;
  F_Similarity       := 75;
  BmpRepresentation  := TBitmap.Create;
  BmpRepresentation.PixelFormat := pf24Bit;
end;

destructor TKAFormImage.Destroy;
begin
  F_ColorArray.Free;
  F_Shape.Free;
  BmpRepresentation.Free;
  if @F_OldWndProc <> Nil Then F_Control.WindowProc := F_OldWndProc;
  inherited Destroy;
end;

function TKAFormImage.F_Get_Picture: TPicture;
begin
 Result := Inherited Picture;
end;

procedure TKAFormImage.F_Set_Picture(Value: TPicture);
begin
 Inherited Picture.Assign(Value);
 if csLoading   In ComponentState Then Exit;
 if Picture.Graphic is TBitmap Then
     Begin
       BmpRepresentation.Assign(Picture.Graphic);
     End
  Else
     Begin
       BmpRepresentation.Width  := Picture.Graphic.Width;
       BmpRepresentation.Height := Picture.Graphic.Height;
       BmpRepresentation.Canvas.Draw(0,0,Picture.Graphic);
     End;
 ApplyFormShape;
 if csDesigning In ComponentState Then Exit;
 if F_Active Then F_Set_Active(F_Active);
end;

Procedure TKAFormImage.F_Set_Color(Value  : TColor);
Begin
  F_Color     := Value;
  F_Invisible := TColorRef(F_Color);
  IPixR       := GetRValue(F_Invisible);
  IPixG       := GetGValue(F_Invisible);
  IPixB       := GetBValue(F_Invisible);
  if csLoading   In ComponentState Then Exit;
  ApplyFormShape;
  if csDesigning In ComponentState Then Exit;
  if F_Active Then F_Set_Active(F_Active);
End;


Procedure TKAFormImage.F_Set_ColorMatching(Value : TColorMatching);
Begin
  F_ColorMatching     := Value;
  if csLoading   In ComponentState Then Exit;
  ApplyFormShape;
  if csDesigning In ComponentState Then Exit;
  if F_Active Then F_Set_Active(F_Active);
End;

Procedure TKAFormImage.F_Set_Similarity(Value : Integer);
Begin
  F_Similarity     := Value;
  if csLoading   In ComponentState Then Exit;
  if (F_ColorMatching = Similar)
  Or (F_ColorMatching = SimilarColorArray) Then ApplyFormShape;
  if csDesigning In ComponentState Then Exit;
  if F_Active Then F_Set_Active(F_Active);
End;

Procedure TKAFormImage.F_Set_ColorArray(Value : TList);
Var
 X : Integer;
Begin
  F_ColorArray.Clear;
  For X := 0 To Value.Count-1 do F_ColorArray.Add(Value.Items[X]);
  if csLoading   In ComponentState Then Exit;
  if (F_ColorMatching = Similar)
  Or (F_ColorMatching = SimilarColorArray) Then ApplyFormShape;
  if csDesigning In ComponentState Then Exit;
  if F_Active Then F_Set_Active(F_Active);
End;

Procedure TKAFormImage.F_Set_Control(Value  : TControl);
Begin
 if @F_OldWndProc <> Nil Then F_Control.WindowProc := F_OldWndProc;
 F_OldWndProc := Nil;
 F_Control := Value;
 if Value=Self Then
    Begin
      F_All := True;
      Exit;
    End;
 if F_Control <> Nil Then
    Begin
      F_Control.FreeNotification(Self);
      if Not (csDesigning in ComponentState) Then
         Begin
           F_OldWndProc         := F_Control.WindowProc;
           F_Control.WindowProc := ControlWindowProc;
         End;  
    End;
End;

Procedure TKAFormImage.F_Set_Active(Value : Boolean);
Var
 F_RGN : HRGN;
Begin
 F_Active := Value;
 if csLoading   In ComponentState Then Exit;
 if csDesigning In ComponentState Then Exit;
 if (F_Active) And (F_Color <> clNone) Then
    Begin
     F_RGN := ExtCreateRegion(Nil,F_RGNSize,TRGNData(F_RGNData^));
     SetWindowRgn(Parent.Handle, F_RGN, True);
     DeleteObject(F_RGN);
    End
 Else
    Begin
      SetWindowRgn(Parent.Handle, 0, True);
    End;
End;

procedure TKAFormImage.SaveRGNToStream(S : TStream);
begin
  if F_RGNSize = 0 then Exit;
  S.Write(F_RGNSize,SizeOf(DWord));
  S.Write(F_RGNData^,F_RGNSize);
end;

procedure TKAFormImage.LoadRGNFromStream(S : TStream);
begin
  if S.Size = 0 then
     Begin
      F_RGNData := Nil;
      F_RGNSize := 0;
      SetWindowRgn(Parent.Handle, 0, True);
      Exit;
     End;
  if F_RGNData <> nil then FreeMem(F_RGNData);
  F_RGNData := Nil;
  F_RGNSize := 0;
  S.Position:= 0;
  S.Read(F_RGNSize,SizeOf(DWord));
  F_RGNData := AllocMem(F_RGNSize);
  S.Read(F_RGNData^,F_RGNSize);
end;

procedure TKAFormImage.SaveListToStream(S : TStream);
Var
  X  : Integer;
  DW : DWORD;
begin
  DW := F_ColorArray.Count;
  if DW = 0 then Exit;
  S.Write(DW,SizeOf(DWORD));
  For X := 0 To F_ColorArray.Count-1 do
      Begin
        DW := DWord(F_ColorArray.Items[X]);
        S.Write(DW,SizeOf(DWORD));
      End;
end;

procedure TKAFormImage.LoadListFromStream(S : TStream);
Var
 DW  : DWORD;
 DWD : DWORD;
 X   : Integer;
Begin
  if S.Size = 0 then
     Begin
       F_ColorArray.Clear;
       Exit;
     End;
  S.Read(DW,SizeOf(DWord));
  For X := 1 To DW do
      Begin
        S.Read(DWD,SizeOf(DWord));
        F_ColorArray.Add(Pointer(DWD));
      End;
End;

Procedure TKAFormImage.F_Set_Shape(Value : TMemoryStream);
Begin
 F_Shape.Position:=0;
 F_Shape.LoadFromStream(Value);
 LoadRGNFromStream(F_Shape);
End;

Function  TKAFormImage.F_Get_Shape : TMemoryStream;
Begin
  SaveRGNToStream(F_Shape);
  Result := F_Shape;
End;

Procedure TKAFormImage.F_Set_All(Value : Boolean);
Begin
 F_All     := Value;
 F_InMouse := F_All;
End;

Function TKAFormImage.IsInvisible(Color : TColorRef):Boolean;
Var
 CPixR : Byte;
 CPixG : Byte;
 CPixB : Byte;
 X     : Integer;
 Clr   : TColorRef;
Begin
  Result := False;
  if F_ColorMatching = Exact Then
     Begin
       Result := Color = F_Invisible;
     End
  Else
  if F_ColorMatching = Similar Then
     Begin
      CPixR  := GetRValue(Color);
      CPixG  := GetGValue(Color);
      CPixB  := GetBValue(Color);
      Result :=     (Abs(CPixR-IPixR) <= F_Similarity)
                And (Abs(CPixG-IPixG) <= F_Similarity)
                And (Abs(CPixB-IPixB) <= F_Similarity);
     End
  Else
  if F_ColorMatching = ExactColorArray Then
     Begin
       For X := 0 to F_ColorArray.Count-1 do
           Begin
             Clr := TColorRef(TColor(F_ColorArray.Items[X]));
             if Clr = Color Then
                Begin
                  Result := True;
                  System.Break;
                End;
           End;
     End
  Else
  if F_ColorMatching = SimilarColorArray Then
     Begin
       CPixR  := GetRValue(Color);
       CPixG  := GetGValue(Color);
       CPixB  := GetBValue(Color);
       For X := 0 to F_ColorArray.Count-1 do
           Begin
             Clr    := TColorRef(TColor(F_ColorArray.Items[X]));
             IPixR  := GetRValue(Clr);
             IPixG  := GetGValue(Clr);
             IPixB  := GetBValue(Clr);
             Result :=     (Abs(CPixR-IPixR) <= F_Similarity)
                       And (Abs(CPixG-IPixG) <= F_Similarity)
                       And (Abs(CPixB-IPixB) <= F_Similarity);
             if Result Then System.Break;
           End;
     End;
End;



Function TKAFormImage.GetFormRegion:HRGN;
Var
  DC        : HDC;
  DCRect    : TRect;
  X         : Integer;
  Y         : Integer;
  DX        : Integer;
  TempRGN   : HRgn;
  TempRGN1  : HRgn;
  TempRGN2  : HRgn;
  TempRGN3  : HRgn;
Begin
  DC              := BmpRepresentation.Canvas.Handle;
  GetClipBox(DC,DCRect);
  Result    := CreateRectRgn(0,0,0,0);
  For Y :=DCRect.Top to DCRect.Bottom  do
    Begin
      X := DCRect.Left;
      While (X <= DCRect.Right) Do
        Begin
         DX := X;
         While (IsInvisible(GetPixel(DC,X,Y)) And (X <= DCRect.Right)) do Inc(X);
         TempRGN := CreateRectRgn(DX,Y,X,Y+1);
         CombineRgn(Result,Result,TempRGN,RGN_OR);
         DeleteObject(TempRGN);
         While (NOT IsInvisible(GetPixel(DC,X,Y)) And (X <= DCRect.Right)) do Inc(X);
        End;
    End;
  TempRGN1 := CreateRectRgn(0,0,0,0);
  TempRGN2 := CreateRectRgnIndirect(DCRect);
  TempRGN3 := CreateRectRgnIndirect(DestRect);
  CombineRgn(TempRGN1,TempRGN2,TempRGN3, RGN_AND);
  CombineRgn(Result,TempRGN1,Result,RGN_DIFF);
  DeleteObject(TempRGN1);
  DeleteObject(TempRGN2);
  DeleteObject(TempRGN3);

  if F_RGNData <> Nil Then FreeMem(F_RGNData);
  F_RGNData := nil;
  F_RGNSize := 0;
  F_RGNSize := GetRegionData(Result,0,Nil);
  if F_RGNSize > 0 Then
     Begin
       F_RGNData := AllocMem(F_RGNSize);
       GetRegionData(Result,F_RGNSize,F_RGNData);
     End;
End;

Procedure TKAFormImage.ApplyFormShape;
Var
 RGN : HRGN;
Begin
 if Assigned(Picture) And (Parent is TForm) Then
     Begin
       RGN := GetFormRegion;
       DeleteObject(RGN);
     End;
End;

procedure TKAFormImage.Loaded;
begin
  inherited;
  If csDesigning in ComponentState Then Exit;
  if F_RGNSize=0 Then ApplyFormShape;
  if F_Active Then F_Set_Active(True);
End;

procedure TKAFormImage.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (F_Control <> nil) and (AComponent = F_Control) then
      Begin
        if @F_OldWndProc <> Nil Then F_Control.WindowProc := F_OldWndProc;
        F_OldWndProc := Nil;
        F_Control    := Nil;
      End;
end;

procedure TKAFormImage.ControlWindowProc(var Message: TMessage);
Begin
  if Message.Msg=WM_LBUTTONDOWN Then
     Begin
       F_InMouse := True;
       Self.WndProc(Message);
     End
  Else
    F_OldWndProc(Message);
End;

procedure TKAFormImage.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  if F_InMouse Then
     Begin
      ReleaseCapture;
      Parent.Perform(WM_SysCommand,$F012,0);
     End
  Else
    Begin
      inherited MouseDown(Button, Shift, X, Y);
    End;
  F_InMouse := F_All;
end;

procedure TKAFormImage.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(Filer);
  Filer.DefineBinaryProperty('FormShape',LoadRGNFromStream, SaveRGNToStream, True);
  Filer.DefineBinaryProperty('ColorArrayData',LoadListFromStream, SaveListToStream, True);
end;



end.