jclshell.pas

East make Tray Icon in delphi

{**************************************************************************************************}
{                                                                                                  }
{ Project JEDI Code Library (JCL)                                                                  }
{                                                                                                  }
{ 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/                                                           }
{                                                                                                  }
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF   }
{ ANY KIND, either express or implied. See the License for the specific language governing rights  }
{ and limitations under the License.                                                               }
{                                                                                                  }
{ The Original Code is JclShell.pas.                                                               }
{                                                                                                  }
{ The Initial Developers of the Original Code are Marcel van Brakel and Petr Vones.                }
{ Portions created by these individuals are Copyright (C) of these individuals.                    }
{ All Rights Reserved.                                                                             }
{                                                                                                  }
{ Contributor(s):                                                                                  }
{   Rik Barker (rikbarker)                                                                         }
{   Marcel van Brakel                                                                              }
{   Jeff                                                                                           }
{   Aleksej Kudinov                                                                                }
{   Robert Marquardt (marquardt)                                                                   }
{   Robert Rossmair (rrossmair)                                                                    }
{   Olivier Sannier (obones)                                                                       }
{   Matthias Thoma (mthoma)                                                                        }
{   Petr Vones (pvones)                                                                            }
{                                                                                                  }
{**************************************************************************************************}
{                                                                                                  }
{ This unit contains routines and classes which makes working with the Windows Shell a bit easier. }
{ Included are routines for working with PIDL's, special folder's, file and folder manipulation    }
{ through shell interfaces, shortcut's and program execution.                                      }
{                                                                                                  }
{**************************************************************************************************}

// Last modified: $Date: 2005/02/25 07:20:16 $
// For history see end of file

unit JclShell;

{$I jcl.inc}

interface

uses
  Windows, SysUtils,
  {$IFNDEF FPC}
  ShlObj,
  {$ENDIF ~FPC}
  JclWin32, JclSysUtils;

// Files and Folders
type
  TSHDeleteOption  = (doSilent, doAllowUndo, doFilesOnly);
  TSHDeleteOptions = set of TSHDeleteOption;
  TSHRenameOption  = (roSilent, roRenameOnCollision);
  TSHRenameOptions = set of TSHRenameOption;

  TUnicodePath     = array [0..MAX_PATH-1] of WideChar;
  TAnsiPath        = array [0..MAX_PATH-1] of char;

function SHDeleteFiles(Parent: HWND; const Files: string; Options: TSHDeleteOptions): Boolean;
function SHDeleteFolder(Parent: HWND; const Folder: string; Options: TSHDeleteOptions): Boolean;
function SHRenameFile(const Src, Dest: string; Options: TSHRenameOptions): Boolean;

type
  TEnumFolderFlag = (efFolders, efNonFolders, efIncludeHidden);
  TEnumFolderFlags = set of TEnumFolderFlag;

  TEnumFolderRec = record
    DisplayName: string;
    Attributes: DWORD;
    IconLarge: HICON;
    IconSmall: HICON;
    Item: PItemIdList;
    EnumIdList: IEnumIdList;
    Folder: IShellFolder;
  end;

function SHEnumFolderFirst(const Folder: string; Flags: TEnumFolderFlags;
  var F: TEnumFolderRec): Boolean;
function SHEnumSpecialFolderFirst(SpecialFolder: DWORD; Flags: TEnumFolderFlags;
  var F: TEnumFolderRec): Boolean;
procedure SHEnumFolderClose(var F: TEnumFolderRec);
function SHEnumFolderNext(var F: TEnumFolderRec): Boolean;

function GetSpecialFolderLocation(const Folder: Integer): string;

function DisplayPropDialog(const Handle: HWND; const FileName: string): Boolean; overload;
function DisplayPropDialog(const Handle: HWND; Item: PItemIdList): Boolean; overload;

function DisplayContextMenuPidl(const Handle: HWND; const Folder: IShellFolder;
  Item: PItemIdList; Pos: TPoint): Boolean;
function DisplayContextMenu(const Handle: HWND; const FileName: string;
  Pos: TPoint): Boolean;

function OpenFolder(const Path: string; Parent: HWND = 0): Boolean;
function OpenSpecialFolder(FolderID: Integer; Parent: HWND = 0): Boolean;

// Memory Management
function SHReallocMem(var P: Pointer; Count: Integer): Boolean;
function SHAllocMem(out P: Pointer; Count: Integer): Boolean;
function SHGetMem(var P: Pointer; Count: Integer): Boolean;
function SHFreeMem(var P: Pointer): Boolean;

// Paths and PIDLs
function DriveToPidlBind(const DriveName: string; out Folder: IShellFolder): PItemIdList;
function PathToPidl(const Path: string; Folder: IShellFolder): PItemIdList;
function PathToPidlBind(const FileName: string; out Folder: IShellFolder): PItemIdList;
function PidlBindToParent(IdList: PItemIdList; out Folder: IShellFolder; out Last: PItemIdList): Boolean;
function PidlCompare(Pidl1, Pidl2: PItemIdList): Boolean;
function PidlCopy(Source: PItemIdList; out Dest: PItemIdList): Boolean;
function PidlFree(var IdList: PItemIdList): Boolean;
function PidlGetDepth(Pidl: PItemIdList): Integer;
function PidlGetLength(Pidl: PItemIdList): Integer;
function PidlGetNext(Pidl: PItemIdList): PItemIdList;
function PidlToPath(IdList: PItemIdList): string;

function StrRetFreeMem(StrRet: TStrRet): Boolean;
function StrRetToString(IdList: PItemIdList; StrRet: TStrRet; Free: Boolean): string;

// Shortcuts / Shell link
type
  PShellLink = ^TShellLink;
  TShellLink = record
    Arguments: string;
    ShowCmd: Integer;
    WorkingDirectory: string;
    IdList: PItemIDList;
    Target: string;
    Description: string;
    IconLocation: string;
    IconIndex: Integer;
    HotKey: Word;
  end;

procedure ShellLinkFree(var Link: TShellLink);
function ShellLinkResolve(const FileName: string; var Link: TShellLink): HRESULT;
function ShellLinkCreate(const Link: TShellLink; const FileName: string): HRESULT;
function ShellLinkCreateSystem(const Link: TShellLink; const Folder: Integer; const FileName: string): HRESULT;
function ShellLinkIcon(const Link: TShellLink): HICON; overload;
function ShellLinkIcon(const FileName: string): HICON; overload;

// Miscellaneous
function SHDllGetVersion(const FileName: string; var Version: TDllVersionInfo): Boolean;

function GetSystemIcon(IconIndex: Integer; Flags: Cardinal): HICON;
function OverlayIcon(var Icon: HICON; Overlay: HICON; Large: Boolean): Boolean;
function OverlayIconShortCut(var Large, Small: HICON): Boolean;
function OverlayIconShared(var Large, Small: HICON): Boolean;
function SHGetItemInfoTip(const Folder: IShellFolder; Item: PItemIdList): string;

function ShellExecEx(const FileName: string; const Parameters: string = ''; const Verb: string = '';
  CmdShow: Integer = SW_SHOWNORMAL): Boolean;
function ShellExec(Wnd: Integer; const Operation, FileName, Parameters, Directory: string; ShowCommand: Integer): Boolean;
function ShellExecAndWait(const FileName: string; const Parameters: string = ''; const Verb: string = '';
  CmdShow: Integer = SW_SHOWNORMAL): Boolean;

function ShellOpenAs(const FileName: string): Boolean;
function ShellRasDial(const EntryName: string): Boolean;
function ShellRunControlPanel(const NameOrFileName: string; AppletNumber: Integer = 0): Boolean;

function GetFileNameIcon(const FileName: string; Flags: Cardinal = 0): HICON;

type
  TJclFileExeType = (etError, etMsDos, etWin16, etWin32Gui, etWin32Con);

function GetFileExeType(const FileName: TFileName): TJclFileExeType;

function ShellFindExecutable(const FileName, DefaultDir: string): string;

//MSI functions and types used in ShellLinkResolve - copied from JwaMsi.pas
type
  INSTALLSTATE = Longint;
const
  MSILIB = 'msi.dll';
var
  RtdlMsiLibHandle: TModuleHandle = INVALID_MODULEHANDLE_VALUE;
  RtdlMsiGetShortcutTarget: function(szShortcutPath: LPCSTR; szProductCode: LPSTR;
    szFeatureId: LPSTR; szComponentCode: LPSTR): UINT; stdcall = nil;

  RtdlMsiGetComponentPath: function(szProduct: LPCSTR; szComponent: LPCSTR;
    lpPathBuf: LPSTR; pcchBuf: LPDWORD): INSTALLSTATE; stdcall = nil;

implementation

uses
  ActiveX,
  {$IFNDEF FPC}
  CommCtrl,
  {$ENDIF ~FPC}
  Messages, ShellApi,
  JclFileUtils, JclStrings, JclSysInfo;

const
  cVerbProperties = 'properties';
  cVerbOpen = 'open';

//=== Files and Folders ======================================================

// Helper function and constant to map a TSHDeleteOptions set to a Cardinal

const
  FOF_COMPLETELYSILENT = FOF_SILENT or FOF_NOCONFIRMATION or FOF_NOERRORUI or FOF_NOCONFIRMMKDIR;

function DeleteOptionsToCardinal(Options: TSHDeleteOptions): Cardinal;
begin
  Result := 0;
  if doSilent in Options then
    Result := Result or FOF_COMPLETELYSILENT;
  if doAllowUndo in Options then
    Result := Result or FOF_ALLOWUNDO;
  if doFilesOnly in Options then
    Result := Result or FOF_FILESONLY;
end;

function SHDeleteFiles(Parent: HWND; const Files: string;
  Options: TSHDeleteOptions): Boolean;
var
  FileOp: TSHFileOpStruct;
  Source: string;
begin
  FillChar(FileOp, SizeOf(FileOp), #0);
  with FileOp do
  begin
    {$IFDEF FPC}
    hwnd := Parent;
    {$ELSE}
    Wnd := Parent;
    {$ENDIF FPC}
    wFunc := FO_DELETE;
    Source := Files + #0#0;
    pFrom := PChar(Source);
    fFlags := DeleteOptionsToCardinal(Options);
  end;
  {$IFDEF FPC}
  Result := SHFileOperation(@FileOp) = 0;
  {$ELSE}
  Result := SHFileOperation(FileOp) = 0;
  {$ENDIF FPC}
end;

function SHDeleteFolder(Parent: HWND; const Folder: string;
  Options: TSHDeleteOptions): Boolean;
begin
  Exclude(Options, doFilesOnly);
  Result := SHDeleteFiles(Parent, PathAddSeparator(Folder) + '*.*', Options);
  if Result then
    SHDeleteFiles(Parent, Folder, Options);
end;

// Helper function to map a TSHRenameOptions set to a cardinal

function RenameOptionsToCardinal(Options: TSHRenameOptions): Cardinal;
begin
  Result := 0;
  if roRenameOnCollision in Options then
    Result := Result or FOF_RENAMEONCOLLISION;
  if roSilent in Options then
    Result := Result or FOF_COMPLETELYSILENT;
end;

function SHRenameFile(const Src, Dest: string; Options: TSHRenameOptions): Boolean;
var
  FileOp: TSHFileOpStruct;
  Source, Destination: string;
begin
  FillChar(FileOp, SizeOf(FileOp), #0);
  with FileOp do
  begin
    {$IFDEF FPC}
    hwnd := GetDesktopWindow;
    {$ELSE}
    Wnd := GetDesktopWindow;
    {$ENDIF FPC}
    wFunc := FO_RENAME;
    Source := Src + #0#0;
    Destination := Dest + #0#0;
    pFrom := PChar(Source);
    pTo := PChar(Destination);
    fFlags := RenameOptionsToCardinal(Options);
  end;
  {$IFDEF FPC}
  Result := SHFileOperation(@FileOp) = 0;
  {$ELSE}
  Result := SHFileOperation(FileOp) = 0;
  {$ENDIF FPC}
end;

function EnumFolderFlagsToCardinal(Flags: TEnumFolderFlags): Cardinal;
begin
  Result := 0;
  if efFolders in Flags then
    Result := Result or SHCONTF_FOLDERS;
  if efNonFolders in Flags then
    Result := Result or SHCONTF_NONFOLDERS;
  if efIncludeHidden in Flags then
    Result := Result or SHCONTF_INCLUDEHIDDEN;
end;

procedure ClearEnumFolderRec(var F: TEnumFolderRec; const Free, Release: Boolean);
begin
  if Release then
  begin
    F.EnumIdList := nil;
    F.Folder := nil;
  end;
  if Free then
  begin
    PidlFree(F.Item);
    DestroyIcon(F.IconLarge);
    DestroyIcon(F.IconSmall);
  end;
  F.Attributes := 0;
  F.Item := nil;
  F.IconLarge := 0;
  F.IconSmall := 0;
end;

procedure SHEnumFolderClose(var F: TEnumFolderRec);
begin
  ClearEnumFolderRec(F, True, True);
end;

function SHEnumFolderNext(var F: TEnumFolderRec): Boolean;
const
  Attr = Cardinal(SFGAO_CAPABILITYMASK or SFGAO_DISPLAYATTRMASK or SFGAO_CONTENTSMASK);
var
  DisplayNameRet: TStrRet;
  ItemsFetched: ULONG;
  ExtractIcon: IExtractIcon;
  IconFile: TUnicodePath;
  IconIndex: Integer;
  Flags: DWORD;
begin
  Result := False;
  ClearEnumFolderRec(F, True, False);
  if (F.EnumIdList = nil) or (F.Folder = nil) then
    Exit;
  if F.EnumIdList.Next(1, F.Item, ItemsFetched) = NO_ERROR then
  begin
    F.Folder.GetDisplayNameOf(F.Item, SHGDN_INFOLDER, DisplayNameRet);
    F.DisplayName := StrRetToString(F.Item, DisplayNameRet, True);
    F.Attributes := Attr;
    F.Folder.GetAttributesOf(1, F.Item, F.Attributes);
    F.Folder.GetUIObjectOf(0, 1, F.Item, IID_IExtractIconW, nil,
      Pointer(ExtractIcon));
    Flags := 0;
    F.IconLarge := 0;
    F.IconSmall := 0;
    
    if Assigned(ExtractIcon) then
    begin
      ExtractIcon.GetIconLocation(0, @IconFile, MAX_PATH, IconIndex, Flags);
      if (IconIndex < 0) and ((Flags and GIL_NOTFILENAME) = GIL_NOTFILENAME) then
        ExtractIconEx(@IconFile, IconIndex, F.IconLarge, F.IconSmall, 1)
      else
        ExtractIcon.Extract(@IconFile, IconIndex, F.IconLarge, F.IconSmall,
          MakeLong(32, 16));
    end;
          
    Result := True;