{******************************************************************************}
{                                                                              }
{ 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 Developer of the Original Code is documented in the accompanying }
{ help file JCL.chm. Portions created by these individuals are Copyright (C)   }
{ of these individuals.                                                        }
{                                                                              }
{******************************************************************************}
{                                                                              }
{ 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.                                                       }
{                                                                              }
{ Unit owner: Marcel van Brakel                                                }
{ Last modified: April 29, 2001                                                }
{                                                                              }
{******************************************************************************}

unit JclShell;

{$I jcl.inc}

{$WEAKPACKAGEUNIT ON}

interface

uses
  Windows, Graphics, ShlObj, SysUtils,
  JclBase;

//------------------------------------------------------------------------------
// Files and Folders
//------------------------------------------------------------------------------

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

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; const 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 {$IFDEF SUPPORTS_DEFAULTPARAMS} = 0 {$ENDIF}): Boolean;
function OpenSpecialFolder(FolderID: Integer; Parent: HWND {$IFDEF SUPPORTS_DEFAULTPARAMS} = 0 {$ENDIF}): 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(const IdList: PItemIdList; out Folder: IShellFolder;
  out Last: PItemIdList): Boolean;
function PidlCompare(const Pidl1, Pidl2: PItemIdList): Boolean;
function PidlCopy(const Source: PItemIdList; out Dest: PItemIdList): Boolean;
function PidlFree(var IdList: PItemIdList): Boolean;
function PidlGetDepth(const Pidl: PItemIdList): Integer;
function PidlGetLength(const Pidl: PItemIdList): Integer;
function PidlGetNext(const 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 ShellLinkGetIcon(const Link: TShellLink; const Icon: TIcon): Boolean;  

//------------------------------------------------------------------------------
// Miscellanuous
//------------------------------------------------------------------------------

type
  PDllVersionInfo = ^TDllVersionInfo;
  _DllVersionInfo = packed record
    cbSize: DWORD;
    dwMajorVersion: DWORD;
    dwMinorVersion: DWORD;
    dwBuildNumber: DWORD;
    dwPlatformId: DWORD;
  end;
  TDllVersionInfo = _DllVersionInfo;

const
  DLLVER_PLATFORM_WINDOWS = $00000001;
  DLLVER_PLATFORM_NT      = $00000002;

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 ShellExec(const FileName: string;
  const Parameters: string {$IFDEF SUPPORTS_DEFAULTPARAMS} = '' {$ENDIF};
  const Verb: string {$IFDEF SUPPORTS_DEFAULTPARAMS} = '' {$ENDIF};
  CmdShow: Integer {$IFDEF SUPPORTS_DEFAULTPARAMS} = SW_SHOWNORMAL {$ENDIF}): Boolean;
function ShellExecAndWait(const FileName: string;
  const Parameters: string {$IFDEF SUPPORTS_DEFAULTPARAMS} = '' {$ENDIF};
  const Verb: string {$IFDEF SUPPORTS_DEFAULTPARAMS} = '' {$ENDIF};
  CmdShow: Integer {$IFDEF SUPPORTS_DEFAULTPARAMS} = SW_SHOWNORMAL {$ENDIF}): Boolean;

function ShellOpenAs(const FileName: string): Boolean;
function ShellRasDial(const EntryName: string): Boolean;
function ShellRunControlPanel(const NameOrFileName: string;
  AppletNumber: Integer {$IFDEF SUPPORTS_DEFAULTPARAMS} = 0 {$ENDIF}): Boolean;

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

function GetFileExeType(const FileName: TFileName): TJclFileExeType;

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

implementation

uses
  ActiveX, CommCtrl, ComObj, Messages, ShellApi,
  JclFileUtils, JclStrings, JclSysInfo, JclSysUtils;

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
    Wnd := Parent;
    wFunc := FO_DELETE;
    Source := Files + #0#0;
    pFrom := PChar(Source);
    fFlags := DeleteOptionsToCardinal(Options);
  end;
  Result := SHFileOperation(FileOp) = 0;
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
    Wnd := GetDesktopWindow;
    wFunc := FO_RENAME;
    Source := Src + #0#0;
    Destination := Dest + #0#0;
    pFrom := PChar(Source);
    pTo := PChar(Destination);
    fFlags := RenameOptionsToCardinal(Options);
  end;
  Result := SHFileOperation(FileOp) = 0;
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.IconLarge);
  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: array [0..MAX_PATH] of WideChar;
  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;
    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));
    Result := True;
  end;
end;

//------------------------------------------------------------------------------

function SHEnumSpecialFolderFirst(SpecialFolder: DWORD; Flags: TEnumFolderFlags;
  var F: TEnumFolderRec): Boolean;
var
  DesktopFolder: IShellFolder;
  FolderPidl: PItemIdList;
begin
  ClearEnumFolderRec(F, False, False);
  SHGetDesktopFolder(DesktopFolder);
  if SpecialFolder = CSIDL_DESKTOP then
    F.Folder := DesktopFolder
  else
  begin
    SHGetSpecialFolderLocation(0, SpecialFolder, FolderPidl);
    try
      DesktopFolder.BindToObject(FolderPidl, nil, IID_IShellFolder, Pointer(F.Folder));
    finally
      PidlFree(FolderPidl);
    end;
  end;
  F.Folder.EnumObjects(0, EnumFolderFlagsToCardinal(Flags), F.EnumIdList);
  Result := SHEnumFolderNext(F);
  if not Result then
    SHEnumFolderClose(F);
end;

//------------------------------------------------------------------------------

function SHEnumFolderFirst(const Folder: string; Flags: TEnumFolderFlags;
  var F: TEnumFolderRec): Boolean;
var
  DesktopFolder: IShellFolder;
  FolderPidl: PItemIdList;
begin
  ClearEnumFolderRec(F, False, False);
  SHGetDesktopFolder(DesktopFolder);
  FolderPidl := PathToPidl(PathAddSeparator(Folder), DesktopFolder);
  try
    DesktopFolder.BindToObject(FolderPidl, nil, IID_IShellFolder, Pointer(F.Folder));
    F.Folder.EnumObjects(0, EnumFolderFlagsToCardinal(Flags), F.EnumIdList);
    Result := SHEnumFolderNext(F);
    if not Result then
      SHEnumFolderClose(F);
  finally
    PidlFree(FolderPidl);
  end;
end;

//------------------------------------------------------------------------------

function GetSpecialFolderLocation(const Folder: Integer): string;
var
  FolderPidl: PItemIdList;
begin
  if Succeeded(SHGetSpecialFolderLocation(0, Folder, FolderPidl)) then
  begin
    Result := PidlToPath(FolderPidl);
    PidlFree(FolderPidl);
  end
  else
    Result := '';
end;

//------------------------------------------------------------------------------

function DisplayPropDialog(const Handle: HWND; const FileName: string): Boolean;
var
  Info: TShellExecuteInfo;
begin
  FillChar(Info, SizeOf(Info), #0);
  with Info do
  begin
    cbSize := SizeOf(Info);
    lpFile := PChar(FileName);
    nShow := SW_SHOW;
    fMask := SEE_MASK_INVOKEIDLIST;
    Wnd := Handle;
    lpVerb := cVerbProperties;
  end;
  Result := ShellExecuteEx(@Info);
end;

//------------------------------------------------------------------------------

function DisplayPropDialog(const Handle: HWND; const Item: PItemIdList): Boolean;
var
  Info: TShellExecuteInfo;
begin
  FillChar(Info, SizeOf(Info), #0);
  with Info do
  begin
    cbSize := SizeOf(Info);
    nShow := SW_SHOW;
    lpIDList := Item;
    fMask := SEE_MASK_INVOKEIDLIST or SEE_MASK_IDLIST;
    Wnd := Handle;
    lpVerb := cVerbProperties;
  end;
  Result := ShellExecuteEx(@Info);
end;

//------------------------------------------------------------------------------

// Window procedure for the callback window created by DisplayContextMenu.
// It simply forwards messages to the folder. If you don't do this then the
// system created submenu's will be empty (except for 1 stub item!)
// note: storing the IContextMenu2 pointer in the window's user data was
// 'inspired' by (read: copied from) code by Brad Stowers.

function MenuCallback(Wnd: HWND; Msg: UINT; wParam: WPARAM;
  lParam: LPARAM): LRESULT; stdcall;
var
  ContextMenu2: IContextMenu2;
begin
  case Msg of
    WM_CREATE:
      begin
        ContextMenu2 := IContextMenu2(PCreateStruct(lParam).lpCreateParams);
        SetWindowLong(Wnd, GWL_USERDATA, Longint(ContextMenu2));
        Result := DefWindowProc(Wnd, Msg, wParam, lParam);
      end;
    WM_INITMENUPOPUP:
      begin
        ContextMenu2 := IContextMenu2(GetWindowLong(Wnd, GWL_USERDATA));
        ContextMenu2.HandleMenuMsg(Msg, wParam, lParam);
        Result := 0;
      end;
    WM_DRAWITEM, WM_MEASUREITEM:
      begin
        ContextMenu2 := IContextMenu2(GetWindowLong(Wnd, GWL_USERDATA));
        ContextMenu2.HandleMenuMsg(Msg, wParam, lParam);
        Result := 1;
      end;
  else
    Result := DefWindowProc(Wnd, Msg, wParam, lParam);
  end;
end;

//------------------------------------------------------------------------------

// Helper function for DisplayContextMenu, creates the callback window.

function CreateMenuCallbackWnd(const ContextMenu: IContextMenu2): HWND;
const
  IcmCallbackWnd = 'ICMCALLBACKWND';
var
  WndClass: TWndClass;
begin
  FillChar(WndClass, SizeOf(WndClass), #0);
  WndClass.lpszClassName := PChar(IcmCallbackWnd);
  WndClass.lpfnWndProc := @MenuCallback;
  WndClass.hInstance := HInstance;
  Windows.RegisterClass(WndClass);
  Result := CreateWindow(IcmCallbackWnd, IcmCallbackWnd, WS_POPUPWINDOW, 0,
    0, 0, 0, 0, 0, HInstance, Pointer(ContextMenu));
end;

//------------------------------------------------------------------------------

function DisplayContextMenuPidl(const Handle: HWND; const Folder: IShellFolder;
  Item: PItemIdList; Pos: TPoint): Boolean;
var
  Cmd: Cardinal;
  ContextMenu: IContextMenu;
  ContextMenu2: IContextMenu2;
  Menu: HMENU;
  CommandInfo: TCMInvokeCommandInfo;
  CallbackWindow: HWND;
begin
  Result := False;
  // TODO If Folder = nil then PidlBindToParent ?
  if (Item = nil) or (Folder = nil) then
    Exit;
  Folder.GetUIObjectOf(Handle, 1, Item, IID_IContextMenu, nil,
    Pointer(ContextMenu));
  if ContextMenu <> nil then
  begin
    Menu := CreatePopupMenu;
    if Menu <> 0 then
    begin
      if Succeeded(ContextMenu.QueryContextMenu(Menu, 0, 1, $7FFF, CMF_EXPLORE)) then
      begin
        CallbackWindow := 0;
        if Succeeded(ContextMenu.QueryInterface(IContextMenu2, ContextMenu2)) then
        begin
          CallbackWindow := CreateMenuCallbackWnd(ContextMenu2);
        end;
        ClientToScreen(Handle, Pos);
        Cmd := Cardinal(TrackPopupMenu(Menu, TPM_LEFTALIGN or TPM_LEFTBUTTON or
          TPM_RIGHTBUTTON or TPM_RETURNCMD, Pos.X, Pos.Y, 0, CallbackWindow, nil));
        if Cmd <> 0 then
        begin
          FillChar(