Einzelnen Beitrag anzeigen

CodeX

Registriert seit: 30. Okt 2004
458 Beiträge
 
Delphi 10.3 Rio
 
#1

Explorer-Kontextmenüpunkt unsichtbar ausführen

  Alt 14. Aug 2015, 14:12
Ich möchte gerne einen Menüpunkt aus dem Kontextmenü des Windows Explorers ausführen.
Nach einigem Hin und Her bin ich bei diesem Beitrag gelandet, der eine sehr gute Grundlage dafür bietet. Ich habe den Code etwas besser aufbereitet und nachfolgend eingefügt.

Was mir noch fehlt: Mit dem Code kann ich das gewünschte Kontextmenü anzeigen und manuell auf den Menüpunkt klicken, aber eigentlich möchte ich das ja gar nicht anzeigen. Das gefundene Menü soll unsichtbar bleiben. Stattdessen möchte ich dessen Items durchiterieren und die Aktion eines bestimmten Items ausführen.

Nach einigen Tests bin ich irgendwie ratlos, wie das gehen könnte. Kann mir dabei bitte jemand weiterhelfen?

Delphi-Quellcode:
unit Unit2;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls,
  ComObj, ShlObj, ActiveX;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure WndProc(var Message: TMessage); override;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;
  aContextMenu: IContextMenu;
  aContextMenu2: IContextMenu2;

implementation

{$R *.dfm}

procedure TForm1.WndProc(var Message: TMessage);
begin
  case Message.Msg of
    WM_INITMENUPOPUP,
    WM_DRAWITEM,
    WM_MENUCHAR,
    WM_MEASUREITEM:
      if Assigned(aContextMenu2) then
      begin
        If (aContextMenu2.HandleMenuMsg(Message.Msg, Message.wParam, Message.lParam) <> NOERROR) then
          inherited WndProc(Message)
        else
          Message.Result := 0;
      end
      else
      inherited WndProc(Message);
  else
    inherited WndProc(Message);
  end;
end;

function SlashDirName(ADir: String): String;
var
  s: String;
  bRootDir: Boolean;
begin
  if ADir<>'then
  begin
    s := ADir;
    bRootDir := ((Length(s)=3) and (s[2]=':')) or (s='\');
    if not bRootDir 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
    begin
      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
    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
  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)));


  // Ab hier wird das Kontextmenü zusammengebaut und angezeigt
  // Stattdessen:
  // 1. Menüpunkte iterieren und gewünschten Eintrag erkennen (Text? ID?)
  // 2. Dessen Aktion ausführen

  aPopup := CreatePopUpMenu;
  if aPopup=0 then
    Exit;
  try
    OLECheck(aContextMenu.QueryContextMenu(aPopup, 0, 1, $7FFF, CMF_EXPLORE or CMF_CANRENAME));
    OLECheck(aContextMenu.QueryInterface(IID_IContextMenu2, aContextMenu2)); //To handle submenus.
    try
      aCmd := Integer(TrackPopupMenu(aPopup, TPM_LEFTALIGN or TPM_LEFTBUTTON or TPM_RIGHTBUTTON or TPM_RETURNCMD, X, Y, 0, Handle, nil));
      if aCmd<>0 then
      begin
        FillChar(aCmdInfo, Sizeof(aCmdInfo), 0);
        with aCmdInfo do
        begin
          cbSize := SizeOf(TCMInvokeCommandInfo);
          lpVerb := PAnsiChar(MakeIntResource(aCmd-1));
          nShow := SW_SHOWNORMAL;
        end;
        try
          aContextMenu.InvokeCommand(aCmdInfo);
        except
        end;
      end;
    finally
      aContextMenu2 := nil;
    end;
  finally
    DestroyMenu(aPopup);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ContextMenuForFile('C:\', 100, 100, Application.Handle);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  aContextMenu2 := nil;
end;


end.
Nur Delphi schafft es, einem ein Lächeln zu schenken, wenn man sich beim Schreiben von := vertippt und stattdessen ein :) erscheint.
  Mit Zitat antworten Zitat