IThumbnailCache - Thumbnail ermitteln

[Andreas L.]

Hi,

ich möchte mit dem Interface IThumbnailCache das gecachte Thumbnail für ein Bild ermitteln. Dazu habe ich folgende Funktion geschrieben:

Delphi-Quellcode:

function GetThumbFromCache(AFileName: string; var hBmp: HBITMAP; AMaxSize: Integer = 120): HRESULT;
var
  thumbcache: IThumbnailCache;
  sharedbmp: ISharedBitmap;
  shellitem: IShellItem;
  thumbflags: PWTS_CACHEFLAGS;
  thumbid: PWTS_THUMBNAILID;
  thumbsize: TSize;
begin
  Result := CoCreateInstance(
    CLSID_LocalThumbnailCache,
    nil,
    CLSCTX_INPROC,
    IThumbnailCache,
    thumbcache
  );

  if Succeeded(Result) then
  begin
    Result := SHCreateItemFromParsingName(
      PChar(AFileName),
      nil,
      IShellItem,
      shellitem
    );

    if Succeeded(Result) then
    begin
      Result := thumbcache.GetThumbnail(
        shellitem,
        AMaxSize,
        WTS_EXTRACT,
        sharedbmp,
        nil,
        nil
      );

      if Succeeded(Result) then
      begin
        {sharedbmp.GetSize(thumbsize);
        ShowMessage(IntToStr(thumbsize.cx) + ' - ' + IntToStr(thumbsize.cy)); } // <-- gibt die richtige Größe aus
        Result := sharedbmp.GetSharedBitmap(hBmp);
      end;

      CoUninitialize;
    end;
  end;
end;

Beim Aufruf wird in hBmp ein Handle eingetragen. Das Image zeigt aber nichts an. Weiß jemand was ich falsch mache?

Delphi-Quellcode:

      GetThumbFromCache(OpenDialog1.FileName, hbmp);
      image3.Picture.Bitmap.Handle := hbmp;
      // image3.Refresh, Repaint, etc. hilft auch nichts

[Andreas L.]

Hat denn keiner eine Idee?

[KarstenK]

image3.Picture.Bitmap.Handle := hbmp;

Ich bin nicht sicher ob das reicht, ich verwende für DIB per handle eine extra funktion die aus dem Handle ein richtiges TBitmap macht.

Delphi-Quellcode:

//*****************************************************************************************
// efg, June 2000.  efg's Computer Lab, www.efg2.com/Lab
//
// Contents
//
//      Method 2.  hDIB to TBitmap resulting in bmDIB using MemoryStream (best)
//
// Summary:
//
//      Method 1.  hDIB to TBitmap resulting in bmDDB using StretchDIBits
//      Method 2.  hDIB to TBitmap resulting in bmDIB using MemoryStream
//      Method 3.  pf24bit TBitmap created using L_PaintDC Lead API call
//
// Tests:
//
//      A.  Deer.BMP, 160 by 194, 8 bits/pixel, palette mostly of browns
//
//                   256 color display     true color display (24-bit)
//                   400 MHz Pentium       166 MHz Pentium
//                   ------------------    -----------------
//      Method 1     15 ms always works    12 ms white bar (~10%) 1 of 4 times
//      Method 2      7 ms always works     4 ms always works
//      Method 3      6 ms bad color       21 ms bad color
//
//
//      B.  Balloons.BMP, 768 by 512, 24 bits/pixel, no palette
//
//                   256 color display     true color display (24-bit)
//                   400 MHz Pentium       166 MHz Pentium
//                   ------------------    -----------------
//      Method 1      82 ms bad color      189 ms always works.
//      Method 2      74 ms OK color       261 ms always works
//      Method 3     155 ms bad color      289 ms always works
//
// ============================================================================
// Method 2.  hDIB to TBitmap resulting in bmDIB using MemoryStream.
// Anatomy of a DIB written to stream :
// 1.  Bitmap File Header.  Normally 14 bytes, i.e., SizeOf(TBitmapFileHeader).
// 2.  Bitmap Info Header.  Normally 40 bytes, i.e., SizeOf(TBitmapInfoHeader)
// 3.  Color Table.  Bitmaps with > 256 colors do not have a color table.
// 4.  Bitmap Bits.
//
// Based on 12 July 1998 UseNet post "DIB to TBitmap" by Taine Gilliam in
// borland.public.delphi.vcl.components.using

function hDIBToTBitmap(const hDIB: THandle): TBitmap;

var
  BitCount: INTEGER;
  BitmapFileHeader: TBitmapFileHeader;
  BitmapInfo: pBitmapInfo;
  DIBinMemory: Pointer;
  MemoryStream: TMemoryStream;
  NumberOfColors: INTEGER;
begin
  RESULT := TBitmap.Create;

  DIBinMemory := GlobalLock(hDIB);
  try
    BitmapInfo := DIBInMemory;
    NumberOfColors := BitmapInfo.bmiHeader.biClrUsed;
    BitCount := BitmapInfo.bmiHeader.biBitCount;
    if (NumberOfColors = 0) and (BitCount <= 8) then
      NumberOfColors := 1 shl BitCount;

    with BitmapFileHeader do
      begin
        bfType := $4D42; // 'BM'
        bfReserved1 := 0;
        bfReserved2 := 0;
        bfOffBits := SizeOf(TBitmapFileHeader) +
          SizeOf(TBitmapInfoHeader) +
          NumberOfColors * SizeOf(TRGBQuad);
        bfSize := bfOffBits + BitmapInfo.bmiHeader.biSizeImage;
      end;

    MemoryStream := TMemoryStream.Create;
    try
      MemoryStream.Write(BitmapFileHeader, SizeOf(TBitmapFileHeader));
      MemoryStream.Write(DIBInMemory^,
        BitmapFileHeader.bfSize - SizeOf(TBitmapFileHeader));
      MemoryStream.Position := 0;
      RESULT.LoadFromStream(MemoryStream)
    finally
      MemoryStream.Free
    end

  finally
    GlobalUnlock(hDIB);
    GlobalFree(hDIB)
  end
end {hDIBToTBitmap};

[Andreas L.]

Danke für deine Antwort. Leider bekomme ich eine Access Violation wenn ich hBmp an deine Funktion übergebe.

Zitat:

---------------------------
Benachrichtigung über Debugger-Exception
---------------------------
Im Projekt Project3.exe ist eine Exception der Klasse EAccessViolation mit der Meldung 'Zugriffsverletzung bei Adresse 004DF337 in Modul 'Project3.exe'. Lesen von Adresse 00000020' aufgetreten.
---------------------------
Anhalten Fortsetzen Hilfe
---------------------------

Delphi-Quellcode:

    GetThumbFromCache(OpenDialog1.FileName, hbmp2, 250);
    image3.Picture.Bitmap.Assign(hDIBToTBitmap(hbmp2)); // auch ohne Assign versucht

Bei einer anderen Routine lässt sich das hBmp einfach an Bitmap.Handle zuweisen.

Delphi-Quellcode:

function GetThumb(AFilePath: string; var hBmp: HBITMAP; AMaxSize: LongInt = 120): HRESULT;
var
  fileShellItemImage: IShellItemImageFactory;
  s: TSize;
begin
  Result := CoInitializeEx(
    nil,
    COINIT_APARTMENTTHREADED or COINIT_DISABLE_OLE1DDE
  );

  if Succeeded(Result) then
  begin
    Result := SHCreateItemFromParsingName(
      PChar(AFilePath),
      nil,
      IShellItemImageFactory,
      fileShellItemImage
    );

    if Succeeded(Result) then
    begin
      s.cx := AMaxSize;
      s.cy := AMaxSize;
      Result := fileShellItemImage.GetImage(s, SIIGBF_THUMBNAILONLY, hBmp);
    end;

    CoUninitialize;
  end;
end;

...

    getThumb(opendialog1.filename, hbmp, 250);
    image1.Picture.Bitmap.Handle := hbmp;

[ralfschwalbe]

Hallo,

laut dieser Seite ist der Parameter hBmp ein PHBITMAP, also ein Pointer auf ein HBITMAP...

Bei Dir ist es "nur" HBITMAP.

[Andreas L.]

So sieht die Interface-Deklaration aus:

Delphi-Quellcode:

  {$EXTERNALSYM ISharedBitmap}
  ISharedBitmap = interface(IUnknown)
    ['{091162a4-bc96-411f-aae8-c5122cd03363}']
    function GetSharedBitmap(out phbm: HBITMAP): HRESULT; stdcall;
    function GetSize(out pSize: TSize): HRESULT; stdcall;
    function GetFormat(out pat: WTS_ALPHATYPE): HRESULT; stdcall;
    function InitializeBitmap(hbm: HBITMAP; wtsAT: WTS_ALPHATYPE): HRESULT;
stdcall;
    function Detach(out phbm: HBITMAP): HRESULT; stdcall;
  end;

[ralfschwalbe]

Wo steht die Deklaration? Bei mir im Delphi 2010 gibts die nicht...

Aber ich würde mich bei solchen "speziellen" Interfaces eh lieber auf die Beschreibung von MS verlassen. Versuch es doch einfach mal

[KarstenK]

Hallo Andreas,

kannst Du mal deinen Stand des Test-Projektes mit den entsprechenden units hochladen? Ich würde es mir dann mal genauer anschauen.

Karsten

[ralfschwalbe]

Das Problem ist ein anderes:

Das Handle des Bitmaps ist nach Verlassen der Function GetThumbFromCache ungültig, da die verwendeten Interfaces ungültig sind. Also musst Du, nachdem du das Handle mit GetSharedBitmap bekommen hast, sofort das Bitmap einmal wegkopieren:

Delphi-Quellcode:

Result := sharedbmp.GetSharedBitmap(hBmp);
        if Succeeded(Result) then
        begin
          if Assigned(Bmp) then
          begin
            Bmp.SetSize(thumbsize.cx, thumbsize.cy);
            Bmp.Handle := hBmp;
          end;
        end;

Bmp ist TBitmap und nach dem Bmp.Handle := hBmp auch gültig. Bmp.SaveToFile funktioniert z.B.

Also an dieser Stelle sofort in ein anderes Bitmap kopieren und dieses dann verwenden. Dann funktionierts...

[KarstenK]

Hallo,

so klappt das.

Delphi-Quellcode:

procedure FlipBitmap(Bitmap: Tbitmap);
var
  i, j: integer;
  P1, p2: Pbyte;
  bs: byte;
  BytesPerLine: integer;
begin
  case Bitmap.PixelFormat of
    // pfDevice: ;
    pf1bit:  BytesPerLine := (Bitmap.Width - 7) div 8 +1;  //richtig?
    pf4bit: BytesPerLine :=  (Bitmap.Width - 1) div 2 +1;  //richtig? 
    pf8bit: BytesPerLine := Bitmap.Width;
    pf15bit: BytesPerLine := 2 * Bitmap.Width;
    pf16bit: BytesPerLine := 2 * Bitmap.Width;
    pf24bit: BytesPerLine := 3 * Bitmap.Width;
    pf32bit: BytesPerLine := 4 * Bitmap.Width;
    // pfCustom: ;
  end;

  for I := 0 to Bitmap.Height div 2 - 1 do
    begin
      P1 := Bitmap.ScanLine[i];
      P2 := Bitmap.ScanLine[Bitmap.Height - 1 - i];
      for j := 0 to BytesPerLine - 1 do
        begin
          bs := P1[j];
          P1[j] := P2[j];
          P2[j] := bs;

          inc(p1);
          inc(p2);
        end;
    end;
end;


function GetThumbFromCache1(AFileName: string; AMaxSize: Integer = 120): TBITMAP;
var
  thumbcache: IThumbnailCache;
  sharedbmp: ISharedBitmap;
  shellitem: IShellItem;
  //  thumbflags: PWTS_CACHEFLAGS;
  //  thumbid: PWTS_THUMBNAILID;
  //  thumbsize: TSize;
  hBmp: HBITMAP;
begin
  CoInitialize(nil);
  result := nil;
  try
    if Succeeded(CoCreateInstance(CLSID_LocalThumbnailCache, nil, CLSCTX_INPROC, IThumbnailCache, thumbcache)) then
      if Succeeded(SHCreateItemFromParsingName(PChar(AFileName), nil, IShellItem, shellitem)) then
        if Succeeded(thumbcache.GetThumbnail(shellitem, AMaxSize, WTS_EXTRACT, sharedbmp, nil, nil)) then
          if Succeeded(sharedbmp.GetSharedBitmap(hBmp)) then
            begin
              result := Tbitmap.Create;
              result.Handle := hbmp;
              result.Dormant; //extrem wichtig, sonst stimmen zwar METADATEN, aber das Handle ist kaputt
              //flip , sonst auf dem Kopf
              FlipBitmap(result);
            end;
  finally
    CoUninitialize;
  end;
end;


procedure TForm10.Button1Click(Sender: TObject);
var TB:graphics.Tbitmap;
begin
 if OpenDialog1.execute then
  Try
    TB:= GetThumbFromCache1(OpenDialog1.FileName,120);
    Image1.Picture.Assign(TB);
  finally
    TB.Free;
  end;
end;