Copying and pasting a FireMonkey TBitmap – new and improved

Back in October, I posted code for copying and pasting a FireMonkey TBitmap to and from the system clipboard on both OS X and Windows. Recently, I got a comment noting that on a Mac, if an image file is copied using Finder and pasted using my code, the default icon for the file type is pasted – yet surely it ‘should’ be the actual image that gets copied?

To be honest, it never occurred to me that when a file system link is on the clipboard, pasting it may paste the file contents, but I guess from an end user perspective that makes sense. Similarly, I never imagined that one of the things added to the clipboard when a file is copied might be its icon – but sure enough, this is what Finder does.

Playing around with Word, I found it pastes the icon like my original code. However, TextEdit will paste the actual image, assuming the copied file is an image. Looking to tweak my code to do the same, I first thought maybe this functionality would be built-in somehow, but after trying several permutations and still only getting the icon each time, I can only assume TextEdit (or the rather, the memo/rich edit control that it is a demo of) must explicitly check for a file name being on the clipboard, and if there is one, try and load it as an image file first.

Doing exactly that, I came up with this revised implementation of PasteBitmapFromClipboard (objc_getClass, for getting an Objective-C metaclass, is declared in Macapi.ObjCRuntime):

function PasteBitmapFromClipboard(Bitmap: TBitmap): Boolean;
var
  CFStr: CFStringRef;
  Objs: NSArray;
  Data: NSData;
  DataType: NSString;
  FileName: string;
  Pasteboard: NSPasteboard;
  Range: CFRange;
  Stream: TStream;
  URL: NSURL;
begin
  Pasteboard := GeneralPasteboard;
  //try pasting the file contents first
  Objs := Pasteboard.readObjectsForClasses(TNSArray.Wrap(
    TNSArray.OCClass.arrayWithObject(objc_getClass('NSURL'))), nil);
  if (Objs <> nil) and (Objs.count > 0) then
  begin
    URL := TNSURL.Wrap(Objs.objectAtIndex(0));
    if URL.isFileURL then
    begin
      CFStr := (URL.path as ILocalObject).GetObjectID;
      Range.location := 0;
      Range.length := CFStringGetLength(CFStr);
      SetLength(FileName, Range.length);
      CFStringGetCharacters(CFStr, Range, PChar(FileName));
      if TryLoadBitmapFromFile(Bitmap, FileName) then Exit(True);
    end;
  end;
  //look for actual image data
  DataType := Pasteboard.availableTypeFromArray(NSBitmapTypesArray);
  if DataType <> nil then Data := Pasteboard.dataForType(DataType);
  if Data = nil then Exit(False);
  Stream := TUserMemoryStream.Create(Data.bytes, Data.length);
  try
    Bitmap.Clear(0); //needed due to FMX bug - try pasting the same PNG multiple times
    Bitmap.LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
  Result := True;
end;

Here, we first ask the system clipboard (= general pasteboard) to try and construct an NSURL instance from its contents. If it can, then we see whether the NSURL returned is a file system reference, and if it is, extract the file name, before passing it onto a TryLoadBitmapFromFile routine. (As an aside: 3 updates and counting, and still the NSString definitions have not been fixed! I don’t hold much hope for the 4th update either. Anyhow…) TryLoadBitmapFromFile is just a simple wrapper round the FMX bitmap loading code:

function TryLoadBitmapFromFile(Bitmap: TBitmap; const FileName: string): Boolean;
var
  Filter: TBitmapCodec;
begin
  Filter := DefaultBitmapCodecClass.Create;
  try
    Bitmap.Clear(0);
    if Filter.LoadFromFile(FileName, 0.0, Bitmap) then
    begin
      Bitmap.UpdateHandles;
      Bitmap.BitmapChanged;
      Exit(True);
    end;
  finally
    Filter.Free;
  end;
  Result := False;
end;

So, that’s OS X sorted. What about Windows? In concept the solution is quite similar – before looking for a graphic on the clipboard, check for a file name first. However, if we want *exactly* the same behavour as the OS X code, then we need to handle the case of a file name that does not point to an image file, since Explorer, unlike Finder, will not put the icon on the clipboard alongside the file name itself.

Alas, but the Windows API does give the impression of being somewhat… ‘thrown together’ at this point. The traditional way to retrieve a file’s icon is to use SHGetFileInfo, however if you use that alone, you may not be able to retrieve XP-quality icons, let alone Vista-quality ones (Vista extended the ICO format to allow 256×256 PNG entries). Alongside SHGetFileInfo, you therefore need to use an additional API function, namely SHGetImageList.

This function has two issues: in the first instance, XE2’s Winapi.ShellApi.pas manages to misdeclare it (there’s a missing stdcall), and even then, it needs to be loaded by ordinal number when running on Windows XP because MS forgot to export it by name! Nonetheless, the following code was good enough for me. Assuming it’s possible, I’m not sure why you would want to run a FireMonkey application on Windows 2000, but for completeness’ sake, I’ve backfilled the function for it:

const
  IID_IImageList: TGUID = '{46EB5926-582E-4017-9FDF-E8998DAA0950}';
  ImageListTypes: array[Boolean] of Integer = (SHIL_EXTRALARGE, SHIL_JUMBO);

function BackfillSHGetImageList(Flags: Integer; const IID: TGUID;
  var ImageList: HIMAGELIST): HRESULT; stdcall;
var
  Info: TSHFileInfo;
begin
  if IID <> IID_IImageList then Exit(E_NOINTERFACE);
  ImageList := SHGetFileInfo('', 0, Info, SizeOf(Info), SHGFI_SYSICONINDEX);
  if ImageList <> 0 then Exit(S_OK) else Exit(S_UNEXPECTED);
end;

{$J+}
function GetSysImageList(var ImageList: HIMAGELIST; var Width, Height: Integer): Boolean;
const
  LTriedToLoad: Boolean = False;
  LImageImage: HIMAGELIST = 0;
  LWidth: Integer = 0;
  LHeight: Integer = 0;
var
  SHGetImageList: function (Flags: Integer; const IID: TGUID;
    var ImageList: HIMAGELIST): HRESULT; stdcall;
begin
  if not LTriedToLoad then
  begin
    LTriedToLoad := True;
    SHGetImageList := GetProcAddress(GetModuleHandle('shell32.dll'), 'SHGetImageList');
    if @SHGetImageList = nil then
    begin
      SHGetImageList := GetProcAddress(GetModuleHandle('shell32.dll'), PChar(727));
      if @SHGetImageList = nil then SHGetImageList := BackfillSHGetImageList;
    end;
    if SHGetImageList(ImageListTypes[Win32MajorVersion >= 6], IID_IImageList,
      LImageImage) <> 0 then Exit(False);
    ImageList_GetIconSize(LImageImage, LWidth, LHeight);
  end;
  if LImageList = 0 then Exit(False);
  ImageList := LImageImage;
  Width := LWidth;
  Height := LHeight;
  Result := True;
end;

PasteBitmapFromClipboard can then be revised as the following:

function PasteBitmapFromClipboard(Bitmap: TBitmap): Boolean;
var
  FileName: array[0..MAX_PATH] of Char;
  FileInfo: TSHFileInfo;
  Header: TBitmapFileHeader;
  HDropObj, MemObj: HGLOBAL;
  ImageList: HIMAGELIST;
  BitmapInfoPtr: PBitmapInfoHeader;
  Stream: TMemoryStream;
  VclBitmap: Vcl.Graphics.TBitmap;
  Width, Height, Row: Integer;
begin
  MemObj := 0;
  BitmapInfoPtr := nil;
  Stream := nil;
  VclBitmap := nil;
  OpenClipboard(0);
  try
    //is there a file name on the clipboard that points to a graphic?
    HDropObj := GetClipboardData(CF_HDROP);
    if HDropObj <> 0 then
    begin
      DragQueryFile(HDropObj, 0, FileName, Length(FileName));
      if TryLoadBitmapFromFile(Bitmap, FileName) then Exit(True);
    end;
    //go for actual image data next
    MemObj := GetClipboardData(CF_DIB);
    if MemObj <> 0 then
    begin
      BitmapInfoPtr := GlobalLock(MemObj);
      if BitmapInfoPtr = nil then RaiseLastOSError;
      FillChar(Header, SizeOf(Header), 0);
      Header.bfType := $4D42;
      Header.bfSize := SizeOf(Header) + GlobalSize(MemObj);
      Header.bfOffBits := SizeOf(Header) + BitmapInfoPtr.biSize;
      Stream := TMemoryStream.Create;
      Stream.WriteBuffer(Header, SizeOf(Header));
      Stream.WriteBuffer(BitmapInfoPtr^, Header.bfSize - SizeOf(Header));
      Stream.Position := 0;
      Bitmap.LoadFromStream(Stream);
      Exit(True);
    end;
    //if a file name, mimic OS X and get the icon
    if (HDropObj <> 0) and GetSysImageList(ImageList, Width, Height) then
    begin
      SHGetFileInfo(FileName, 0, FileInfo, SizeOf(FileInfo), SHGFI_SYSICONINDEX);
      VclBitmap := Vcl.Graphics.TBitmap.Create;
      VclBitmap.PixelFormat := pf32bit;
      VclBitmap.Canvas.Brush.Color := 0;
      VclBitmap.SetSize(Width, Height);
      ImageList_Draw(ImageList, FileInfo.iIcon, VclBitmap.Canvas.Handle, 0, 0, ILD_NORMAL);
      Bitmap.Clear(0);
      Bitmap.SetSize(Width, Height);
      for Row := 0 to Height - 1 do
        Move(VclBitmap.ScanLine[Row]^, Bitmap.ScanLine[Row]^, Width * 4);
      Bitmap.UpdateHandles;
      Bitmap.BitmapChanged;
      Exit(True);
    end;
    Result := False;
  finally
    if BitmapInfoPtr <> nil then GlobalUnlock(MemObj);
    CloseClipboard;
    Stream.Free;
    VclBitmap.Free;
  end;
end;

After battling with the combination from hell that is the wilder fringes of the Windows API and FireMonkey’s hostility towards providing native API hooks, I gave up and fell back to the good ol’ VCL TBitmap for part of this. Since Vcl.Graphics sits at the base of the Vcl.* unit scope, using it doesn’t bring in anything else of the VCL however.

Anyhow, the full unit is available here. To download the demo project using the IDE, go to File|Open From Version Control…, and enter

http://delphi-foundations.googlecode.com/svn/trunk/XE2 book/13. Native APIs/FMX bitmap copy and paste

for the repository URL.

[Update: this code has been superseded by my FireMonkey TClipboard implementation. See here.]