jvwndprochook.pas

East make Tray Icon in delphi

  inherited Create;
  FHandle := AHandle;
  FillChar(FFirst, SizeOf(FFirst), 0);
  FillChar(FLast, SizeOf(FLast), 0);
  //FillChar(FStack, SizeOf(FStack), 0);
  //FillChar(FStackCapacity, SizeOf(FStackCapacity), 0);
  //FillChar(FStackCount, SizeOf(FStackCount), 0);
end;

procedure TJvHookInfos.DecDepth;
begin
  if FStackCount > 0 then
    Dec(FStackCount);
end;

procedure TJvHookInfos.Delete(const Order: TJvHookOrder; Hook: TJvControlHook);
var
  HookInfo: PJvHookInfo;
  PrevHookInfo: PJvHookInfo;
  I: Integer;
begin
  HookInfo := FFirst[Order];
  PrevHookInfo := nil;
  while (HookInfo <> nil) and
    ((TMethod(HookInfo.Hook).Code <> TMethod(Hook).Code) or
    (TMethod(HookInfo.Hook).Data <> TMethod(Hook).Data)) do
    {  This is unique: Code = the object whereto the method belongs
                       Data = identifies the method in the object }
  begin
    PrevHookInfo := HookInfo;
    HookInfo := HookInfo.Next;
  end;

  if not Assigned(HookInfo) then
    Exit;

  // patch up the hole (this is the reason for this entire unit!)
  if PrevHookInfo <> nil then
    PrevHookInfo.Next := HookInfo.Next;

  { Bookkeeping }
  if FLast[Order] = HookInfo then
    FLast[Order] := PrevHookInfo;
  if FFirst[Order] = HookInfo then
    FFirst[Order] := HookInfo.Next;

  { Update the stack }
  if Order = hoBeforeMsg then
    I := 0
  else
    I := 1;
  while I < FStackCount * 2 do
  begin
    if FStack[I] = HookInfo then
      FStack[I] := HookInfo.Next;
    Inc(I, 2);
  end;

  Dispose(HookInfo);

  if (FFirst[hoBeforeMsg] = nil) and (FFirst[hoAfterMsg] = nil) then
    { Could also call ReleaseObj(Self). Now this object stays in memory until
      the Control it was hooking will be destroyed. }

    UnHookControl;
end;

destructor TJvHookInfos.Destroy;
var
  HookInfo: PJvHookInfo;
  Order: TJvHookOrder;
begin
  { Remove this TJvHookInfos object from the list of Controller,
    Controller might already be set to nil (in ControlDestroyed) }
  Controller := nil;

  UnHookControl;

  for Order := Low(TJvHookOrder) to High(TJvHookOrder) do
    while FFirst[Order] <> nil do
    begin
      HookInfo := FFirst[Order];
      FFirst[Order] := HookInfo.Next;
      Dispose(HookInfo);
    end;
  FreeMem(FStack);

  inherited Destroy;
end;

procedure TJvHookInfos.HookControl;
begin
  if FHooked or FControlDestroyed then
    Exit;
  if FControl <> nil then
  begin
    FOldWndProc := FControl.WindowProc;
    FControl.WindowProc := WindowProc;
    FHooked := True;
  end
  else
  begin
    TMethod(FOldWndProc).Data := nil;
    TMethod(FOldWndProc).Code := Pointer(GetWindowLong(FHandle, GWL_WNDPROC));
    SetWindowLong(FHandle, GWL_WNDPROC, Integer(MakeObjectInstance(WindowProc)));
    FHooked := True;
  end;
end;

procedure TJvHookInfos.IncDepth;
begin
  if FStackCount >= FStackCapacity then
  begin
    { Upsize the stack }
    Inc(FStackCapacity);
    FStackCapacity := FStackCapacity * 2;
    ReallocMem(FStack, 2 * FStackCapacity * SizeOf(Pointer));
  end;
  Inc(FStackCount);
end;

procedure TJvHookInfos.SetController(const Value: TJvWndProcHook);
begin
  if Value <> FController then
  begin
    if Assigned(FController) then
      FController.Remove(Self);

    FController := Value;

    if Assigned(FController) then
      FController.Add(Self);
  end;
end;

procedure TJvHookInfos.UnHookControl;
var
  Ptr: Pointer;
begin
  if not FHooked or FControlDestroyed then
    Exit;
  if FControl <> nil then
  begin
    FControl.WindowProc := FOldWndProc;
    FHooked := False;
  end
  else
  begin
    Ptr := Pointer(GetWindowLong(FHandle, GWL_WNDPROC));
    SetWindowLong(FHandle, GWL_WNDPROC, Integer(TMethod(FOldWndProc).Code));
    FHooked := False;
    FreeObjectInstance(Ptr);
  end;
end;

procedure TJvHookInfos.WindowProc(var Msg: TMessage);
var
  TmpHookInfo: PJvHookInfo;
  { FStack[Index] is used to travel through the hook infos;
    FStack[Index] points to the current hook info (and might be nil)
    Note that the address of FStack may change due to ReallocMem calls in
    IncDepth; thus we can't assign FStack[Index] to a local var.
  }
  Index: Integer;
begin
  { An object can now report for every possible message that he has
    handled that message, thus preventing the original control from
    handling the message; this is probably not a good idea in the case
    of WM_DESTROY, WM_CLOSE etc. But that's the users responsibility,
    I think }

  Msg.Result := 0;

  IncDepth;
  // (rb) Don't know what the performance impact of a try..finally is.
  try
    { The even members in the stack are hoBeforeMsg hooks }
    Index := 2 * (FStackCount - 1);
    FStack[Index] := FFirst[hoBeforeMsg];
    while Assigned(FStack[Index]) do
    begin
      { We retrieve the next hook info *before* the call to Hook(), because,
        see (I) }
      TmpHookInfo := FStack[Index];
      FStack[Index] := FStack[Index].Next;
      if TmpHookInfo.Hook(Msg) or FControlDestroyed then
        Exit;
      { FStack[Index] may now be changed because of register/unregister calls
        inside HookInfo.Hook(Msg). }
    end;

    { Maybe only exit here (before the original control handles the message),
      thus enabling all hooks to respond to the message? Otherwise if you
      have 2 components of the same class, that hook a control, then only 1 will
      get the message }

    if TMethod(FOldWndProc).Data <> nil then
      FOldWndProc(Msg)
    else
    if TMethod(FOldWndProc).Code <> nil then
      Msg.Result := CallWindowProc(TMethod(FOldWndProc).Code, Handle, Msg.Msg,
        Msg.WParam, Msg.LParam);

    if FControlDestroyed then
      Exit;

    { The odd members in the list are hoAftermsg hooks }
    Index := 2 * FStackCount - 1;
    FStack[Index] := FFirst[hoAfterMsg];
    while Assigned(FStack[Index]) do
    begin
      TmpHookInfo := FStack[Index];
      FStack[Index] := FStack[Index].Next;
      if TmpHookInfo.Hook(Msg) or FControlDestroyed then
        Exit;
    end;
  finally
    DecDepth;
    if (Control = nil) and (Msg.Msg = WM_DESTROY) then
      // Handle is being destroyed: remove all hooks on this window
      ControlDestroyed;
  end;

  { (I)
         HookInfos before                                HookInfos after
         call to Hook()                                  call to Hook()

        |----------|  If FStack[Index] point to A        |----------|
     -->| hook A   |  (arrow) and hook A deletes itself  | hook B   |<--
        |----------|  then after the call to Hook,       |----------|
        | hook B   |  FStack[Index] points to B. If we   | hook C   |
        |----------|  then call Next, FStack[Index]      |----------|
        | hook C   |  points to C (should be B)
        |----------|
      }
end;

//=== { TJvWindowHook } ======================================================

constructor TJvWindowHook.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FActive := True;
end;

procedure TJvWindowHook.DefineProperties(Filer: TFiler);

  function DoWrite: Boolean;
  begin
    if Assigned(Filer.Ancestor) then
      Result := IsForm <> TJvWindowHook(Filer.Ancestor).IsForm
    else
      Result := IsForm;
  end;

begin
  inherited DefineProperties(Filer);
  Filer.DefineProperty('IsForm', ReadForm, WriteForm, DoWrite);
end;

destructor TJvWindowHook.Destroy;
begin
  Active := False;
  Control := nil;
  inherited Destroy;
end;

function TJvWindowHook.DoAfterMessage(var Msg: TMessage): Boolean;
begin
  Result := False;
  if Assigned(FAfterMessage) then
    FAfterMessage(Self, Msg, Result);
end;

function TJvWindowHook.DoBeforeMessage(var Msg: TMessage): Boolean;
begin
  Result := False;
  if Assigned(FBeforeMessage) then
    FBeforeMessage(Self, Msg, Result);
end;

procedure TJvWindowHook.HookControl;
begin
  SetActive(True);
end;

function TJvWindowHook.IsForm: Boolean;
begin
  Result := (Control <> nil) and ((Control = Owner) and (Owner is TCustomForm));
end;

procedure TJvWindowHook.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if Operation = opRemove then
  begin
    if AComponent = Control then
      Control := nil
        { Correct? }
    else
      if (Owner = AComponent) or (Owner = nil) then
      Control := nil;
  end;
end;

function TJvWindowHook.NotIsForm: Boolean;
begin
  { Correct? }
  Result := (Control <> nil) and not (Control is TCustomForm);
end;

procedure TJvWindowHook.ReadForm(Reader: TReader);
begin
  if Reader.ReadBoolean then
    if Owner is TCustomForm then
      Control := TControl(Owner);
end;

procedure TJvWindowHook.SetActive(Value: Boolean);
begin
  if FActive = Value then
    Exit;

  if not (csDesigning in ComponentState) then
  begin
    if Value then
    begin
      { Only register if assigned, to prevent unnecessarily overhead }
      if Assigned(FAfterMessage) then
        WndProcHook.RegisterWndProc(FControl, DoAfterMessage, hoAfterMsg);
      if Assigned(FBeforeMessage) then
        WndProcHook.RegisterWndProc(FControl, DoBeforeMessage, hoBeforeMsg);
    end
    else
    begin
      if Assigned(FAfterMessage) then
        WndProcHook.UnRegisterWndProc(FControl, DoAfterMessage, hoAfterMsg);
      if Assigned(FBeforeMessage) then
        WndProcHook.UnRegisterWndProc(FControl, DoBeforeMessage, hoBeforeMsg);
    end;
  end;
  FActive := Value;
end;

procedure TJvWindowHook.SetAfterMessage(const Value: TJvHookMessageEvent);
begin
  if Active and not (csDesigning in ComponentState) then
  begin
    { Only register if assigned, to prevent unnecessarily overhead }
    if Assigned(Value) and not Assigned(FAfterMessage) then
      WndProcHook.RegisterWndProc(FControl, DoAfterMessage, hoAfterMsg)
    else
      if not Assigned(Value) and Assigned(FAfterMessage) then
      WndProcHook.UnRegisterWndProc(FControl, DoAfterMessage, hoAfterMsg);
  end;
  FAfterMessage := Value;
end;

procedure TJvWindowHook.SetBeforeMessage(const Value: TJvHookMessageEvent);
begin
  if Active and not (csDesigning in ComponentState) then
  begin
    { Only register if assigned, to prevent unnecessarily overhead }
    if Assigned(Value) and not Assigned(FBeforeMessage) then
      WndProcHook.RegisterWndProc(FControl, DoBeforeMessage, hoBeforeMsg)
    else
      if not Assigned(Value) and Assigned(FBeforeMessage) then
      WndProcHook.UnRegisterWndProc(FControl, DoBeforeMessage, hoBeforeMsg);
  end;
  FBeforeMessage := Value;
end;

procedure TJvWindowHook.SetControl(Value: TControl);
var
  SavedActive: Boolean;
begin
  if Value <> Control then
  begin
    SavedActive := Active;
    Active := False;
    if FControl <> nil then
      FControl.RemoveFreeNotification(Self);

    if Assigned(Value) and (csDestroying in Value.ComponentState) then
      { (rb) this should not happen in calls made by Jv components }
      FControl := nil
    else
    begin
      FControl := Value;

      if FControl <> nil then
        FControl.FreeNotification(Self);

      Active := SavedActive;
    end;
  end;
end;

procedure TJvWindowHook.UnHookControl;
begin
  SetActive(False);
end;

procedure TJvWindowHook.WriteForm(Writer: TWriter);
begin
  Writer.WriteBoolean(IsForm);
end;

//=== { TJvReleaser } ========================================================

procedure TJvReleaser.CMRelease(var Msg: TMessage);
var
  Obj: TObject;
  Index: Integer;
begin
  Index := FReleasing.IndexOf(Pointer(Msg.WParam));
  if Index >= 0 then
    FReleasing.Delete(Index);

  Obj := TObject(Msg.WParam);
  Obj.Free;
end;

constructor TJvReleaser.Create;
begin
  inherited Create;
  FReleasing := TList.Create;
end;

procedure TJvReleaser.DefaultHandler(var Msg);
begin
  with TMessage(Msg) do
    if FHandle <> 0 then
      Result := CallWindowProc(@DefWindowProc, FHandle, Msg, WParam, LParam);
end;

destructor TJvReleaser.Destroy;
begin
  while FReleasing.Count > 0 do
  begin
    TObject(FReleasing[0]).Free;
    FReleasing.Delete(0);
  end;

  FReleasing.Free;
  if FHandle <> 0 then
    DeallocateHWnd(FHandle);

  inherited Destroy;
end;

function TJvReleaser.GetHandle: HWND;
begin
  if FHandle = 0 then
    FHandle := AllocateHWnd(WndProc);
  Result := FHandle;
end;

class function TJvReleaser.Instance: TJvReleaser;
begin
  if GReleaser = nil then
    GReleaser := TJvReleaser.Create;
  Result := GReleaser;
end;

procedure TJvReleaser.Release(AObject: TObject);
begin
  { Make sure we're not already releasing this object }
  if FReleasing.IndexOf(AObject) < 0 then
  begin
    FReleasing.Add(AObject);
    PostMessage(Handle, CM_RELEASE, Integer(AObject), 0);
  end;
end;

procedure TJvReleaser.WndProc(var Msg: TMessage);
begin
  try
    Dispatch(Msg);
  except
    {$IFDEF COMPILER6_UP}
    if Assigned(ApplicationHandleException) then
      ApplicationHandleException(Self);
    {$ELSE}
    Application.HandleException(Self);
    {$ENDIF COMPILER6_UP}
  end;
end;

initialization
  {$IFDEF UNITVERSIONING}
  RegisterUnitVersion(HInstance, UnitVersioning);
  {$ENDIF UNITVERSIONING}

finalization
  { Don't call FreeAndNil for GReleaser, it's (hypothetically) possible that
    objects need access to the GReleaser var (via call to ReleaseObj) during
    GReleaser.Destroy }
  GReleaser.Free;
  FreeAndNil(GJvWndProcHook);
  GReleaser := nil;
  {$IFDEF UNITVERSIONING}
  UnregisterUnitVersion(HInstance);
  {$ENDIF UNITVERSIONING}

end.