Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 505
  • Last Modified:

Shell Context Menu

I need a source showing me how to make a shell context menu, that is:

- Register extensions for my program to add an item to its right click in windows explorer (regardless of the extension being registered with any program or not), being able to provide it an icon. It must work for either 1 file or a multiple selection
- Same for folders
- Unregister the extension
- Must check if the extension is registered first

If you could provide me a project with the units (pack the files in a zip and send me) it'd great

Thanks
0
bryan7
Asked:
bryan7
  • 3
  • 2
1 Solution
 
D-MasterCommented:
// Open Delphi select dynamic link library
// Copy / paste this into the DLL
// Then compile
// You will have to customize this code. To suite your needs.
// once the dll has been compiled you will now have to register this
// com server.
// Use regsvr32.exe sendtoweb.dll
// now open windows explorer and you will see a new menu item
// which can be accessed by the desktop also..


unit Sendtoweb;

// Author C Pringle Cjpsoftware.com

{ Implementation of the context menu shell extension COM object. This
  COM object is responsible for forwarding requests to its partner
  TPopupMenu component. The TPopupMenu component must reside on the
  MenuComponentForm, and is referred to explicitly in this example.
  You can modify this code to make it more flexible and generic in
  the future.

  The TContextMenu component registers itself as a global context menu
  handler. This is accomplished by adding a key to the
  HKEY_CLASSES_ROOT\*\ShellEx\ContextMenuHandlers key in the registry.

  jfl
}

interface

uses

Classes, ComServ, ComObj, ActiveX, Windows, ShlObj, Interfaces, Menus,
    ShellAPI, SysUtils,registry;

type
  TContextMenuFactory = class( TComObjectFactory )
  public
    procedure UpdateRegistry( Register: Boolean ); override;
  end;

  TContextMenu = class( TComObject, IShellExtInit, IContextMenu )
  private
    FFileName: String;
    function BuildSubMenu( Menu: HMENU; IndexMenu: Integer;
      var IDCmdFirst: Integer ): HMENU;
  protected
    szFile: array[0..MAX_PATH] of Char;
    // Required to disambiguate TComObject.Initialize otherwise a compiler
    // warning will result.
    function IShellExtInit.Initialize = IShellExtInit_Initialize;
  public
    { IShellExtInit members }
    function IShellExtInit_Initialize(pidlFolder: PItemIDList; lpdobj: IDataObject;
      hKeyProgID: HKEY): HResult; stdcall;
    { IContextMenu }
    function QueryContextMenu(Menu: HMENU;
      indexMenu, idCmdFirst, idCmdLast, uFlags: UINT): HResult; stdcall;
    function InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult; stdcall;
    function GetCommandString(idCmd, uType: UINT; pwReserved: PUINT;
      pszName: LPSTR; cchMax: UINT): HResult; stdcall;
  end;

var
  // Must be set prior to instantiation of TContextMenu!
  GFileExtensions: TStringList;

const
  MenuCommandStrings: array[ 0..3 ] of String = (
    '','&STW Web Upload','&STW FTPClient','&STW Setup'
);


implementation

{ TContextMenuFactory }
{ Public }

Function ReadDefaultPAth: String;
var
  path       : String;
  Reg        : TRegistry;
begin

Reg := TRegistry.CReate;
try
With Reg Do
  Begin
      RootKey := HKEY_LOCAL_MACHINE;
      Path := 'SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths';

      If KeyExists(Path) Then
         Begin
         OpenKey(Path+'\sendtoweb.exe',false);
         Result := ReadString(#0);
         closekey;
         End;

     // Key Added to shell ext.

  End;
Finally
Reg.CloseKey;
Reg.Free;
End;

End;// Custom registration code
procedure TContextMenuFactory.UpdateRegistry( Register: Boolean );
begin
  inherited UpdateRegistry( Register );

  // Register our global context menu handler
  if Register then
  begin
    CreateRegKey( '*\ShellEx\ContextMenuHandlers\SendToWeb', '',
      GUIDToString( Class_ContextMenu ) );
    CreateRegKey( 'CLSID\' + GUIDToString( ClassID ) + '\' +
      ComServer.ServerKey, 'ThreadingModel', 'Apartment' );
  end else
  begin
    DeleteRegKey( '*\ShellEx\ContextMenuHandlers\SendToWeb' );
  end;
end;

{ TContextMenu }
{ Private }

{ Build a context menu using the existing Menu handle. If Menu is nil,
  we create a new menu handle and return it in the function's return
  value. Note that this function does not handle nested (recursive)
  menus. This exercise is left to the reader. }
function TContextMenu.BuildSubMenu( Menu: HMENU; IndexMenu: Integer;
  var IDCmdFirst: Integer ): HMENU;
var
  i: Integer;
  menuItemInfo: TMenuItemInfo;
begin
  if Menu = 0 then
    Result := CreateMenu
  else
    Result := Menu;

  // Build the menu items here
  with menuitemInfo do
  begin
    cbSize          := SizeOf( TMenuItemInfo );
    fMask           := MIIM_CHECKMARKS or MIIM_DATA or MIIM_ID or
                        MIIM_STATE or MIIM_SUBMENU or MIIM_TYPE or MIIM_CHECKMARKS ;
    fType           := MFT_STRING;
    fState          := MFS_ENABLED ;
    hSubMenu        := 0;
    hbmpChecked     := 0;
    hbmpUnchecked   := 0;
  end;

  for i := 0 to High( MenuCommandStrings ) do
  begin
   if i = 0 then
      menuitemInfo.fType := MFT_SEPARATOR
      else
      menuiteminfo.ftype := MFT_String;
   if i = 1 then
      menuitemInfo.fstate := MFS_ENABLED OR MFS_DEFAULT
      Else
      menuitemInfo.fstate := MFS_ENABLED;

    menuitemInfo.dwTypeData := PChar(MenuCommandStrings[ i ]);
    menuitemInfo.wID := IDCmdFirst;
    InsertMenuItem( Result, IndexMenu + i, True, menuItemInfo );
    Inc( IDCmdFirst );
  end;
end;

{ IShellExtInit }

function TContextMenu.IShellExtInit_Initialize( pidlFolder: PItemIDList;
  lpdobj: IDataObject; hKeyProgID: HKEY ): HResult;
var
  medium: TStgMedium;
  fe: TFormatEtc;

begin
  with fe do
  begin
    cfFormat := CF_HDROP;
    ptd := Nil;
    dwAspect := DVASPECT_CONTENT;
    lindex := -1;
    tymed := TYMED_HGLOBAL;
  end;
  // Fail the call if lpdobj is Nil.
  if lpdobj = Nil then
  begin
    Result := E_FAIL;
    Exit;
  end;
  // Render the data referenced by the IDataObject pointer to an HGLOBAL
  // storage medium in CF_HDROP format.
  Result := lpdobj.GetData(fe, medium);
  if Failed(Result) then Exit;
  // If only one file is selected, retrieve the file name and store it in
  // szFile. Otherwise fail the call.
  if DragQueryFile(medium.hGlobal, $FFFFFFFF, Nil, 0) = 1 then
  begin
    DragQueryFile(medium.hGlobal, 0, szFile, SizeOf(szFile));
    Result := NOERROR;
  end
  else
    Result := E_FAIL;
  ReleaseStgMedium(medium);
end;

{ IContextMenu }

function TContextMenu.QueryContextMenu( Menu: HMENU;
  indexMenu, idCmdFirst, idCmdLast, uFlags: UINT ): HResult;
var
  extension:      String;
  I: Integer;
  idLastCommand:  Integer;
begin
  Result := E_FAIL;
  idLastCommand := idCmdFirst;

  // Extract the filename extension from the file dropped, and see if we
  // have a handler registered for it
//  extension := UpperCase( ( FFileName ) );

//for i := 0 to GFileExtensions.Count - 1 do
//   if Pos(Lowercase(GFileExtensions[ i ]),lowercase(extension))=0 then
  //  begin
      BuildSubMenu( Menu, indexMenu, idLastCommand );
      // Return value is number of items added to context menu
      Result := idLastCommand - idCmdFirst;
//      Exit;
//    end;
end;

function TContextMenu.InvokeCommand( var lpici:
  TCMInvokeCommandInfo ): HResult;
var
  idCmd: UINT;
begin
  if HIWORD( Integer(lpici.lpVerb) ) <> 0 then
    Result := E_FAIL
  else
  begin
  idCmd := LOWORD( lpici.lpVerb );
  Result := S_OK;

  // Activate the Dialog And prepare to send data to the
  // web

    case idCmd of
      1: Begin
       
        ShellExecute( GetDesktopWindow, nil,Pchar(ExtractFileName(ReadDefaultPath)),
          Pchar('Direct'+'"'+szfile+'"'), nil, SW_SHOW );
           
        End;
      3:Begin
        ShellExecute( GetDesktopWindow, nil,Pchar(ExtractFileName(ReadDefaultPath)),
          Pchar('Path'), nil, SW_SHOW );

        End;
      2:
        ShellExecute( GetDesktopWindow, nil, Pchar(ExtractFileName(ReadDefaultPath)),
          PChar(''), nil, SW_SHOW );
      else
        Result := E_FAIL;
      end;
  end;
end;

function TContextMenu.GetCommandString( idCmd, uType: UINT;
  pwReserved: PUINT; pszName: LPSTR; cchMax: UINT ): HResult;

begin
//  StrCopy( pszName, 'Send To The Web') ;


  Result := S_OK;
end;

initialization
  { Note that we create an instance of TContextMenuFactory here rather
    than TComObjectFactory. This is necessary so that we can add some
    custom registry entries by overriding the UpdateRegistry virtual
    function. }
  TContextMenuFactory.Create( ComServer, TContextMenu, Class_ContextMenu,
    'ContextMenu', 'Send To The Web', ciMultiInstance );

  // Initialize the file extension list
  GFileExtensions := TStringList.Create;
// GFileExtensions.Add( 'setup msn' );


finalization
  GFileExtensions.Free;
   
end.
0
 
bryan7Author Commented:
Do I need to put that in another unit ? Since a new DLL project starts with Library..

Also, I don't seem to have Interfaces unit. I have Delphi 5 and 6. What can I replace it for ?

Thanks
0
 
D-MasterCommented:
you can put it in another unit in the dll....

and for the interfaces unit just erase it..it is a mistake...I'm sorry...

and add these two lines under the var section of the unit...
under these lines......
var
  // Must be set prior to instantiation of TContextMenu!
  GFileExtensions: TStringList;

const
  MenuCommandStrings: array[ 0..3 ] of String = (
    '','&STW Web Upload','&STW FTPClient','&STW Setup'
);

ADD THESE LINES
------------------------------------------------------------------------------------------

  const
  Class_ContextMenu: TGUID = '{A2C45DE1-AEB5-11D6-B120-C3192AD13D41}';

--------------------------------------------------------------------------------------------
0
 
bryan7Author Commented:
I have been busy but I'll try it this week
0
 
bryan7Author Commented:
I get an error trying to register it:

a.dll was loaded, but the DllRegisterServer entry point was not found.
This file can not be registered.
0

Featured Post

VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

  • 3
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now