jvbandobject.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: JvBandObject.PAS, released on 2001-07-10.

The Initial Developer of the Original Code is Chiang Seng Chang <csatt ctzen dott com>
Portions created by Chiang Seng Chang are Copyright (C) 2001 Chiang Seng Chang.
All Rights Reserved.

Contributor(s): ______________________________________.

You may retrieve the latest version of this file at the Project JEDI home page,
located at http://www.delphi-jedi.org

Description:
  Band objects wrapper classes.

Known Issues:
-----------------------------------------------------------------------------}
// $Id: JvBandObject.pas,v 1.26 2005/02/17 10:19:59 marquardt Exp $

unit JvBandObject;

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

interface

uses
  {$IFDEF UNITVERSIONING}
  JclUnitVersioning,
  {$ENDIF UNITVERSIONING}
  Windows, Messages, ComObj, ShlObj, ActiveX, Classes, Controls, 
  JvBandForms;

const
  CATID_DESKBAND = '{00021492-0000-0000-C000-000000000046}';
  CATID_INFOBAND = '{00021493-0000-0000-C000-000000000046}';
  CATID_COMMBAND = '{00021494-0000-0000-C000-000000000046}';

type
  // Band Object Factory Classes
  TzCustomBandObjectFactory = class(TComObjectFactory)
  private
    function GetClassIDString: string;
  public
    property ClassIDString: string read GetClassIDString;
  end;

  TzToolBandObjectFactory = class(TzCustomBandObjectFactory)
  public
    procedure UpdateRegistry(Reg: Boolean); override;
  end;

  TzCatBandObjectFactory = class(TzCustomBandObjectFactory)
  protected
    function GetImplCatID: TGUID; virtual; abstract;
  public
    procedure UpdateRegistry(Reg: Boolean); override;
  end;

  TzDeskBandObjectFactory = class(TzCatBandObjectFactory)
  protected
    function GetImplCatID: TGUID; override;
  end;

  TzExplorerBarObjectFactory = class(TzCatBandObjectFactory)
  private
    function BarSize: string;
  protected
    function GetURL: string; virtual;
    function GetBarWidth: Word; virtual;
    function GetBarHeight: Word; virtual;
  public
    procedure UpdateRegistry(Reg: Boolean); override;
  end;

  TzInfoBandObjectFactory = class(TzExplorerBarObjectFactory)
  protected
    function GetImplCatID: TGUID; override;
  end;

  TzCommBandObjectFactory = class(TzExplorerBarObjectFactory)
  protected
    function GetImplCatID: TGUID; override;
  end;

  TzCustomBandObject = class(TComObject, IDeskBand, IObjectWithSite, IPersist, IPersistStream, IInputObject)
  private
    FBandForm: TJvBandForm;
    FBandID: DWORD;
    FViewMode: DWORD;
    FSite: IInputObjectSite;
    FOleCommandTarget: IOleCommandTarget;
    FSavedWndProc: TWndMethod;
    FHasFocus: Boolean;
    FHook: HHook;
  protected
    function CreateBandForm(const ParentWnd: HWND): TJvBandForm; virtual; abstract;
    procedure BandWndProc(var Msg: TMessage);
    procedure FocusChange(HasFocus: Boolean);
  public
    procedure AfterConstruction; override;
    procedure BeforeDestruction; override;
    function BandInfoChanged: HRESULT;
    function Maximize: HRESULT;
    function ShowAllBands: HRESULT;
    function HideAllBands: HRESULT;
    function ShowMeOnly: HRESULT;
    property BandID: DWORD read FBandID;
    property ViewMode: DWORD read FViewMode;
    property Site: IInputObjectSite read FSite;
    property OleCommandTarget: IOleCommandTarget read FOleCommandTarget;
    function GetBandInfo(BandID, ViewMode: DWORD;
      var Dbi: TDeskBandInfo): HRESULT; virtual; stdcall;
    function ShowDW(AShow: BOOL): HRESULT; virtual; stdcall;
    function CloseDW(dwReserved: DWORD): HRESULT; virtual; stdcall;
    function ResizeBorderDW(var Border: TRect;
      ToolbarSite: IUnknown; Reserved: BOOL): HRESULT; virtual; stdcall;
    function GetWindow(out Wnd: HWND): HRESULT; virtual; stdcall;
    function ContextSensitiveHelp(EnterMode: BOOL): HRESULT; virtual; stdcall;
    function SetSite(const Site: IUnknown): HRESULT; virtual; stdcall;
    function GetSite(const Riid: TIID; out Site: IUnknown): HRESULT; virtual; stdcall;
    function IsDirty: HRESULT; virtual; stdcall;
    function Load(const Strm: IStream): HRESULT; virtual; stdcall;
    function Save(const Strm: IStream; ClearDirty: BOOL): HRESULT; virtual; stdcall;
    function GetSizeMax(out Size: Largeint): HRESULT; virtual; stdcall;
    function GetClassID(out ClassID: TCLSID): HRESULT; virtual; stdcall;
    function UIActivateIO(Activate: BOOL; var Msg: TMsg): HRESULT; virtual; stdcall;
    function HasFocusIO: HRESULT; virtual; stdcall;
    function TranslateAcceleratorIO(var Msg: TMsg): HRESULT; virtual; stdcall;
  published
    function MsgHookProc(nCode, wParam, lParam: Integer): Integer; stdcall;
  end;

  TzToolBandObject = class(TzCustomBandObject)
  end;

  TzContextMenuBandObject = class(TzCustomBandObject, IContextMenu)
  public
    FMenuItemLink: TList;
    function QueryContextMenu(AMenu: HMENU;
      IndexMenu, idCmdFirst, idCmdLast, uFlags: UINT): HRESULT; virtual; stdcall;
    function InvokeCommand(var Ici: TCMInvokeCommandInfo): HRESULT; virtual; stdcall;
    function GetCommandString(idCmd, uType: UINT; pwReserved: PUINT;
      pszName: LPSTR; cchMax: UINT): HRESULT; virtual; stdcall;
  end;

  TzDeskBandObject = class(TzContextMenuBandObject)
  end;

  TzInfoBandObject = class(TzContextMenuBandObject)
  end;

  TzCommBandObject = class(TzContextMenuBandObject)
  end;

{$IFDEF UNITVERSIONING}
const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$RCSfile: JvBandObject.pas,v $';
    Revision: '$Revision: 1.26 $';
    Date: '$Date: 2005/02/17 10:19:59 $';
    LogPath: 'JVCL\run'
  );
{$ENDIF UNITVERSIONING}

implementation

uses
  {$IFDEF DEBUGINFO_ON}
  //zTrace,
  {$ENDIF DEBUGINFO_ON}
  SysUtils, Registry, Math, Forms, Menus,
  JvConsts, JvJVCLUtils;

const
  cIERegistryBase = 'Software\Microsoft\Internet Explorer\';
  cCLSID = 'CLSID\';
  cBarSize = 'BarSize';
  cExplorerBars = 'Explorer Bars\';
  cInstanceInitPropertyBagUrl = '\Instance\InitPropertyBag\Url';
  cInstanceInitPropertyBag = '\Instance\InitPropertyBag';
  cInstanceCLSID = '\Instance\CLSID';
  cInstance = '\Instance';

{$IFDEF DEBUGINFO_ON}
// (rom) debugging deactivated
procedure zTraceLog(const LogText: string);
begin
end;
{$ENDIF DEBUGINFO_ON}

function MakeHResult(Sev, Fac, Code: LongWord): HRESULT;
begin
  Result := (Sev shl 31) or (Fac shl 16) or Code;
end;

//=== { TzCustomBandObjectFactory } ==========================================

function TzCustomBandObjectFactory.GetClassIDString: string;
begin
  Result := GUIDToString(ClassID);
end;

//=== { TzToolBandObjectFactory } ============================================

function MethodToProcedure(Self: TObject; MethodAddr: Pointer): Pointer;
type
  TMethodToProc = packed record
    PopEAX: Byte;        // $58      pop EAX
    PushSelf: record     //          push Self
      Opcode: Byte;      // $B8
      Self: Pointer;     // Self
    end;
    PushEAX: Byte;       // $50      push EAX
    Jump: record         //          jmp [Target]
      Opcode: Byte;      // $FF
      ModRm: Byte;       // $25
      PTarget: ^Pointer; // @Target
      Target: Pointer;   //          @MethodAddr
    end;
  end;
var
  Mtp: ^TMethodToProc;
begin
  New(Mtp);
  Result := Mtp;
  with Mtp^ do
  begin
    PopEAX          := $58;
    PushSelf.Opcode := $68;
    PushSelf.Self   := Self;
    PushEAX         := $50;
    Jump.Opcode     := $FF;
    Jump.ModRm      := $25;
    Jump.PTarget    := @Jump.Target;
    Jump.Target     := MethodAddr;
  end;
end;

procedure TzToolBandObjectFactory.UpdateRegistry(Reg: Boolean);
begin
  if Reg then
    inherited;
  with TRegistry.Create do
  try
    RootKey := HKEY_LOCAL_MACHINE;
    if OpenKey(cIERegistryBase + 'Toolbar', True) then
    try
      if Reg then
        WriteString(ClassIDString, Description)
      else
        DeleteValue(ClassIDString);
    finally
      CloseKey;
    end;
  finally
    Free;
  end;
  if not Reg then
    inherited UpdateRegistry(Reg);
end;

//=== { TzCatBandObjectFactory } =============================================

procedure TzCatBandObjectFactory.UpdateRegistry(Reg: Boolean);
var
  CatRegister: ICatRegister;
  ImplCatID: TGUID;
begin
  if Reg then
    inherited;
  ImplCatID := GetImplCatID;
  CoInitialize(nil);
  CatRegister := ComObj.CreateComObject(CLSID_StdComponentCategoryMgr) as ICatRegister;
  if Reg then
    CatRegister.RegisterClassImplCategories(ClassID, 1, @ImplCatID)
  else
  begin
    CatRegister.UnregisterClassImplCategories(ClassID, 1, @ImplCatID);
    DeleteRegKey(cCLSID + ClassIDString + '\Implemented Categories');
  end;
  CatRegister := nil;
  CoUninitialize;
  if not Reg then
    inherited UpdateRegistry(Reg);
end;

//=== { TzDeskBandObjectFactory } ============================================

function TzDeskBandObjectFactory.GetImplCatID: TGUID;
begin
  Result := StringToGUID(CATID_DESKBAND);
end;

//=== { TzExplorerBarObjectFactory } =========================================

function TzExplorerBarObjectFactory.BarSize: string;
var
  S: string;
begin
  S := Format('%.4x', [GetBarWidth]);
  Result := Copy(S, 3, 2) + ',' + Copy(S, 1, 2) + ',';
  S := Format('%.4x', [GetBarHeight]);
  Result := Result + Copy(S, 3, 2) + ',' + Copy(S, 1, 2) + ',00,00,00,00';
end;

function TzExplorerBarObjectFactory.GetBarHeight: Word;
begin
  Result := 0;
end;

function TzExplorerBarObjectFactory.GetBarWidth: Word;
begin
  Result := 0;
end;

function TzExplorerBarObjectFactory.GetURL: string;
begin
  Result := '';
end;

procedure TzExplorerBarObjectFactory.UpdateRegistry(Reg: Boolean);
begin
  if Reg then
  begin
    inherited UpdateRegistry(Reg);
    if GetURL <> '' then
    begin
      CreateRegKey(cCLSID + ClassIDString + cInstanceCLSID, '', '{4D5C8C2A-D075-11D0-B416-00C04FB90376}');
      CreateRegKey(cCLSID + ClassIDString + cInstanceInitPropertyBagUrl, '', GetURL);
    end;
    if (GetBarWidth <> 0) or (GetBarHeight <> 0) then
    begin
      with TRegistry.Create do
      try
        RootKey := HKEY_CURRENT_USER;
        if OpenKey(cIERegistryBase + cExplorerBars + ClassIDString, True) then
        try
          WriteString(cBarSize, BarSize)
        finally
          CloseKey;
        end;
      finally
        Free;
      end;
    end;
  end
  else
  begin
    with TRegistry.Create do
    try
      RootKey := HKEY_CURRENT_USER;
      if OpenKey(cIERegistryBase + cExplorerBars + ClassIDString, True) then
      try
        DeleteValue(cBarSize);
      finally
        CloseKey;
      end;
      DeleteKey(cIERegistryBase + cExplorerBars + ClassIDString);
    finally
      Free;
    end;
    DeleteRegKey(cCLSID + ClassIDString + cInstanceInitPropertyBagUrl);
    DeleteRegKey(cCLSID + ClassIDString + cInstanceInitPropertyBag);
    DeleteRegKey(cCLSID + ClassIDString + cInstanceCLSID);
    DeleteRegKey(cCLSID + ClassIDString + cInstance);
    inherited UpdateRegistry(Reg);
  end;
end;

//=== { TzInfoBandObjectFactory } ============================================

function TzInfoBandObjectFactory.GetImplCatID: TGUID;
begin
  Result := StringToGUID(CATID_INFOBAND);
end;