jvexcontrols.pas

East make Tray Icon in delphi

  else
    HintInfo.HintColor := HintColor;
  end;
end;

{$IFDEF VisualCLX}
function Perform(AControl: TControl; Msg: Integer; WParam, LParam: Integer): Integer;
var
  PerformMsg, Mesg: TMessage;
begin
  if AControl.GetInterfaceEntry(IJvExControl) <> nil then
  begin
    Mesg.Msg := Msg;
    Mesg.WParam := WParam;
    Mesg.LParam := LParam;
    Mesg.Result := 0;

    PerformMsg.Msg := CM_PERFORM;
    PerformMsg.WParam := 0;
    PerformMsg.LParam := @Mesg;
    PerformMsg.Result := 0;
    AControl.Dispatch(PerformMsg);
  end;
end;
{$ENDIF VisualCLX}

{$IFDEF COMPILER5}

{ Delphi 5's SetAutoSize is private and not virtual. This code installs a
  JUMP-Hook into SetAutoSize that jumps to our function. }
type
  PBoolean = ^Boolean;
  PPointer = ^Pointer;

function ReadProtectedMemory(Address: Pointer; var Buffer; Count: Cardinal): Boolean;
var
  N: Cardinal;
begin
  Result := ReadProcessMemory(GetCurrentProcess, Address, @Buffer, Count, N);
  Result := Result and (N = Count);
end;

function WriteProtectedMemory(Address: Pointer; const Buffer; Count: Cardinal): Boolean;
var
  N: Cardinal;
begin
  Result := WriteProcessMemory(GetCurrentProcess, Address, @Buffer, Count, N);
  Result := Result and (N = Count);
end;

type
  TJumpCode = packed record
    Pop: Byte; // pop xxx
    Jmp: Byte; // jmp Offset
    Offset: Integer;
  end;

  TOrgCallCode = packed record
    Push: Byte; // push ebx/ebp
    InjectedCode: TJumpCode;
    Jmp: Byte; // jmp Offset
    Offset: Integer;
    Address: Pointer;
  end;

function GetRelocAddress(ProcAddress: Pointer): Pointer;
type
  TRelocationRec = packed record
    Jump: Word;
    Address: PPointer;
  end;
var
  Relocation: TRelocationRec;
  Data: Byte;
begin
  Result := ProcAddress;
  // the relocation table might be protected
  if ReadProtectedMemory(ProcAddress, Data, SizeOf(Data)) then
    if Data = $FF then // ProcAddress is in a DLL or package
      if ReadProtectedMemory(ProcAddress, Relocation, SizeOf(Relocation)) then
        Result := Relocation.Address^;
end;

function InstallProcHook(ProcAddress, HookProc, OrgCallProc: Pointer): Boolean;
var
  Code: TJumpCode;
  OrgCallCode: TOrgCallCode;
begin
  ProcAddress := GetRelocAddress(ProcAddress);
  Result := False;
  if Assigned(ProcAddress) and Assigned(HookProc) then
  begin
    if OrgCallProc <> nil then
    begin
      if ReadProtectedMemory(ProcAddress, OrgCallCode,
        SizeOf(OrgCallCode) - (1 + SizeOf(Integer))) then
      begin
        OrgCallCode.Jmp := $E9;
        OrgCallCode.Offset := (Integer(ProcAddress) + 1 + SizeOf(Code)) -
          Integer(OrgCallProc) -
          (SizeOf(OrgCallCode) - SizeOf(OrgCallCode.Address));
        OrgCallCode.Address := ProcAddress;

        WriteProtectedMemory(OrgCallProc, OrgCallCode, SizeOf(OrgCallCode));
        FlushInstructionCache(GetCurrentProcess, OrgCallProc, SizeOf(OrgCallCode));
      end;
    end;

    if PByte(ProcAddress)^ = $53 then // push ebx
      Code.Pop := $5B // pop ebx
    else
    if PByte(ProcAddress)^ = $55 then // push ebp
      Code.Pop := $5D // pop ebp
    else
      Exit;
    Code.Jmp := $E9;
    Code.Offset := Integer(HookProc) - (Integer(ProcAddress) + 1) - SizeOf(Code);

    { The strange thing is that something overwrites the $e9 with a "PUSH xxx" }
    if WriteProtectedMemory(Pointer(Cardinal(ProcAddress) + 1), Code, SizeOf(Code)) then
    begin
      FlushInstructionCache(GetCurrentProcess, ProcAddress, SizeOf(Code));
      Result := True;
    end;
  end;
end;

function UninstallProcHook(OrgCallProc: Pointer): Boolean;
var
  OrgCallCode: TOrgCallCode;
  ProcAddress: Pointer;
begin
  Result := False;
  if Assigned(OrgCallProc) then
    if OrgCallProc <> nil then
      if ReadProtectedMemory(OrgCallProc, OrgCallCode, SizeOf(OrgCallCode)) then
      begin
        ProcAddress := OrgCallCode.Address;

        Result := WriteProtectedMemory(ProcAddress, OrgCallCode, 1 + SizeOf(TJumpCode));
        FlushInstructionCache(GetCurrentProcess, ProcAddress, SizeOf(OrgCallCode));
      end;
end;

var
  AutoSizeOffset: Cardinal;
  TControl_SetAutoSize: Pointer;

type
  TControlAccessProtected = class(TControl);

procedure OrgSetAutoSize(AControl: TControl; Value: Boolean);
asm
        DD    0, 0, 0, 0  // 16 Bytes
end;

procedure TOpenControl_SetAutoSize(AControl: TControl; Value: Boolean);
begin
  // same as OrgSetAutoSize(AControl, Value); but secure
  with TControlAccessProtected(AControl) do
    if AutoSize <> Value then
    begin
      PBoolean(Cardinal(AControl) + AutoSizeOffset)^ := Value;
      if Value then
        AdjustSize;
    end;
end;

procedure SetAutoSizeHook(AControl: TControl; Value: Boolean);
var
  Msg: TMessage;
begin
  if AControl.GetInterfaceEntry(IJvExControl) <> nil then
  begin
    Msg.Msg := CM_SETAUTOSIZE;
    Msg.WParam := Ord(Value);
    AControl.Dispatch(Msg);
  end
  else
    TOpenControl_SetAutoSize(AControl, Value);
end;

{$OPTIMIZATION ON} // be sure to have optimization activated

function GetCode(AControl: TControlAccessProtected): Boolean; register;
begin
  { generated code:
      8A40xx       mov al,[eax+Byte(Offset)]
  }
  Result := AControl.AutoSize;
end;

procedure SetCode(AControl: TControlAccessProtected); register;
begin
  { generated code:
      B201         mov dl,$01
      E8xxxxxxxx   call TControl.SetAutoSize
  }
  AControl.AutoSize := True;
end;

type
  PGetCodeRec = ^TGetCodeRec;
  TGetCodeRec = packed record
    Sign: Word; // $408a   bytes swapped
    Offset: Byte;
  end;

type
  PSetCodeRec = ^TSetCodeRec;
  TSetCodeRec = packed record
    Sign1: Word; // $01b2  bytes swapped
    Sign2: Byte; // $e8
    Offset: Integer;
  end;

const
  GetCodeSign = $408a;
  SetCodeSign1 = $01b2;
  SetCodeSign2 = $e8;

procedure InitHookVars;
var
  PGetCode: PGetCodeRec;
  PSetCode: PSetCodeRec;
begin
  TControl_SetAutoSize := nil;
  AutoSizeOffset := 0;

  PGetCode := @GetCode;
  PSetCode := @SetCode;

  if (PGetCode^.Sign = GetCodeSign) and
    (PSetCode^.Sign1 = SetCodeSign1) and
    (PSetCode^.Sign2 = SetCodeSign2) then
  begin
    AutoSizeOffset := PGetCode^.Offset;
    TControl_SetAutoSize :=
      GetRelocAddress(Pointer(Integer(@SetCode) + SizeOf(TSetCodeRec) + PSetCode^.Offset));
  end;
end;

{$IFNDEF OPTIMIZATION_ON}
{$OPTIMIZATION OFF} // switch optimization back off if needed
{$ENDIF !OPTIMIZATION_ON}

{$ENDIF COMPILER5}

//============================================================================

constructor TJvExControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FHintColor := clDefault;
end;

function TJvExControl.BaseWndProc(Msg: Integer; WParam: Integer = 0; LParam: Integer = 0): Integer;
var
  Mesg: TMessage;
begin
  Mesg.Msg := Msg;
  Mesg.WParam := WParam;
  Mesg.LParam := LParam;
  Mesg.Result := 0;
  inherited WndProc(Mesg);
  Result := Mesg.Result;
end;

procedure TJvExControl.VisibleChanged;
begin
  BaseWndProc(CM_VISIBLECHANGED);
end;

procedure TJvExControl.EnabledChanged;
begin
  BaseWndProc(CM_ENABLEDCHANGED);
end;

procedure TJvExControl.TextChanged;
begin
  BaseWndProc(CM_TEXTCHANGED);
end;

procedure TJvExControl.FontChanged;
begin
  BaseWndProc(CM_FONTCHANGED);
end;

procedure TJvExControl.ColorChanged;
begin
  BaseWndProc(CM_COLORCHANGED);
end;

procedure TJvExControl.ParentFontChanged;
begin
  BaseWndProc(CM_PARENTFONTCHANGED);
end;

procedure TJvExControl.ParentColorChanged;
begin
  BaseWndProc(CM_PARENTCOLORCHANGED);
  if Assigned(OnParentColorChange) then
    OnParentColorChange(Self);
end;

procedure TJvExControl.ParentShowHintChanged;
begin
  BaseWndProc(CM_PARENTSHOWHINTCHANGED);
end;

function TJvExControl.WantKey(Key: Integer; Shift: TShiftState; const KeyText: WideString): Boolean;
begin
  Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;
end;

function TJvExControl.HitTest(X, Y: Integer): Boolean;
begin
  Result := BaseWndProc(CM_HITTEST, 0, Integer(PointToSmallPoint(Point(X, Y)))) <> 0;
end;

function TJvExControl.HintShow(var HintInfo: THintInfo): Boolean;
begin
  GetHintColor(HintInfo, Self, FHintColor);
  Result := BaseWndProc(CM_HINTSHOW, 0, Integer(@HintInfo)) <> 0;
end;

procedure TJvExControl.MouseEnter(AControl: TControl);
begin
  FMouseOver := True;
  {$IFDEF VCL}
  if Assigned(FOnMouseEnter) then
    FOnMouseEnter(Self);
  {$ENDIF VCL}
  BaseWndProc(CM_MOUSEENTER, 0, Integer(AControl));
end;

procedure TJvExControl.MouseLeave(AControl: TControl);
begin
  FMouseOver := False;
  BaseWndProc(CM_MOUSELEAVE, 0, Integer(AControl));
  {$IFDEF VCL}
  if Assigned(FOnMouseLeave) then
    FOnMouseLeave(Self);
  {$ENDIF VCL}
end;

procedure TJvExControl.FocusChanged(AControl: TWinControl);
begin
  BaseWndProc(CM_FOCUSCHANGED, 0, Integer(AControl));
end;

{$IFDEF COMPILER5}
{$IFNDEF HASAUTOSIZE}

procedure TJvExControl.CMSetAutoSize(var Msg: TMessage);
begin
  SetAutoSize(Msg.WParam <> 0);
end;

procedure TJvExControl.SetAutoSize(Value: Boolean);
begin
  TOpenControl_SetAutoSize(Self, Value);
end;

{$ENDIF !HASAUTOSIZE}
{$ENDIF COMPILER5}

procedure TJvExControl.WndProc(var Msg: TMessage);
begin
  case Msg.Msg of
    CM_DENYSUBCLASSING:
      Msg.Result := Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil);
    CM_DIALOGCHAR:
      with TCMDialogChar(Msg) do
        Result := Ord(WantKey(CharCode, KeyDataToShiftState(KeyData), WideChar(CharCode)));
    CM_HINTSHOW:
      with TCMHintShow(Msg) do
        Result := Integer(HintShow(HintInfo^));
    CM_HITTEST:
      with TCMHitTest(Msg) do
        Result := Integer(HitTest(XPos, YPos));
    CM_MOUSEENTER:
      MouseEnter(TControl(Msg.LParam));
    CM_MOUSELEAVE:
      MouseLeave(TControl(Msg.LParam));
    CM_VISIBLECHANGED:
      VisibleChanged;
    CM_ENABLEDCHANGED:
      EnabledChanged;
    CM_TEXTCHANGED:
      TextChanged;
    CM_FONTCHANGED:
      FontChanged;
    CM_COLORCHANGED:
      ColorChanged;
    CM_FOCUSCHANGED:
      FocusChanged(TWinControl(Msg.LParam));
    CM_PARENTFONTCHANGED:
      ParentFontChanged;
    CM_PARENTCOLORCHANGED:
      ParentColorChanged;
    CM_PARENTSHOWHINTCHANGED:
      ParentShowHintChanged;
  else
    inherited WndProc(Msg);
  end;
end;

//============================================================================

constructor TJvExWinControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FHintColor := clDefault;
end;

function TJvExWinControl.BaseWndProc(Msg: Integer; WParam: Integer = 0; LParam: Integer = 0): Integer;
var
  Mesg: TMessage;
begin
  Mesg.Msg := Msg;
  Mesg.WParam := WParam;
  Mesg.LParam := LParam;
  Mesg.Result := 0;
  inherited WndProc(Mesg);
  Result := Mesg.Result;
end;

procedure TJvExWinControl.VisibleChanged;
begin
  BaseWndProc(CM_VISIBLECHANGED);
end;

procedure TJvExWinControl.EnabledChanged;
begin
  BaseWndProc(CM_ENABLEDCHANGED);
end;

procedure TJvExWinControl.TextChanged;
begin
  BaseWndProc(CM_TEXTCHANGED);
end;

procedure TJvExWinControl.FontChanged;
begin
  BaseWndProc(CM_FONTCHANGED);
end;

procedure TJvExWinControl.ColorChanged;
begin
  BaseWndProc(CM_COLORCHANGED);
end;

procedure TJvExWinControl.ParentFontChanged;
begin
  BaseWndProc(CM_PARENTFONTCHANGED);
end;

procedure TJvExWinControl.ParentColorChanged;
begin
  BaseWndProc(CM_PARENTCOLORCHANGED);
  if Assigned(OnParentColorChange) then
    OnParentColorChange(Self);
end;

procedure TJvExWinControl.ParentShowHintChanged;
begin
  BaseWndProc(CM_PARENTSHOWHINTCHANGED);
end;

function TJvExWinControl.WantKey(Key: Integer; Shift: TShiftState; const KeyText: WideString): Boolean;
begin
  Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;
end;

function TJvExWinControl.HitTest(X, Y: Integer): Boolean;
begin
  Result := BaseWndProc(CM_HITTEST, 0, Integer(PointToSmallPoint(Point(X, Y)))) <> 0;
end;

function TJvExWinControl.HintShow(var HintInfo: THintInfo): Boolean;
begin
  GetHintColor(HintInfo, Self, FHintColor);
  Result := BaseWndProc(CM_HINTSHOW, 0, Integer(@HintInfo)) <> 0;