Shell Extension para Windows 32-bit e 64-bit com Delphi XE2 | Andreano Lanusse

Com o suporte a compilação para windows 64-bit no Delphi XE2, desenvolvedores passam a poder criar Shell Extensions para Windows 64-bit. Shell Extensions são objetos COM que estendem as capacidades do sistema operacional Windows. Nesta primera parte do artigo explico como criar, compilar para 32-bit e 64-bit e registrar um shell extension. O exemplo a ser utilizado irá adicionar dois menus de contexto ao Windows Explorer, estes novos menus terão como funcionalidade permitir que os usuários façam upload de arquivos para as nuvens Microsoft Azure e Amazon S3. Na segunda parte do artigo irei explicar como fazer o upload de arquivos para o Amazon S3 e Microsoft Azure utilizando o Cloud API.

Criando o CloudUpload Shell Extension

Para criar um shell extension em Delphi o primeiro passo é criar um projeto ActiveX Library e em seguinda criar um Automation Object. O exemplo utilizado neste artigo tem como nome de projeto CloudUpload e o Automation Object se chama TCloudUploadContext. Para integrar menus de contexto ao Windows Explorer a classe TCloudUploadContext terá de implementar as interfaces IShellExtInit e IContextMenu e seus respectivos métodos.

    { IShellExtInit Methods }
    { Initialize the context menu if a files was selected}
    function IShellExtInit.Initialize = ShellExtInitialize;
    function ShellExtInitialize(pidlFolder: PItemIDList; lpdobj: IDataObject;
      hKeyProgID: HKEY): HResult; stdcall;

    { IContextMenu Methods }
    { Initializes the context menu and it decides which items appear in it,
      based on the flags you pass }
    function QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, idCmdLast,
      uFlags: UINT): HResult; stdcall;

    { Execute the command, which will be the upload to Amazon or Azure}
    function InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult; stdcall;
    { Set help string on the Explorer status bar when the menu item is selected }
    function GetCommandString(idCmd: UINT_PTR; uFlags: UINT; pwReserved: PUINT;
      pszName: LPSTR; cchMax: UINT): HResult; stdcall;

O ShellExtInitialize define se o menu de contexto será exibido ou não no Windows Explorer. Neste exemplo o menu de contexto aparece apenas e somente quando um arquivo for selecionado, a partir dai armazenamos o nome do arquivo na variável FFileName.

function TCloudUploadContextMenu.ShellExtInitialize(pidlFolder: PItemIDList;
  lpdobj: IDataObject; hKeyProgID: HKEY): HResult;
var
  DataFormat: TFormatEtc;
  StrgMedium: TStgMedium;
  Buffer: array [0 .. MAX_PATH] of Char;
begin
  Result := E_FAIL;

  { Check if an object was defined }
  if lpdobj = nil then
    Exit;

  { Prepare to get information about the object }
  DataFormat.cfFormat := CF_HDROP;
  DataFormat.ptd := nil;
  DataFormat.dwAspect := DVASPECT_CONTENT;
  DataFormat.lindex := -1;
  DataFormat.tymed := TYMED_HGLOBAL;

  if lpdobj.GetData(DataFormat, StrgMedium) <> S_OK then
    Exit;

  { The implementation now support only one file }
  if DragQueryFile(StrgMedium.hGlobal, $FFFFFFFF, nil, 0) = 1 then
  begin
    SetLength(FFileName, MAX_PATH);
    DragQueryFile(StrgMedium.hGlobal, 0, @Buffer, SizeOf(Buffer));
    FFileName := Buffer;
    Result := NOERROR;
  end
  else
  begin
    // Don't show the Menu if more then one file was selected
    FFileName := EmptyStr;
    Result := E_FAIL;
  end;

  { http://msdn.microsoft.com/en-us/library/ms693491(v=vs.85).aspx }
  ReleaseStgMedium(StrgMedium);

end;

Depois de inicializado o handle do menu de contexto através da interface IShellExiInit, o Windows utilizar a interface IContextMenu para chamar os outros métodos do handle do menu de contexto, neste caso irá chamar QueryContextMenu, GetCommandString e InvokeCommand.

As opções do menu de contexto (Amazon S3, Microsoft Azure) serão criadas através do método QueryContextMenu.

function TCloudUploadContextMenu.QueryContextMenu(Menu: HMENU;
  indexMenu, idCmdFirst, idCmdLast, uFlags: UINT): HResult;
var
  CloudMenuItem: TMenuItemInfo;
  MenuCaption: String;
  SubMenu: HMENU;
  uId: UINT;
begin
  { only adding one menu CloudMenuItem, so generate the result code accordingly }
  Result := MakeResult(SEVERITY_SUCCESS, 0, 3);

  { store the menu CloudMenuItem index }
  FMenuItemIndex := indexMenu;

  { specify what the menu says, depending on where it was spawned }
  if (uFlags = CMF_NORMAL) then // from the desktop
    MenuCaption := 'Send file from Desktop to the Cloud'
  else if (uFlags and CMF_VERBSONLY) = CMF_VERBSONLY then // from a shortcut
    MenuCaption := 'Send file from Shourtcut to the Cloud'
  else if (uFlags and CMF_EXPLORE) = CMF_EXPLORE then // from explorer
    MenuCaption := 'Send file from Explorer to the Cloud'
  else
    { fail for any other value }
    Result := E_FAIL;

  if Result <> E_FAIL then
  begin

    SubMenu := CreatePopupMenu;

    uId := idCmdFirst;
    InsertMenu(SubMenu, AmazonIndex, MF_BYPOSITION, uId, TClouds[AmazonIndex]);

    Inc(uId);
    InsertMenu(SubMenu, AzureIndex, MF_BYPOSITION, uId, TClouds[AzureIndex]);

    FillChar(CloudMenuItem, SizeOf(TMenuItemInfo), #0);
    CloudMenuItem.cbSize := SizeOf(TMenuItemInfo);
    CloudMenuItem.fMask := MIIM_SUBMENU or MIIM_STRING or MIIM_ID;
    CloudMenuItem.fType := MFT_STRING;
    CloudMenuItem.wID := FMenuItemIndex;
    CloudMenuItem.hSubMenu := SubMenu;
    CloudMenuItem.dwTypeData := PWideChar(MenuCaption);
    CloudMenuItem.cch := Length(MenuCaption);

    InsertMenuItem(Menu, indexMenu, True, CloudMenuItem);
  end;
end;

Quando o usuário estiver no Windows Explorer e passar o mouse sobre um dos menus criados, uma mensagem será exibida na barra de status do Windows Explorer, isso acontece devido a implementação do método GetCommandString, o qual retorna a string a ser exibida pelo Windows Explorer.

function TCloudUploadContextMenu.GetCommandString(idCmd: UINT_PTR; uFlags: UINT;
pwReserved: PUINT; pszName: LPSTR; cchMax: UINT): HResult;
begin
  Result := E_INVALIDARG;

  { Set help string on the Explorer status bar when the menu item is selected }
  if (idCmd in [AmazonIndex, AzureIndex]) and (uFlags = GCS_HELPTEXT) then
  begin
    StrLCopy(PWideChar(pszName), PWideChar('Copy the selected file to ' +
      TClouds[idCmd]), cchMax);
    Result := NOERROR;
  end;

end;

Assim que usuário clicar no menu referente a nuvem que deseja enviar o arquivo, o método InvokeCommand será chamado e dará inicio o processo para fazer o upload do arquivo selecionado. Neste ponto já temos o nome do arquivo e com base nos parâmetros lpici podemos identificar o qual dos items de menu o usuário clicou.

function TCloudUploadContextMenu.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult;
var
  Item: Word;
begin
  Result := E_FAIL;

  if HiWord(Integer(lpici.lpVerb)) <> 0 then
    Exit;

  { if the index matches the index for the menu, show the cloud options }
  Item := LoWord(Integer(lpici.lpVerb));

  if Item in [AmazonIndex, AzureIndex] then
  begin
    try
      Upload(lpici.HWND, Item, FFileName);
    except
      on E: Exception do
        MessageBox(lpici.hwnd, PWideChar(E.Message), 'Cloud Upload', MB_ICONERROR);

    end;
    Result := NOERROR;
  end;

end;

Para que o objeto COM seja criado sempre que o CloudUpload é carregado, é necessário criar uma instância da classe factory o qual irá criar uma instância do objeto shell extension. A instância da classe factory será criada na seção initialization conforme o código abaixo, veja que o código original criado pelo Delphi será substituido por este.

initialization
  TCloudUploadObjectFactory.Create(ComServer, TCloudUploadContextMenu, CLASS_CloudUploadContextMenu, ciMultiInstance, tmApartment);
end.

Uma vez que a classe factory será responsável por registrar/desregistrar a DLL, os métodos ApproveShellExtension e UpdateRegistry serão chamados, isso vai acontecer quando você usar o regsvr32.exe.

  { the new class factory }
  TCloudUploadObjectFactory = class(TAutoObjectFactory)
  protected
    procedure ApproveShellExtension(&Register: Boolean; const ClsID: string);
    function GetProgID: string; override;
  public
    procedure UpdateRegistry(Register: Boolean); override;
  end;

{ TCloudUploadObjectFactory }

{ Required to registration for Windows NT/2000 }
procedure TCloudUploadObjectFactory.ApproveShellExtension(&Register: Boolean;
  const ClsID: string);
Const
  WinNTRegKey =
    'SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved';
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;

  try
    Reg.RootKey := HKEY_LOCAL_MACHINE;

    if not Reg.OpenKey(WinNTRegKey, True) then
      Exit;

    { register the extension appropriately }
    if &Register then
      Reg.WriteString(ClsID, Description)
    else
      Reg.DeleteValue(ClsID);
  finally
    Reg.Free;
  end;

end;

function TCloudUploadObjectFactory.GetProgID: string;
begin
  { ProgID not required for shell extensions }
  Result := '';
end;

procedure TCloudUploadObjectFactory.UpdateRegistry(Register: Boolean);
Const
  ContextKey = '*\shellex\ContextMenuHandlers\%s';
begin
  { perform normal registration }
  inherited UpdateRegistry(Register);

  { Registration required for Windows NT/2000 }
  ApproveShellExtension(Register, GUIDToString(ClassID));

  { if this server is being registered, register the required key/values
    to expose it to Explorer }
  if Register then
    CreateRegKey(Format(ContextKey, [ClassName]), '', GUIDToString(ClassID),
      HKEY_CLASSES_ROOT)
  else
    DeleteRegKey(Format(ContextKey, [ClassName]));

end;

Compilar para plataformas 32-bit ou 64-bit

A partir daqui preciamos apenas compilar o projeto, neste exemplo as API’s do Windows e os métodos da RTL são os mesmos para as plataformas 32-bit e 64-bit, assim sendo não precisamos fazer implementações específicas para cada plataforma. Você pode definir para qual plataforma deseja compilar utilizando o Project Manager, o default é 32-bit Windows, use o botão direito do mouse na opção Target Platforms para adicionar 64-bit Windows.

Você não pode registrar dll 32-bit em sistema operacional 64-bit, assim como não pode registrar dll 64-bit em sistema operacional 32-bit. Se você desenvolve, compila e teste seus projeto na sua máquina de desenvolvimento, compile para a plataforma compatível com o sistema operacional em uso.

Registrando o Shell Extension CloudUpload

Primeiro, você tem que executar em modo “Run as Administrator” a aplicação que será utilizada para registrar o shell extension, mesmo que seu usuário tenha direitos de Administrador.

Shell extensions 32-bit pode ser registradas através do IDE, linha de comando (cmd) pode ser usada para registrar 32-bit e 64-bit.

Abaixo os passos para registrar e cancelar o registro através de linha de comando:

– “Run as Administrator” o cmd;

– Registre a extensão utilizando a linha de comando: regsvr32 <DIRETÓRIO ONDE ESTÁ A DLL>CloudUpload.dll

– Para desregistrar a extensão utilize a seguinte linha de comando: regsvr32 <DIRETÓRIO ONDE ESTÁ A DLL >CloudUpload.dll /u

Efetuado o registro da DLL abra o Windows Explorer, selecione um arquivo e utilize o botão direito do mouse, você verá um novo menu “Send file from Explorer to the Cloud”. No screenshot abaixo você pode ver a extensão no Windows 7 64-bit.

Você pode obter o código fonte do exemplo aqui utilizado de duas formas:

Usando o IDE do RAD Studio XE2, no menu File selecione a opção “Open from Version Control” e configure a URL para https://radstudiodemos.svn.sourceforge.net/svnroot/radstudiodemos/branches/RadStudio_XE2/Delphi/CloudAPI/CloudUpload
Atualizando o repositório local de demos do RAD Studio XE2, case você use TortoiseSVN com o botão direito sobre a pasta C:\Users\Public\Documents\RAD Studio\9.0\Samples\Delphi selecione a opção Update;

No próximo artigo irei explicar a parte deste exemplo relacionada ao Cloud API, enquanto isso você pode ir estudando o exemplo completo.