jvbackgrounds.pas

East make Tray Icon in delphi

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.

The Original Code is: JvBackgrounds.PAS, released on 2004-04-26.

The Initial Developer of the Original Code is Robert Rossmair [Robert dott Rossmair att t-online dott de]
Portions created by Robert Rossmair are Copyright (C) 2003 Robert Rossmair.
All Rights Reserved.

Contributors:
  Andreas Hausladen (ahuser)
  Peter Thornqvist (peter3)
  Robert Marquardt (marquardt)
  Robert Rossmair (rrossmair)

You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.sourceforge.net

Known Issues:
-----------------------------------------------------------------------------}
// $Id: JvBackgrounds.pas,v 1.19 2005/02/21 10:33:57 rrossmair Exp $

unit JvBackgrounds;

{$I jvcl.inc}
{$I windowsonly.inc}

interface

{***************** Conditional Compiler Symbols ************************

 USEJVCL        JEDI VCL installed (http://sourceforge.net/projects/jvcl/)

 USE_JvGIF      use TGIFImage class from JVCL

 USE_AM_GIF     use GIFImage library by Anders Melander et alii
                (download address: http://finn.mobilixnet.dk/delphi/).

 NO_DESIGNHOOK  Disables visual feedback in design mode.
                $DEFINE this if you experience problems in design mode.
                Such problems might occur if there are other components
                manipulating the TrrBackgrounds.Client's window
                procedure.
 *********************************************************************** }

{$DEFINE USEJVCL}
{.$DEFINE USE_AM_GIF}
{.$DEFINE USE_JvGIF}

{$IFDEF USE_JvGIF}
{$UNDEF USE_AM_GIF}
{$ENDIF USE_JvGIF}

uses
  {$IFDEF USEJVCL}
  {$IFDEF UNITVERSIONING}
  JclUnitVersioning,
  {$ENDIF UNITVERSIONING}
  {$ENDIF USEJVCL}
  Windows, Messages, Contnrs, Graphics, Controls, Forms, Classes,
  JclGraphUtils,
  JvTypes;

type
  TJvBackgroundMode = (bmTile, bmCenter, bmTopLeft, bmTop, bmTopRight, bmLeft,
    bmBottomLeft, bmRight, bmBottom, bmBottomRight, bmStretch);
  EJvBackgroundError = class(EJVCLException);
  TJvBackgroundShiftMode = (smRows, smColumns);

  TJvBackgroundImage = class(TPersistent)
  private
    FPicture: TPicture;
    FCanvas: TCanvas;
    FHorzOffset: Integer;
    FVertOffset: Integer;
    FOnChange: TNotifyEvent;
    FWorkingBmp: TBitmap;
    FInUpdWorkingBmp: Boolean;
    FMode: TJvBackgroundMode;
    FTransparent: Boolean;
    FTransparentMode: TTransparentMode;
    FTransparentColor: TColor;
    FTileWidth: Integer;
    FTileHeight: Integer;
    FShift: Integer;
    FShiftMode: TJvBackgroundShiftMode;
    FZigZag: Boolean;
    FAutoSizeTile: Boolean;
    FFitPictureSize: Boolean;
    FEnabled: Boolean;
    FPictureValid: Boolean;
    FGrayMapped: Boolean;
    procedure SetGrayMapped(Value: Boolean);
    procedure SysColorChange;
    class function MainWindowHook(var Msg: TMessage): Boolean;
    procedure HookMainWindow;
    procedure UnhookMainWindow;
    procedure Changed;
    function GetTransparentColor: TColor;
    procedure PictureChanged(Sender: TObject);
    procedure SetAutoSizeTile(Value: Boolean);
    procedure SetEnabled(Value: Boolean);
    procedure SetFitPictureSize(Value: Boolean);
    procedure SetMode(Value: TJvBackgroundMode);
    procedure SetPicture(Value: TPicture);
    procedure SetShift(Value: Integer);
    procedure SetShiftMode(Value: TJvBackgroundShiftMode);
    procedure SetTileWidth(Value: Integer);
    procedure SetTileHeight(Value: Integer);
    procedure SetTransparent(Value: Boolean);
    procedure SetTransparentColor(Value: TColor);
    procedure SetTransparentMode(Value: TTransparentMode);
    procedure SetZigZag(Value: Boolean);
    procedure TileGraphic(AClient: TControl; Graphic: TGraphic);
    function TransparentColorStored: Boolean;
    procedure UpdateWorkingBmp;
    procedure WorkingBmpNeeded;
  protected
    function HandleWMEraseBkgnd(AClient: TWinControl; var Msg: TMessage): Boolean;
    function HandleWMPaint(AClient: TWinControl; var Msg: TMessage): Boolean;
    procedure PaintGraphic(AClient: TControl; DC: HDC; Graphic: TGraphic);
    property Canvas: TCanvas read FCanvas;
    property WorkingBmp: TBitmap read FWorkingBmp;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    function DoEraseBackground(AClient: TWinControl; DC: HDC): Boolean;
  published
    property AutoSizeTile: Boolean read FAutoSizeTile write SetAutoSizeTile
      default True;
    property Enabled: Boolean read FEnabled write SetEnabled default True;
    property FitPictureSize: Boolean
      read FFitPictureSize write SetFitPictureSize default False;
    property GrayMapped: Boolean read FGrayMapped write SetGrayMapped default False;
    property Mode: TJvBackgroundMode read FMode write SetMode default bmTile;
    property Picture: TPicture read FPicture write SetPicture;
    property TileWidth: Integer read FTileWidth write SetTileWidth;
    property TileHeight: Integer read FTileHeight write SetTileHeight;
    property Transparent: Boolean read FTransparent write SetTransparent default False;
    property TransparentColor: TColor read GetTransparentColor
      write SetTransparentColor stored TransparentColorStored;
    property TransparentMode: TTransparentMode read FTransparentMode
      write SetTransparentMode default tmAuto;
    property Shift: Integer read FShift write SetShift default 0;
    property ShiftMode: TJvBackgroundShiftMode read FShiftMode write SetShiftMode default smRows;
    property ZigZag: Boolean read FZigZag write SetZigZag default False;
  end;

  TJvControlBackground = class(TJvBackgroundImage)
  private
    FClient: TWinControl;
  public
    function HookBeforeMessage(var Msg: TMessage): Boolean;
    procedure HookAfterMessage(var Msg: TMessage);
    constructor Create(AClient: TWinControl);
  end;

  TJvBackground = class;

  TJvBackgroundClientLink = class(TObject)
  private
    FBackground: TJvBackground;
    FClient: TWinControl;
    FNewWndProc: Pointer;
    FPrevWndProc: TFarProc;
    FClientIsMDIForm: Boolean;
    procedure ClientInvalidate;
    procedure MainWndProc(var Msg: TMessage);
    procedure ClientWndProc(var Message: TMessage);
    procedure ForceClient(Value: TWinControl; Force: Boolean = True);
    procedure HookClient;
    procedure UnhookClient;
    function GetClientColor: TColor;
    function GetClientHandle: HWND;
    procedure SetClient(Value: TWinControl);
  protected
    procedure Release;
    property Background: TJvBackground read FBackground;
    property ClientColor: TColor read GetClientColor;
    property ClientHandle: HWND read GetClientHandle;
    property Client: TWinControl read FClient write SetClient;
    property ClientIsMDIForm: Boolean read FClientIsMDIForm;
  public
    constructor Create(ABackground: TJvBackground; AClient: TWinControl);
    destructor Destroy; override;
  end;

  TJvBackgroundClients = class(TPersistent)
  private
    FBackground: TJvBackground;
    FLinks: TObjectList;
    FFixups: TStringList;
    function GetClient(Index: Integer): TWinControl;
    procedure Invalidate;
    procedure Notification(AComponent: TComponent; Operation: TOperation);
    procedure FixupReferences(Root: TComponent);
    procedure ReadData(Reader: TReader);
    procedure WriteData(Writer: TWriter);
    function GetLink(Index: Integer): TJvBackgroundClientLink;
  protected
    procedure DefineProperties(Filer: TFiler); override;
    property Background: TJvBackground read FBackground;
    property Links[Index: Integer]: TJvBackgroundClientLink read GetLink;
  public
    constructor Create(ABackground: TJvBackground);
    destructor Destroy; override;
    procedure Clear;
    procedure Add(Control: TWinControl);
    procedure Remove(Control: TWinControl);
    function IndexOf(Control: TWinControl): Integer;
    property Clients[Index: Integer]: TWinControl read GetClient; default;
  end;

  TJvBackground = class(TComponent)
  private
    FClients: TJvBackgroundClients;
    FHandle: HWND;
    FImage: TJvBackgroundImage;
    procedure SetClients(Value: TJvBackgroundClients);
    procedure WallpaperChanged(Sender: TObject);
    procedure WndProc(var Msg: TMessage);
    procedure SetImage(const Value: TJvBackgroundImage);
  protected
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function HasClient(Control: TWinControl): Boolean;
  published
    property Image: TJvBackgroundImage read FImage write SetImage;
    property Clients: TJvBackgroundClients read FClients write SetClients;
  end;

procedure GetMappedGrays(var Shades: array of TColor; StartIntensity: Byte);

{$IFDEF USEJVCL}
{$IFDEF UNITVERSIONING}
const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$RCSfile: JvBackgrounds.pas,v $';
    Revision: '$Revision: 1.19 $';
    Date: '$Date: 2005/02/21 10:33:57 $';
    LogPath: 'JVCL\run'
  );
{$ENDIF UNITVERSIONING}
{$ENDIF USEJVCL}

implementation

uses
  SysUtils, jpeg,
  StdCtrls, CommCtrl, ComCtrls, Dialogs,
  {$IFDEF USE_AM_GIF}
  GIFImage,
  {$DEFINE HANDLES_GIF}
  {$ENDIF USE_AM_GIF}
  {$IFDEF USE_JvGIF}
  JvGIF,
  {$DEFINE HANDLES_GIF}
  {$ENDIF USE_JvGIF}
  JvConsts, JvResources;

type
  TWinControlAccessProtected = class(TWinControl);

  {$IFDEF USE_JvGIF}
  // make TJvGIFImage's Bitmap property visible
  TGIFImage = class(TJvGIFImage);
  {$ENDIF USE_JvGIF}

const
  ScrollLineSize = 3;
  ScrollUnit = 8;

  CM_RECREATEWINDOW = CM_BASE + 82;
  CM_RELEASECLIENTLINK = CM_BASE + 83;

type
  TColorGradation = array [Byte] of TColor;
  PColorGradation = ^TColorGradation;

var
  SysColorGradation: TColorGradation;
  SysColorGradationInitialized: Boolean = False;
  Hooked: TList = nil;
  Backgrounds: TList = nil;

procedure UpdateSysColorGradation;
var
  SysHLS: THLSVector;
  FaceLum, MaxLum: THLSValue;
  I: Integer;
begin
  SysHLS := RGBtoHLS(ColorToRGB(clBtnHighlight));
  MaxLum := SysHLS.Luminance;
  SysHLS := RGBtoHLS(ColorToRGB(clBtnFace));
  FaceLum := SysHLS.Luminance;
  with SysHLS do
  begin
    for I := 0 to 192 do
    begin
      Luminance := I * FaceLum div 192;
      SysColorGradation[I] := HLStoRGB(Hue, Luminance, Saturation);
    end;
    for I := 193 to 255 do
    begin
      Luminance := FaceLum + (MaxLum - FaceLum) * (I - 192) div (255 - 192);
      SysColorGradation[I] := HLStoRGB(Hue, Luminance, Saturation);
    end;
  end;
end;

procedure SysColorsNeeded;
begin
  if not SysColorGradationInitialized then
  begin
    SysColorGradationInitialized := True;
    UpdateSysColorGradation;
  end;
end;

procedure GetMappedGrays(var Shades: array of TColor; StartIntensity: Byte);
var
  I, Intensity: Integer;
begin
  SysColorsNeeded;
  Intensity := StartIntensity;
  for I := Low(Shades) to High(Shades) do
  begin
    Shades[I] := SysColorGradation[Intensity];
    if Intensity < High(SysColorGradation) then
      Inc(Intensity);
  end;
end;

procedure MapGrays(Dest: TBitmap; Source: TGraphic);
var
  Grays: PColorGradation;
  I: Integer;
  SrcWasTransparent: Boolean;
begin
  if Source = nil then
    Exit;
  New(Grays);
  try
    for I := Low(Grays^) to High(Grays^) do
      Grays[I] := RGB(I, I, I);
    with Dest do
    begin
      if ((Source is TBitmap) and (TBitmap(Source).PixelFormat in [pf1bit..pf8bit]))
        {$IFDEF HANDLES_GIF} or (Source is TGIFImage) {$ENDIF} then
        Assign(Source)
      else
      begin
        PixelFormat := pf8bit;
        Width := Source.Width;
        Height := Source.Height;
        SetBitmapColors(Dest, Grays^, 0);
        SrcWasTransparent := Source.Transparent;
        try
          Source.Transparent := False;
          Canvas.Draw(0, 0, Source);
        finally
          Source.Transparent := SrcWasTransparent;
        end;
      end;
      Handle := CreateMappedBmp(Handle, Grays^, SysColorGradation);
    end;
  finally
    Dispose(Grays);
  end;
end;

function TrimmedOffset(Offset, TileDim: Integer): Integer;
begin
  if TileDim <> 0 then
    if Offset > 0 then
      Offset := (Offset mod TileDim) - TileDim
    else
    if Offset < 0 then
      Dec(Offset, (Offset div TileDim) * TileDim);
  Result := Offset;
end;

function GetClientRect(AClient: TControl): TRect;
var
  MDIClientHandle: HWND;
begin
  if AClient is TCustomForm then
  begin
    MDIClientHandle := TForm(AClient).ClientHandle;
    if MDIClientHandle <> 0 then
    begin
      Windows.GetClientRect(MDIClientHandle, Result);
      Exit;
    end;
  end;
  Result := AClient.ClientRect;
end;

function GetVirtualClientRect(AClient: TControl): TRect;
var
  ClientHandle: HWND;
  ScrollInfo: TScrollInfo;
  R: TRect;
  TVTopItem: TTreeNode;
begin
  Result := GetClientRect(AClient);
  if AClient is TWinControl then
  begin
    ClientHandle := TWinControl(AClient).Handle;
    FillChar(ScrollInfo, SizeOf(ScrollInfo), 0);
    ScrollInfo.cbSize := SizeOf(ScrollInfo);
    ScrollInfo.fMask := SIF_ALL;
    GetScrollInfo(ClientHandle, SB_HORZ, ScrollInfo);
    if ScrollInfo.nPage > 0 then // horizontal scroll bar visible
    begin
      if ScrollInfo.nMax > Result.Right then
        Result.Right := ScrollInfo.nMax;
      Dec(Result.Left, ScrollInfo.nPos);
      Dec(Result.Right, ScrollInfo.nPos);
    end;
    GetScrollInfo(ClientHandle, SB_VERT, ScrollInfo);
    if ScrollInfo.nPage > 0 then // vertical scroll bar visible
    begin
      if AClient is TCustomListBox then
        with TListBox(AClient) do
        begin
          ScrollInfo.nPos := ScrollInfo.nPos * ItemHeight;
          ScrollInfo.nMax := ScrollInfo.nMax * ItemHeight;
        end
      else
      if AClient is TCustomTreeView then
      begin
        TVTopItem := TCustomTreeView(AClient).TopItem;
        if Assigned(TVTopItem) and TreeView_GetItemRect(ClientHandle, TVTopItem.ItemID, R, False) then
        begin
          ScrollInfo.nPos := ScrollInfo.nPos * R.Bottom;
          ScrollInfo.nMax := ScrollInfo.nMax * R.Bottom;
        end;
      end;
      if ScrollInfo.nMax > Result.Bottom then
        Result.Bottom := ScrollInfo.nMax;
      Dec(Result.Top, ScrollInfo.nPos);
      Dec(Result.Bottom, ScrollInfo.nPos);
    end;
  end;
end;