// Откройте Delphi, выберите в меню New... Dynamic link library
// Скопируйте нижеприведенный текст DLL
// Скомпилируйте проект.
// Теперь нужно зарегистрировать полученную библиотеку.
// Наберите в командной строке regsvr32.exe sendtoweb.dll
// После этого откройте Windows Explorer и вы увидите новый
// пункт меню...

unit Sendtoweb;

// Author C Pringle Cjpsoftware.com

{ Реализация COM объекта расширения оболочки Windows Explorer. Этот
  COM объект способен перенаправлять запросы компоненту TPopupMenu. Компонент
  TPopupMenu должен находиться  на форме MenuComponentForm.
  Вы можете модернизировать код для большей гибкости.

  Компонент TContextMenu регистрируется как  глобальным обработчик
  контекстного меню. Это достигается модификацией ключа реестра
  HKEY_CLASSES_ROOT\*\ShellEx\ContextMenuHandlers.

  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;
    // Необходимо для исключения предупреждения компилятора о неоднозначности
    function IShellExtInit.Initialize = IShellExtInit_Initialize;
  public
    { IShellExtInit }
    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
  // Должен быть инициализирован перед регистрацией 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;

      // Ключ добавлен в реестр.

    end;
  finally
    Reg.CloseKey;
    Reg.Free;
  end;

end; // Код регистрации

procedure TContextMenuFactory.UpdateRegistry(Register: Boolean);
begin
  inherited UpdateRegistry(Register);

  // Регистрация нашего обработчика
  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 }

{ Построение контекстного меню с использованием хэндла существующего меню.
  Если Menu =  nil, мы создаем новый хэндл меню и возвращаем его как результат
  функции. Заметьте, что обработчик не поддерживаетвложенные (рекурсивные)
  меню. }

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;

  // Подготавливаем меню
  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;
  // Ошибка, если  lpdobj = Nil.
  if lpdobj = nil then
  begin
    Result := E_FAIL;
    Exit;
  end;
  Result := lpdobj.GetData(fe, medium);
  if Failed(Result) then
    Exit;
  // Если выбран только один файл, получаем его имя и сохраняем в
  // szFile. иначе - ошибка.
  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;

  // Получаем расширение файла и определяем, есть ли для него
  // зарегистрированный обработчик
//  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;

    // Активизация диалога и подготовка к послке данных в 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
  { Заметьте, что в данном фрагменте мы создаем экземпляр TContextMenuFactory,
  а не TComObjectFactory. }
  TContextMenuFactory.Create(ComServer, TContextMenu, Class_ContextMenu,
    'ContextMenu', 'Send To The Web', ciMultiInstance);

  // Инициализируем список расширений
  GFileExtensions := TStringList.Create;
  // GFileExtensions.Add( 'setup msn' );

finalization
  GFileExtensions.Free;
end.