jclshell.pas

East make Tray Icon in delphi

  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; 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;
  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(CommandInfo, SizeOf(CommandInfo), #0);
          CommandInfo.cbSize := SizeOf(TCMInvokeCommandInfo);
          CommandInfo.hwnd := Handle;
          CommandInfo.lpVerb := MakeIntResource(Cmd - 1);
          CommandInfo.nShow := SW_SHOWNORMAL;
          Result := Succeeded(ContextMenu.InvokeCommand(CommandInfo));
        end;
        if CallbackWindow <> 0 then
          DestroyWindow(CallbackWindow);
      end;
      DestroyMenu(Menu);
    end;
  end;
end;

function DisplayContextMenu(const Handle: HWND; const FileName: string;
  Pos: TPoint): Boolean;
var
  ItemIdList: PItemIdList;
  Folder: IShellFolder;
begin
  Result := False;
  ItemIdList := PathToPidlBind(FileName, Folder);
  if ItemIdList <> nil then
  begin
    Result := DisplayContextMenuPidl(Handle, Folder, ItemIdList, Pos);
    PidlFree(ItemIdList);
  end;
end;

function OpenFolder(const Path: string; Parent: HWND): Boolean;
var
  Sei: TShellExecuteInfo;
begin
  Result := False;
  if IsDirectory(Path) then
  begin
    FillChar(Sei, SizeOf(Sei), #0);
    with Sei do
    begin
      cbSize := SizeOf(Sei);
      Wnd := Parent;
      lpVerb := cVerbOpen;
      lpFile := PChar(Path);
      nShow := SW_SHOWNORMAL;
    end;
    Result := ShellExecuteEx(@Sei);
  end;
end;

function OpenSpecialFolder(FolderID: Integer; Parent: HWND): Boolean;
var
  Malloc: IMalloc;
  Pidl: PItemIDList;
  Sei: TShellExecuteInfo;
begin
  Result := False;
  if Succeeded(SHGetMalloc(Malloc)) and
    Succeeded(SHGetSpecialFolderLocation(Parent, FolderID, Pidl)) then
  begin
    FillChar(Sei, SizeOf(Sei), #0);
    with Sei do
    begin
      cbSize := SizeOf(Sei);
      Wnd := Parent;
      fMask := SEE_MASK_INVOKEIDLIST;
      lpVerb := cVerbOpen;
      lpIDList := Pidl;
      nShow := SW_SHOWNORMAL;
      if PidlToPath(Pidl) = '' then
      begin
        fMask := SEE_MASK_INVOKEIDLIST;
        lpIDList := Pidl;
      end
      else
        lpFile := PChar(PidlToPath(Pidl));
    end;
    Result := ShellExecuteEx(@Sei);
    Malloc.Free(Pidl);
  end;
end;

//=== Memory Management ======================================================

function SHAllocMem(out P: Pointer; Count: Integer): Boolean;
var
  Malloc: IMalloc;
begin
  Result := False;
  P := nil;
  if Succeeded(SHGetMalloc(Malloc)) then
  begin
    P := Malloc.Alloc(Count);
    if P <> nil then
    begin
      FillChar(P^, Count, #0);
      Result := True;
    end;
  end;
end;

function SHFreeMem(var P: Pointer): Boolean;
var
  Malloc: IMalloc;
begin
  Result := False;
  if P <> nil then
  begin
    if Succeeded(SHGetMalloc(Malloc)) and (Malloc.DidAlloc(P) > 0) then
    begin
      Malloc.Free(P);
      P := nil;
      Result := True;
    end;
  end;
end;

function SHGetMem(var P: Pointer; Count: Integer): Boolean;
var
  Malloc: IMalloc;
begin
  Result := False;
  if Succeeded(SHGetMalloc(Malloc)) then
  begin
    P := Malloc.Alloc(Count);
    if P <> nil then
      Result := True;
  end;
end;

function SHReallocMem(var P: Pointer; Count: Integer): Boolean;
var
  Malloc: IMalloc;
begin
  Result := False;
  if Succeeded(SHGetMalloc(Malloc)) then
  begin
    if (P <> nil) and (Malloc.DidAlloc(P) <= 0) then
      Exit;
    P := Malloc.ReAlloc(P, Count);
    Result := (P <> nil) or (Count = 0);
  end;
end;

//=== Paths and PIDLs ========================================================

function DriveToPidlBind(const DriveName: string; out Folder: IShellFolder): PItemIdList;
var
  Attr: ULONG;
  Eaten: ULONG;
  DesktopFolder: IShellFolder;
  Drives: PItemIdList;
  Path: TUnicodePath;
begin
  Result := nil;
  if Succeeded(SHGetDesktopFolder(DesktopFolder)) then
  begin
    if Succeeded(SHGetSpecialFolderLocation(0, CSIDL_DRIVES, Drives)) then
    begin
      if Succeeded(DesktopFolder.BindToObject(Drives, nil, IID_IShellFolder,
        Pointer(Folder))) then
      begin
        MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, PChar(PathAddSeparator(DriveName)), -1, Path, MAX_PATH);
        if Failed(Folder.ParseDisplayName(0, nil, Path, Eaten, Result, Attr)) then
        begin
          Folder := nil;
          // Failure probably means that this is not a drive. However, do not
          // call PathToPidlBind() because it may cause infinite recursion.
        end;
      end;
    end;
    PidlFree(Drives);
  end;
end;

function PathToPidl(const Path: string; Folder: IShellFolder): PItemIdList;
var
  DesktopFolder: IShellFolder;
  CharsParsed, Attr: ULONG;
  WidePath: TUnicodePath;
begin
  Result := nil;
  MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, PChar(Path), -1, WidePath, MAX_PATH);
  if Folder <> nil then
    Folder.ParseDisplayName(0, nil, WidePath, CharsParsed, Result, Attr)
  else