Jak wstawić własne dymki podpowiedzi dla plików w powłoce windows (IQueryInfo)

Nie mogłem sobie tego odpuścić bo jestem maniakiem powłoki windowsowej

Zatem do rzeczy :

Chcemy aby po najechaniu kursorem (zaznaczeniu) na plik w windowsowym explore'rze
pojawiał się dymek z naszym opisem pliku (lub pojawiał się opis w pasku statusu).

Do tego celu najbardziej odpowiednim narzędziem w windows jest interfejs IQueryInfo,
wyglądający tak:

type
  IQueryInfo = interface(IUnknown)
    [SID_IQueryInfo]
    function GetInfoTip(dwFlags: DWORD; var ppwszTip: PWideChar): HResult; stdcall;
    function GetInfoFlags(out pdwFlags: DWORD): HResult; stdcall;
  end;

Do jego działania (MSDN) potrzebny jest również interfejs IPersistFile
razem cały interfejs w delphi będzie wyglądał tak:

TTxtTipView = class(TComObject,IQueryInfo, IPersistFile)
  private
    FFile:string;
  protected
    //IPersistFile
    function IsDirty: HResult; stdcall;
    function Load(pszFileName: POleStr; dwMode: Longint): HResult; stdcall;
    function Save(pszFileName: POleStr; fRemember: BOOL): HResult; stdcall;
    function SaveCompleted(pszFileName: POleStr): HResult; stdcall;
    function GetCurFile(out pszFileName: POleStr): HResult; stdcall;
    function GetClassID(out classID: TCLSID): HResult; stdcall;
    //IQueryInfo
    function GetInfoTip(dwFlags: DWORD; var ppwszTip: PWideChar): HResult; stdcall;
    function GetInfoFlags(out pdwFlags: DWORD): HResult; stdcall;
 public
end;

Na pierwszy rzut oka wygląda to strasznie (ale tak jest z interfejsami nie należy się zrażać!)
nam jednak będzie potrzebna tylko funkcja GetInfoTip oraz Load,
pozostałe otrzymają status niezaimplementowanych co po delphi'emu i OLE będzie oznaczało, że muszą
zwrócić one E_NOTIMPL (w przeciwieństwie do zaimplementowanych,
które zwracają S_OK gdy OK a w w razie niepowodzenia E_FAIL).

UWAGA: To nie oznacza, że pozostałe funkcje są nie potrzebne!
Tylko w tym przypadku chcemy uruchomić interfejs z jak najprostszymi możliwościami !

Obsługa Load należy do bardzo prostych, wygląda ona tak:

function TTxtTipView.Load(pszFileName: POleStr; dwMode: Integer): HResult;
begin
//pobieramy nazwe pliku - aby mozna bylo ja widziec globalnie
  FFile  := pszFileName;
// i zwracamy OK (standardowe komunikaty dla OLE)
  Result := S_OK;
end;

GetInfoTip już jest nieco bardziej złożona

function TTxtTipView.GetInfoTip(dwFlags: DWORD; var ppwszTip: PWideChar): HResult;
var
 pMalloc:IMalloc;
 F:TextFile;
 ToolTipS,FLine:string;
begin

    {$I-}
    AssignFile(F,FFile);
    FileMode := 0;
    Reset(F);
    {$I+}
//Sprawdz czy da sie otworzyc plik, jesli nie to sie wycofaj
    if IOResult <> 0 then
    begin
      result := E_FAIL;
      exit;
    end;

//Pobirze interfejs IMalloc z powloki
    if (  SHGetMalloc ( pMalloc ) = E_FAIL ) then
    begin
//... a jak sie nie uda to zamknij plik i powiadom o bledzie
       CloseFile(F);
       result := E_FAIL;
       exit;
    end;



//czytamy pierwsza linie z pliku ....
    ReadLn(F,FLine);
//oraz jego wielkosc ...
    ToolTipS := Format ('Wielkość pliku : %d',[SizeFile(FFile)]);
//zamykamy plik bo nie bedzie juz potrzebny
    CloseFile(F);

//i jesli linia nie jest pusta to dodajemy ja do naszego "tipa"
    if  Length(FLine) > 0 then
        ToolTipS := ToolTipS+ #10#13 + FLine;

//alokacja pamieci dla powloki systemu tu powinno sie stosowac interfejs
// IMalloc do zarzadzania pamiecia
    ppwszTip := pMalloc.Alloc ( Length(ToolTipS)*SizeOf(WideChar) + 1);

//interfejs juz nam nie bedzie potrzebny mozemy go zwolnic (w poprzednich wersjach delphi .Realease
// - powoduje zmniejszenie licznikow interfejsow w systemie)
    pMalloc._Release();

//zamieniamy ....
    StringToWideChar(ToolTipS,ppwszTip,Length(ToolTipS)*SizeOf(WideChar) + 1);

    result := S_OK;
end;

Tu szczególną uwagę należy zwrócić na interfejs IMalloc, służ on do zarządzania pamięcią
w implementacjach interfejsów powłoki i jest zalecany przez MS do tego.

Może to ograniczać troche korzystanie z innych obiektów delphi, które rezerwują pamięć w "tradycyjny" sposób, jednak
z własnych doświadczeń stosowania innych obiektów,
nie zauważyłem jakiś problemów (wieszanie systemu, trudności z odrejestrowaniem biblioteki etc.).

ostatnia część w plikuTxtTipViewU.pas służy do rejestracji biblioteki w powłoce (np za pomocą popularnego regsvr32)
z tego na co warto zwrócić uwagę to to, że nazwa klucza zawiera w sobie numer CLSID ( 'txtfile\shellex\'+SID_IQueryInfo) interfejsu IQueryInfo
(nie tego który my generujemy wciskajac Ctrl+Shift+G !!).

//*************************************************************
//Czesc programu zwiazana z rejestracja/od_rejestracja naszej
// obslugi interfejsu

type
  TTxtTipViewFactory = class(TComObjectFactory)
  public
    procedure UpdateRegistry(register: Boolean); override;
  end;

procedure TTxtTipViewFactory.UpdateRegistry(register: Boolean);
var
  ClassID: string;
  Buf:array[0..MAX_PATH] of Char;
begin
  if register then begin
    inherited UpdateRegistry(register);

     ClassID := GUIDToString(Class_TxtTipView);
      with TRegistry.Create do
        try
          RootKey := HKEY_CLASSES_ROOT;
          OpenKey('txtfile\shellex\'+SID_IQueryInfo,True);
          WriteString('',ClassID);
          CloseKey;

          OpenKey('CLSID\'+ClassID+'\InprocServer32',True);
          GetModuleFileName(Hinstance,buf,sizeof(buf));
          WriteString('',Buf);
          WriteString('ThreadingModel','Apartment');
          CloseKey;
        finally
          Free;
        end;
//w przypadku gdy mamy doczynienia z systemami NT (teraz juz to prawie standard)        
    if (Win32Platform = VER_PLATFORM_WIN32_NT) then
      with TRegistry.Create do
        try
          RootKey := HKEY_LOCAL_MACHINE;
          OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions', True);
          OpenKey('Approved', True);
          WriteString(ClassID, szDescr);
        finally
          Free;
        end;
  end
  else begin
    with TRegistry.Create do
    try
      RootKey := HKEY_CLASSES_ROOT;
      DeleteKey('CLSID\'+ClassID+'\InprocServer32');
      DeleteKey('txtfile\shellex\'+SID_IQueryInfo);
    finally
          Free;
    end;
    inherited UpdateRegistry(register);
  end;
end;

initialization
  TTxtTipViewFactory.Create(ComServer, TTxtTipView, Class_TxtTipView, '', szDescr, ciMultiInstance, tmApartment);
end.

Na koniec jeszcze warto wspomnieć, że w pliku projektu powinniśmy udostępnić (wyeksportować) funkcje
za pomocą których powłoka windows mogła by się dostać do naszej implementacji interfejsu.
a zatem projekt powinien wyglądać:

library TxtTipView;

uses
  ComServ,
  TxtTipViewU in 'TxtTipViewU.pas';

exports
  DllGetClassObject,
  DllCanUnloadNow,
  DllRegisterServer,
  DllUnregisterServer;

begin
end.

Kończąc przedstawiam rezultat (przed i po rejestracji biblioteki)

Przed rejestracją

Po rejestracji ( z konsoli należy wydać polecenie regsvr32 TxtTipViewU.dll)

oraz źrodła (link)
http://4programmers.net/bin/dobry_src.rar