borderstylefix.pas

delphi 的一点代码 delphi 的一点代码 delphi 的一点代码

unit BorderStyleFix;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, Forms, TypInfo;

implementation

var
  SetBorderStyleProc: procedure(Self: TCustomForm; Value: TFormBorderStyle);

type
  TFixForm = class(TForm)
    function GetIconHandle: HICON;
    procedure SetBorderStyle(Value: TFormBorderStyle);
  end;

function TFixForm.GetIconHandle: HICON;
begin
  Result := Icon.Handle;
  if Result = 0 then
  begin
    Result := Application.Icon.Handle;
    if Result = 0 then
      Result := LoadIcon(0, IDI_APPLICATION);
  end;
end;

procedure TFixForm.SetBorderStyle(Value: TFormBorderStyle);
begin
  if Value <> BorderStyle then
  begin
    SetBorderStyleProc(Self, Value);

    if HandleAllocated then
    begin
      // reset SystemMenu
      GetSystemMenu(Handle, True);

      // set the window's icon
      if BorderStyle = bsDialog then
        SendMessage(Handle, WM_SETICON, 1, 0)
      else
      begin
        SendMessage(Handle, WM_SETICON, 1, GetIconHandle);
        SetClassLong(Handle, GCL_HICON, GetIconHandle);
      end;

      // set correct SystemMenu
      Perform(WM_NCCREATE, 0, 0);
    end;
  end;
end;

var
  BorderStylePropInfo: PPropInfo;
  OldProtect: Cardinal;

initialization
  BorderStylePropInfo := GetPropInfo(TForm, 'BorderStyle');
  if BorderStylePropInfo <> nil then
  begin
    @SetBorderStyleProc := BorderStylePropInfo.SetProc;

    VirtualProtect(@BorderStylePropInfo.SetProc, SizeOf(Pointer), PAGE_READWRITE, @OldProtect);
    BorderStylePropInfo.SetProc := @TFixForm.SetBorderStyle;
    VirtualProtect(@BorderStylePropInfo.SetProc, SizeOf(Pointer), OldProtect, nil);
  end;

finalization
  if BorderStylePropInfo <> nil then
  begin
    VirtualProtect(@BorderStylePropInfo.SetProc, SizeOf(Pointer), PAGE_READWRITE, @OldProtect);
    BorderStylePropInfo.SetProc := @SetBorderStyleProc;
    VirtualProtect(@BorderStylePropInfo.SetProc, SizeOf(Pointer), OldProtect, nil);
  end;

end.