jvbackgrounds.pas

East make Tray Icon in delphi

          Delta := 0;
        MaxChange := (nMax - Delta) - nPos;
        if Delta > MaxChange then
          Delta := MaxChange;
        Delta := -Delta;
      end;
    SB_THUMBPOSITION:
      Delta := -Msg.Pos;
  end;
  Result := Delta * ScrollUnit;
end;

procedure TJvBackgroundClientLink.ClientWndProc(var Message: TMessage);

  procedure InvalidateBackground;
  begin
    InvalidateRect(ClientHandle, nil, True);
  end;

begin
  if ClientHandle <> 0 then
    with FBackground.FImage, Message do
    begin
      if ClientIsMDIForm then
      begin
        if Msg = WM_ERASEBKGND then
          if FEnabled and DoEraseBackground(FClient, TWMEraseBkgnd(Message).DC) then
          begin
            Result := 1;
            Exit;
          end;
      end
      else // not ClientIsMDIForm
      begin
        if FEnabled then
          case Msg of
            WM_PAINT:
              if HandleWMPaint(FClient, Message) then
                Exit;
            WM_ERASEBKGND:
              if HandleWMEraseBkgnd(FClient, Message) then
                Exit;
          end;
        Result := CallWindowProc(FPrevWndProc, ClientHandle, Msg, wParam, lParam);
        if Msg = CM_RELEASE then
          Exit;
      end;
      case Msg of
        WM_DESTROY:
          begin
            UnhookClient;
            if not (csDestroying in FClient.ComponentState) then
              PostMessage(FBackground.FHandle, CM_RECREATEWINDOW, 0, Longint(Self));
          end;
        WM_SIZE:
          if not (FMode in [bmTile, bmTopLeft]) then
            InvalidateBackground;
        WM_HSCROLL:
          begin
            if ClientIsMDIForm then
              Inc(FHorzOffset, GetMDIClientScrollDelta(ClientHandle,
                SB_HORZ, TWMScroll(Message)));
            if FMode <> bmTile then
              InvalidateBackground;
          end;
        WM_VSCROLL:
          begin
            if ClientIsMDIForm then
              Inc(FVertOffset, GetMDIClientScrollDelta(ClientHandle,
                SB_VERT, TWMScroll(Message)));
            if FMode <> bmTile then
              InvalidateBackground;
          end;
      end;
      if ClientIsMDIForm then
        Result := CallWindowProc(FPrevWndProc, ClientHandle, Msg, wParam, lParam);
    end;
end;

procedure TJvBackgroundClientLink.MainWndProc(var Msg: TMessage);
begin
  try
    try
      ClientWndProc(Msg);
    finally
      //FreeDeviceContexts;
      FreeMemoryContexts;
    end;
  except
    Application.HandleException(Self);
  end;
end;

procedure TJvBackgroundClientLink.ForceClient(Value: TWinControl; Force: Boolean = True);
var
  I: Integer;
  Bk: TJvBackground;
begin
  if Value <> FClient then
  begin
    for I := 0 to Backgrounds.Count - 1 do
    begin
      Bk := Backgrounds[I];
      if (Bk <> FBackground) and Bk.HasClient(Value) then
        if Force then
        begin
          Bk.Clients.Remove(Value);
          Break;
        end
        else
          Exit;
    end;
    UnhookClient;
    {$IFDEF COMPILER5_UP}
    if Assigned(FClient) then
      FBackground.RemoveFreeNotification(FClient);
    {$ENDIF COMPILER5_UP}
    FClient := Value;
    if Assigned(Value) then
    begin
      FClientIsMDIForm := IsMDIForm(Value);
      FBackground.FreeNotification(Value);
      if not (csLoading in FBackground.ComponentState) then
        HookClient;
    end;
  end;
end;

procedure TJvBackgroundClientLink.HookClient;
begin
  {$IFDEF NO_DESIGNHOOK}
  if csDesigning in ComponentState then
    Exit;
  {$ENDIF NO_DESIGNHOOK}
  if Assigned(FClient) and not Assigned(FPrevWndProc) then
    if not ((csLoading in FClient.ComponentState) or ((FClient is TCustomForm) and (csDesigning in FClient.ComponentState))) then
    begin
      FClient.HandleNeeded;
      FPrevWndProc := Pointer(SetWindowLong(ClientHandle, GWL_WNDPROC, Longint(FNewWndProc)));
      FBackground.FImage.UpdateWorkingBmp;
    end;
end;

procedure TJvBackgroundClientLink.UnhookClient;
const
  WorkaroundStr: array [Boolean] of string = ('', SWorkaround);
begin
  if Assigned(FPrevWndProc) then
    if Assigned(FClient) then
    begin
      if FClient.HandleAllocated then
      begin
        if (Longint(FNewWndProc) <>
          SetWindowLong(ClientHandle, GWL_WNDPROC, Longint(FPrevWndProc))) and
          not (csDestroying in FClient.ComponentState) then
          MessageDlg(Format(SChainError, [FBackground.Owner.Name, FBackground.Name, FClient.Name,
            WorkaroundStr[csDesigning in FBackground.ComponentState]]),
              mtWarning, [mbOK], 0);
      end;
      FPrevWndProc := nil;
      ClientInvalidate;
      FClientIsMDIForm := False;
    end;
end;

function TJvBackgroundClientLink.GetClientColor: TColor;
begin
  Result := TWinControlAccessProtected(FClient).Color;
end;

function TJvBackgroundClientLink.GetClientHandle: HWND;
begin
  Result := 0;
  if FClient is TCustomForm then
    Result := TForm(FClient).ClientHandle;
  if Result = 0 then
    if FClient.HandleAllocated then
      Result := FClient.Handle;
end;

procedure TJvBackgroundClientLink.SetClient(Value: TWinControl);
begin
  ForceClient(Value);
end;

procedure TJvBackgroundClientLink.Release;
begin
  UnhookClient;
  PostMessage(FBackground.FHandle, CM_RELEASECLIENTLINK, 0, Longint(Self));
end;

//=== { TJvBackgroundClients } ===============================================

constructor TJvBackgroundClients.Create(ABackground: TJvBackground);
begin
  inherited Create;
  FBackground := ABackground;
  FLinks := TObjectList.Create;
  FLinks.OwnsObjects := False;
  FFixups := TStringList.Create;
end;

destructor TJvBackgroundClients.Destroy;
begin
  FFixups.Free;
  FLinks.Clear;
  FLinks.Free;
  inherited Destroy;
end;

procedure TJvBackgroundClients.Clear;
var
  I: Integer;
begin
  for I := 0 to FLinks.Count - 1 do
    Links[I].Release;
  FLinks.Clear;
end;

procedure TJvBackgroundClients.Add(Control: TWinControl);
begin
  if IndexOf(Control) < 0 then
    FLinks.Add(TJvBackgroundClientLink.Create(FBackground, Control));
end;

procedure TJvBackgroundClients.Remove(Control: TWinControl);
var
  I: Integer;
  Link: TJvBackgroundClientLink;
begin
  I := IndexOf(Control);
  if I >= 0 then
  begin
    Link := TJvBackgroundClientLink(Links[I]);
    FLinks.Delete(I);
    Link.Release;
  end;
end;

function TJvBackgroundClients.GetClient(Index: Integer): TWinControl;
begin
  Result := TJvBackgroundClientLink(FLinks[Index]).Client;
end;

function TJvBackgroundClients.IndexOf(Control: TWinControl): Integer;
var
  I: Integer;
begin
  Result := -1;
  for I := 0 to FLinks.Count - 1 do
    if Links[I].Client = Control then
    begin
      Result := I;
      Exit;
    end;
end;

procedure TJvBackgroundClients.Notification(AComponent: TComponent; Operation: TOperation);
var
  I: Integer;
  Client: TWinControl;
begin
  if Operation = opRemove then
    for I := 0 to FLinks.Count - 1 do
    begin
      Client := Links[I].Client;
      if AComponent = Client then
        Remove(Client);
    end;
end;

procedure TJvBackgroundClients.DefineProperties(Filer: TFiler);

  function WriteClients: Boolean;
  var
    I: Integer;
    AncestorClients: TJvBackgroundClients;
  begin
    AncestorClients := TJvBackgroundClients(Filer.Ancestor);
    if AncestorClients = nil then
      Result := True // FLinks.Count > 0
    else
    if AncestorClients.FLinks.Count <> FLinks.Count then
      Result := True
    else
    begin
      Result := False;
      for I := 0 to FLinks.Count - 1 do
      begin
        Result := not (Clients[I] = AncestorClients[I]);
        if Result then
          Break;
      end
    end;
  end;

begin
  inherited DefineProperties(Filer);
  Filer.DefineProperty('Clients', ReadData, WriteData, WriteClients);
end;

procedure TJvBackgroundClients.ReadData(Reader: TReader);
begin
  Reader.ReadListBegin;
  while not Reader.EndOfList do
    FFixups.Add(Reader.ReadString);
  Reader.ReadListEnd;
end;

procedure TJvBackgroundClients.WriteData(Writer: TWriter);
var
  I: Integer;
begin
  Writer.WriteListBegin;
  for I := 0 to FLinks.Count - 1 do
    Writer.WriteString(Clients[I].Name);
  Writer.WriteListEnd;
end;

procedure TJvBackgroundClients.FixupReferences(Root: TComponent);
var
  I: Integer;
  S: string;
  NextItem: TComponent;
begin
  FLinks.Clear;
  with FFixups do
  begin
    FLinks.Capacity := Capacity;
    for I := 0 to Count - 1 do
    begin
      S := Strings[I];
      if Root.Name = S then
        NextItem := Root
      else
        NextItem := Root.FindComponent(Strings[I]);
      if NextItem = nil then
        Break;
      if NextItem is TWinControl then
        Self.Add(TWinControl(NextItem));
    end;
  end;
end;

function TJvBackgroundClients.GetLink(Index: Integer): TJvBackgroundClientLink;
begin
  Result := TJvBackgroundClientLink(FLinks[Index]);
end;

procedure TJvBackgroundClients.Invalidate;
var
  I: Integer;
begin
  for I := 0 to FLinks.Count - 1 do
    Links[I].ClientInvalidate;
end;

//=== { TJvBackground } ======================================================

var
  Registered: Boolean = False;

constructor TJvBackground.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FHandle := AllocateHWnd(WndProc);
  FImage := TJvBackgroundImage.Create;
  FImage.FOnChange := WallpaperChanged;
  if Backgrounds = nil then
    Backgrounds := TList.Create;
  Backgrounds.Add(Self);
  FClients := TJvBackgroundClients.Create(Self);
  if csDesigning in ComponentState then
    if Assigned(Owner) then
      if Owner is TWinControl then
        FClients.Add(TWinControl(Owner));
  if not Registered then
  begin
    Classes.RegisterClasses([TJvBackgroundImage]);
    Registered := True;
  end;
end;

destructor TJvBackground.Destroy;
begin
  DeallocateHWnd(FHandle);
  FClients.Free;
  Backgrounds.Remove(Self);
  FImage.Free;
  inherited Destroy;
end;

procedure TJvBackground.Loaded;
begin
  inherited Loaded;
  FClients.FixupReferences(Owner);
end;

procedure TJvBackground.Notification(AComponent: TComponent; Operation: TOperation);
begin
  if not (csDestroying in ComponentState) and Assigned(FClients) then
    FClients.Notification(AComponent, Operation);
  inherited Notification(AComponent, Operation);
end;

procedure TJvBackground.SetClients(Value: TJvBackgroundClients);
begin
  // dummy method to make Clients property visible in Object Inspector
end;

procedure TJvBackground.WallpaperChanged;
begin
  Clients.Invalidate;
end;

procedure TJvBackground.WndProc(var Msg: TMessage);
begin
  try
    case Msg.Msg of
      CM_RECREATEWINDOW:
        TJvBackgroundClientLink(Msg.lParam).HookClient;
      CM_RELEASECLIENTLINK:
        TJvBackgroundClientLink(Msg.lParam).Free;
    else
      Msg.Result := DefWindowProc(FHandle, Msg.Msg, Msg.wParam, Msg.lParam);
    end;
  except
    Application.HandleException(Self);
  end;
end;

procedure TJvBackground.SetImage(const Value: TJvBackgroundImage);
begin
  FImage.Assign(Value);
end;

function TJvBackground.HasClient(Control: TWinControl): Boolean;
begin
  Result := Clients.IndexOf(Control) >= 0;
end;

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

finalization
  FreeAndNil(Hooked);
  FreeAndNil(Backgrounds);
  {$IFDEF UNITVERSIONING}
  UnregisterUnitVersion(HInstance);
  {$ENDIF UNITVERSIONING}

end.