MultiFile context menu

[olesio]

Hello. Sorry for such a question here but there are many programmers
here and most of them probable know Delphi bett than me. So I found a
code below and it works, but how to modifite it to handle some TStrings
type which can pass to Widnows information which files are sleected, like
Total Commander do. When I select few files. For example a shorctus
placed in "send to" receive more than one file name. Please show me
some example Dephi code. Thanks and sorry for my bad english.

Code: Select all

]uses ShlObj, ComObj;

function SlashDirName(ADir: String): String;
var
  S: String;
  RootDir: Boolean;
begin
  if ADir <> '' then
  begin
    S := ADir;
    RootDir := ((Length(S) = 3) and (S[2] = ':')) or (S = '\');
    if not RootDir then
      if S[Length(S)] <> '\' then S := S + '\';
    Result := S;
  end;
end;

function SHGetIDListFromPath(Path: TFileName;
  var ShellFolder: IShellFolder): PItemIDList;
var
  TempPath, NextDir: TFileName;
  SlashPos: Integer;
  Folder, subFolder: IShellFolder;
  PIDL, PIDLbase: PItemIDList;
  ParseStruct: TStrRet;
  ParseNAme: String;
  EList: IEnumIDList;
  DidGet: Cardinal;
  ScanParam: Integer;
begin
  SHGetDesktopFolder(Folder);
  SHGetSpecialFolderLocation(0, CSIDL_DRIVES, PIDLbase);
  OLECheck(Folder.BindToObject(PIDLbase,
    nil, IID_IShellFolder, Pointer(SubFolder)));
  TempPath := Path;
  NextDir := '';
  while Length(TempPath) > 0 do
  begin   
    SlashPos := Pos('\', TempPath);
    if SlashPos > 0 then
    begin
      if Pos(':', TempPath) > 0 then NextDir:=Copy(TempPath, 1, 3)
        else NextDir := SlashDirName(NextDir) +
          Copy(TempPath, 1, SlashPos - 1);
      TempPath := Copy(TempPath, SlashPos + 1, Length(TempPath));
    end else
    begin   
      if NextDir = '' then NextDir := TempPath
        else NextDir := SlashDirName(NextDir) + TempPath;
      TempPath := '';
    end;   
    PIDL := PidlBase;
    ScanParam := SHCONTF_FOLDERS or SHCONTF_INCLUDEHIDDEN;
    if (NextDir = Path) and (not DirectoryExists(Path)) then
      ScanParam := ScanParam or SHCONTF_NONFOLDERS;
    if S_OK = SubFolder.EnumObjects(0, ScanParam, EList) then
    while S_OK = EList.Next(1, pidl, DidGet) do
    begin
      OLECheck(SubFolder.GetDisplayNameOf(PIDL,
        SHGDN_FORPARSING, ParseStruct));
      case ParseStruct.uType of   
        STRRET_CSTR: ParseName := ParseStruct.cStr;
        STRRET_WSTR: ParseName := WideCharToString(ParseStruct.pOleStr);
        STRRET_OFFSET: Parsename := PChar(DWORD(Pidl) + ParseStruct.uOffset);
      end;
      if UpperCase(Parsename) = UpperCase(NextDir) then Break;
    end else
    begin
      Folder := nil;
      Result := nil;
      Exit;   
    end;
    if DidGet = 0 then
    begin
      Folder := nil;
      Result := nil;
      Exit;
    end;
    PIDLBase := PIDL;
    Folder := subFolder;
    if not FileExists(NextDir) then
      OLECheck(Folder.BindToObject(Pidl,
        nil, IID_IShellFolder, Pointer(SubFolder)));
  end;   
  ShellFolder := Folder;
  if ShellFolder = nil then Result := nil else Result := PIDL;
end;

procedure ContextMenuForFile(FileName: TFileName;
  X, Y: Integer; Handle: HWND);
var   
  aContextMenu: IContextMenu;   
  aPrgOut: Pointer;
  aPopup: HMENU;   
  aCmd: Integer;   
  aCmdInfo: TCMInvokeCommandInfo;
  PIDL: PItemIDList;   
  ShellFolder: IShellFolder;   
begin
  PIDL := SHGetIDListFromPath(FileName, ShellFolder);
  if not Assigned(PIDL) then Exit;
  aPrgOut := nil;
  OLECheck(ShellFolder.GetUIObjectOf(0, 1, PIDL,
    IID_IContextMenu, aPrgOut, Pointer(aContextMenu)));
  aPopup := CreatePopUpMenu;
  if aPopup = 0 then Exit;
  try
    OLECheck(aContextMenu.QueryContextMenu(aPopup, 0, 1, $7FFF, CMF_NORMAL));
    aCmd := Integer(TrackPopupMenuEx(aPopup,
      TPM_LEFTALIGN or TPM_RETURNCMD or TPM_RIGHTBUTTON or TPM_HORIZONTAL
      or TPM_VERTICAL, X, Y, Handle, nil));
    if aCmd <> 0 then
    begin
      FillChar(aCmdInfo, Sizeof(aCmdInfo), 0);
      with aCmdInfo do
      begin   
        cbSize := SizeOf(TCMInvokeCommandInfo);
        lpVerb := MakeIntResource(aCmd - 1);
        nShow := SW_SHOWNORMAL;
      end;
      try
        aContextMenu.InvokeCommand(aCmdInfo);
      except end;
    end;
  finally
    DestroyMenu(aPopup);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  P: TPoint;
begin
  GetCursorPos(P);
  ContextMenuForFile('C:\Windows\Notepad.exe', P.X, P.Y, Form1.Handle);
end;

[ghisler(Author)]

If all files are in the same folder, you need to get the PIDL for each of these files via SHGetIDListFromPath, put them all in an array of PIDL, and pass that to GetUIObjectOf with the number of files as one parameter.

If they are in different folders, you need to get the ShellFolder object for the Desktop, and pass the complete PIDLs (not relative to a folder, use ParseDisplayName).

[olesio]

Thank you for answer, but I still have a problem. I have all files in one
directory and I try code blow. And for one file is everything ok, but wken
I add thee path and filename of three mp3 I got all files into WinAmp but
Acess Violation shows up when menu is closed. Also Propeties generate AV
error. And menu subgroups like Open with and Send to does not have any
shorctus. Please tell me how to fix it and can I use one element array like
PIDL : array[0..0] of PItemIDList; instead dynamic array? Because I seen
a code exeample for showing Propeties tab for multi files at following site
http://www.swissdelphicenter.ch/torry/showcode.php?id=2425 and there
was one element array used. Please tell me what I'm doing wrong. T.I.A.

Code: Select all

procedure ContextMenuForFile(FileName : TFileName;
  X, Y : Integer; Handle : HWND);
var
  aContextMenu : IContextMenu;
  aPrgOut : Pointer;
  aPopup : HMENU;
  aCmd : Integer;
  aCmdInfo : TCMInvokeCommandInfo;
  ShellFolder : IShellFolder;
  I, Cnt : integer;
  PIDL : array of PItemIDList;
begin
  Cnt := Form1.Memo1.Lines.Count;
  SetLength(PIDL, Cnt);
  for I := 0 to Cnt - 1 do
  begin
    PIDL[I] := SHGetIDListFromPath(Form1.Memo1.Lines[I], ShellFolder);
  end;
  for I := 0 to Cnt - 1 do
  begin
    if not Assigned(PIDL[I]) then Exit;
    aPrgOut := nil;
    OLECheck(ShellFolder.GetUIObjectOf(0, Cnt, PIDL[I],
      IID_IContextMenu, aPrgOut, Pointer(aContextMenu)));
    aPopup := CreatePopUpMenu;
    if aPopup = 0 then Exit;
    try
      OLECheck(aContextMenu.QueryContextMenu(aPopup, 0, Cnt, $7FFF, CMF_NORMAL));
      aCmd := Integer(TrackPopupMenuEx(aPopup,
        TPM_LEFTALIGN or TPM_RETURNCMD or TPM_RIGHTBUTTON or TPM_HORIZONTAL
        or TPM_VERTICAL, X, Y, Handle, nil));
      if aCmd <> 0 then
      begin
        FillChar(aCmdInfo, Sizeof(aCmdInfo), 0);
        with aCmdInfo do
        begin
          cbSize := SizeOf(TCMInvokeCommandInfo);
          lpVerb := MakeIntResource(aCmd - 1);
          nShow := SW_SHOWNORMAL;
        end;
        try
          aContextMenu.InvokeCommand(aCmdInfo);
        except end;
      end;
    finally
      DestroyMenu(aPopup);
    end;
  end;
end;

[ghisler(Author)]

That doesn't look right, try something like this instead:

Code: Select all

procedure ContextMenuForFile(FileName : TFileName;
  X, Y : Integer; Handle : HWND);
var
  aContextMenu : IContextMenu;
  aPrgOut : Pointer;
  aPopup : HMENU;
  aCmd : Integer;
  aCmdInfo : TCMInvokeCommandInfo;
  ShellFolder : IShellFolder;
  I, Cnt : integer;
  PIDL : array of PItemIDList;
begin
  Cnt := Form1.Memo1.Lines.Count;
  SetLength(PIDL, Cnt);
  for I := 0 to Cnt - 1 do
  begin
    PIDL[I] := SHGetIDListFromPath(Form1.Memo1.Lines[I], ShellFolder);
    if I<Cnt - 1 then
      ShellFolder.Release;
  end;
  for I := 0 to Cnt - 1 do
    if not Assigned(PIDL[I]) then Exit;  {Here we would need to free data...}

    aPrgOut := nil;
    OLECheck(ShellFolder.GetUIObjectOf(0, Cnt, PIDL[I],
      IID_IContextMenu, aPrgOut, Pointer(aContextMenu)));
    aPopup := CreatePopUpMenu;
    if aPopup = 0 then Exit;
    try
      OLECheck(aContextMenu.QueryContextMenu(aPopup, 0, 1, $7FFF, CMF_NORMAL));
      aCmd := Integer(TrackPopupMenuEx(aPopup,
        TPM_LEFTALIGN or TPM_RETURNCMD or TPM_RIGHTBUTTON or TPM_HORIZONTAL
        or TPM_VERTICAL, X, Y, Handle, nil));
      if aCmd <> 0 then
      begin
        FillChar(aCmdInfo, Sizeof(aCmdInfo), 0);
        with aCmdInfo do
        begin
          cbSize := SizeOf(TCMInvokeCommandInfo);
          lpVerb := MakeIntResource(aCmd - 1);
          nShow := SW_SHOWNORMAL;
        end;
        try
          aContextMenu.InvokeCommand(aCmdInfo);
        except end;
      end;
    finally
      DestroyMenu(aPopup);
    end;
end; 

[olesio]

Thanks for answer. But I still have problem. AV error popup and debugger
stop at line following line. When I make lines with ShellFolder._Release; as
comment menu popups - but when I choose some option from menu still get
AV error. Any other Idea? This is the line in your code, which stop debugger:

Code: Select all

    PIDL[I] := SHGetIDListFromPath(Form1.Memo1.Lines[I], ShellFolder);

[ghisler(Author)]

Hmm, I cannot see any error - maybe there is an empty line at the end of the memo1, or one of the file names is invalid? SHGetIDListFromPath will return NIL then.

[olesio]

There is no empty line at end of memo or invalid filenames. Any other idea how to get this code work under Delphi 7 Personal without AV error?