Clipboard operations in Delphi

Question

Local workstation: Win 7

Terminal Server: Win 2008 Server

Outlook: 2003 running on local workstation.

I'm trying to implement copying and pasting of Outlook messages from local workstation to terminal server.

Using the code below, I am able to copy and paste files from local workstation to server...

TmyMemoryStream = class(TMemoryStream);

...

procedure TmyMemoryStream.LoadFromIStream(AStream : IStream);
var
  iPos : Int64;
  aStreamStat : TStatStg;
  oOLEStream: TOleStream;
begin
  AStream.Seek(0, STREAM_SEEK_SET, iPos);
  AStream.Stat(aStreamStat, STATFLAG_NONAME);
  oOLEStream := TOLEStream.Create(AStream);
  try
    Self.Clear;
    Self.Position := 0;
    Self.CopyFrom( oOLEStream, aStreamStat.cbSize );
    Self.Position := 0;
  finally
    oOLEStream.Free;
  end;
end;

...but when I try to copy and paste an Outlook message, the stream size (aStreamStat.cbSize) is 0. I am able to obtain the message subject (file name), but unable to read the stream content.

What is wrong with my code?

Complete unit code:

unit Unit1;

interface
uses
  dialogs,
  Windows, ComCtrls, ActiveX, ShlObj, ComObj, StdCtrls, AxCtrls,
  SysUtils, Controls, ShellAPI, Classes, Forms;

type

  {****************************************************************************}

  TMyDataObjectHandler = class;

  PFileDescriptorArray = Array of TFileDescriptor;

  {****************************************************************************}

  TMyDataObjectHandler = class(TObject)
  strict private
    CF_FileContents            : UINT;
    CF_FileGroupDescriptorA    : UINT;
    CF_FileGroupDescriptorW    : UINT;
    CF_FileDescriptor          : UINT;
    FDirectory                 : string;
    function  _CanCopyFiles(const ADataObject : IDataObject) : boolean;
    function  _DoCopyFiles(const ADataObject : IDataObject) : HResult;
    //function  _ExtractFileNameWithoutExt(const FileName: string): string;
    function  _CopyFiles(AFileNames: TStringList): HResult;
    procedure _GetFileNames(AGroup: PDropFiles; var AFileNames: TStringList);
    procedure _ProcessAnsiFiles(ADataObject: IDataObject; AGroup: PFileGroupDescriptorA);
    function  _ProcessDropFiles(ADataObject: IDataObject; AGroup: PDropFiles): HResult;
    procedure _ProcessFileContents(ADataObject: IDataObject; Index: UINT; AFileName: string; AFileSize : Cardinal);
    function  _ProcessStorageMedium(ADataObject: IDataObject; AMedium: STGMEDIUM; AFilename: string; AFileSize : Cardinal): HResult;
    function  _ProcessStreamMedium(ADataObject: IDataObject; AMedium: STGMEDIUM; AFileName: String; AFileSize : Cardinal): HResult;
    procedure _ProcessUnicodeFiles(ADataObject: IDataObject; AGroup: PFileGroupDescriptorW );
    function  _CanCopyFile(AFileName: string): boolean;
  public
    constructor Create; reintroduce;
    destructor Destroy; override;
    function  CanCopyFiles(const ADataObject : IDataObject; const ADirectory : string) : boolean;
    procedure CopyFiles(const ADataObject : IDataObject; const ADirectory : string);
  end;

  {****************************************************************************}

  TMyMemoryStream = class( TMemoryStream )
  public
    procedure LoadFromIStream(AStream : IStream; AFileSize : Cardinal);
    function GetIStream : IStream;
  end;

  {****************************************************************************}

implementation

{------------------------------------------------------------------------------}

{ TMyDataObjectHandler }

function TMyDataObjectHandler.CanCopyFiles(const ADataObject : IDataObject; const ADirectory : string): boolean;
begin
  Result := IsDirectoryWriteable( ADirectory);
  if Result then
  begin
    Result := _CanCopyFiles(ADataObject);
  end;
end;

{------------------------------------------------------------------------------}

constructor TMyDataObjectHandler.Create;
begin
  inherited Create;
  CF_FileContents         := $8000 OR RegisterClipboardFormat(CFSTR_FILECONTENTS)     AND $7FFF;
  CF_FileGroupDescriptorA := $8000 OR RegisterClipboardFormat(CFSTR_FILEDESCRIPTORA)  AND $7FFF;
  CF_FileGroupDescriptorW := $8000 OR RegisterClipboardFormat(CFSTR_FILEDESCRIPTORW)  AND $7FFF;
  CF_FileDescriptor       := $8000 OR RegisterClipboardFormat(CFSTR_FILEDESCRIPTOR)   AND $7FFF;
end;

{------------------------------------------------------------------------------}

destructor TMyDataObjectHandler.Destroy;
begin
  //
  inherited;
end;

{------------------------------------------------------------------------------}

procedure TMyDataObjectHandler.CopyFiles(const ADataObject : IDataObject; const ADirectory : string);
begin
  FDirectory := ADirectory;
  _DoCopyFiles(ADataObject);
end;

{------------------------------------------------------------------------------}

function TMyDataObjectHandler._CanCopyFiles(const ADataObject : IDataObject) : boolean;
var
  eFORMATETC : IEnumFORMATETC;
  OLEFormat  : TFormatEtc;
  iFetched   : Integer;
begin
  Result := false;
  if Succeeded(ADataObject.EnumFormatEtc(DATADIR_GET, eFormatETC)) then
  begin
    if Succeeded(eFormatETC.Reset) then
    begin
      while(eFORMATETC.Next(1, OLEFormat, @iFetched) = S_OK) and (not Result) do
      begin
        Result := ( OLEFormat.cfFormat = CF_FileGroupDescriptorW )
                  or
                  ( OLEFormat.cfFormat = CF_FileGroupDescriptorA )
                  or
                  ( OLEFormat.cfFormat = CF_HDROP );
      end;
    end;
  end;
end;

{------------------------------------------------------------------------------}

function  TMyDataObjectHandler._CanCopyFile( AFileName : string ) : boolean;
begin
  Result := not FileExists( ExpandUNCFileName(FDirectory + ExtractFileName(AFileName)) );
end;

{------------------------------------------------------------------------------}

function  TMyDataObjectHandler._CopyFiles(AFileNames : TStringList) : HResult;
var
  i: Integer;
begin
  Result := S_OK;
  i := 0;
  while(i < AFileNames.Count) do
  begin
    if _CanCopyFile(AFileNames[i]) then
    begin
      Copyfile( Application.MainForm.Handle, PChar(AFileNames[i]), PChar(FDirectory + ExtractFileName(AFileNames[i])), false );
    end;
    inc(i);
  end;
end;

{------------------------------------------------------------------------------}

procedure TMyDataObjectHandler._GetFileNames(AGroup: PDropFiles; var AFileNames : TStringList);
var
  sFilename : PAnsiChar;
  s         : string;
begin
  sFilename := PAnsiChar(AGroup) + AGroup^.pFiles;
  while (sFilename^ <> #0) do
  begin
    if (AGroup^.fWide) then
    begin
      s := PWideChar(sFilename);
      Inc(sFilename, (Length(s) + 1) * 2);
    end
    else
    begin
      s := PWideChar(sFilename);
      Inc(sFilename, Length(s) + 1);
    end;
    AFileNames.Add(s);
  end;
end;

{------------------------------------------------------------------------------}

function TMyDataObjectHandler._ProcessDropFiles(ADataObject: IDataObject; AGroup: PDropFiles) : HResult;
var
  sFiles    : TStringList;
begin
  Result := S_OK;
  sFiles := TStringList.Create;
  try
    _GetFileNames( AGroup, sFiles );
    if (sFiles.Count > 0) then
    begin
      Result := _CopyFiles( sFiles );
    end;
  finally
    sFiles.Free;
  end;
end;

{------------------------------------------------------------------------------}

function TMyDataObjectHandler._ProcessStorageMedium(ADataObject: IDataObject; AMedium: STGMEDIUM; AFilename : string; AFileSize : Cardinal) : HResult;
var
  StorageInterface     : IStorage;
  FileStorageInterface : IStorage;
  sGUID                : PGuid;
  iCreateFlags         : integer;
begin
  Result := S_OK;
  if _CanCopyFile(AFileName) then
  begin
    sGUID := nil;
    StorageInterface := IStorage(AMedium.stg);
    iCreateFlags := STGM_CREATE OR STGM_READWRITE OR STGM_SHARE_EXCLUSIVE;
    Result := StgCreateDocfile(PWideChar(ExpandUNCFileName(FDirectory + AFilename)), iCreateFlags, 0, FileStorageInterface);
    if Succeeded(Result) then
    begin
      Result := StorageInterface.CopyTo(0, sGUID, nil, FileStorageInterface);
      if Succeeded(Result) then
      begin
        Result := FileStorageInterface.Commit(0);
      end;
      FileStorageInterface := nil;
    end;
    StorageInterface := nil;
  end;
end;

{------------------------------------------------------------------------------}

function TMyDataObjectHandler._ProcessStreamMedium(ADataObject: IDataObject; AMedium: STGMEDIUM; AFileName : String; AFileSize : Cardinal) : HResult;
var
  Stream : IStream;
  myStream: TMyMemoryStream;
begin
  Result := S_OK;
  if _CanCopyFile(AFileName) then
  begin
    Stream := ISTREAM(AMedium.stm);
    if (Stream <> nil) then
    begin
      myStream := TMyMemoryStream.Create;
      try
        myStream.LoadFromIStream(Stream, AFileSize);
        myStream.SaveToFile(ExpandUNCFileName(FDirectory + AFileName));
      finally
        myStream.Free;
      end;
    end;
  end;
end;

{------------------------------------------------------------------------------}

procedure TMyDataObjectHandler._ProcessFileContents(ADataObject: IDataObject; Index: UINT; AFileName : string; AFileSize : Cardinal);
var
  Fetc: FORMATETC;
  Medium: STGMEDIUM;
begin
  Fetc.cfFormat := CF_FILECONTENTS;
  Fetc.ptd := nil;
  Fetc.dwAspect := DVASPECT_CONTENT;
  Fetc.lindex := Index;
  Fetc.tymed := TYMED_HGLOBAL or TYMED_ISTREAM or TYMED_ISTORAGE;
  if SUCCEEDED(ADataObject.GetData(Fetc, Medium)) then
  begin
    try
      case Medium.tymed of
        TYMED_HGLOBAL  : ;
        TYMED_ISTREAM  : _ProcessStreamMedium(ADataObject, Medium, AFileName, AFileSize);
        TYMED_ISTORAGE : _ProcessStorageMedium(ADataObject, Medium, AFileName, AFileSize);
        else ;
      end;
    finally
      ReleaseStgMedium(Medium);
    end;
  end;
end;

{------------------------------------------------------------------------------}

procedure TMyDataObjectHandler._ProcessAnsiFiles(ADataObject: IDataObject; AGroup: PFileGroupDescriptorA);
var
  I         : UINT;
  sFileName : AnsiString;
  iSize     : Cardinal;
begin
  for I := 0 to AGroup^.cItems-1 do
  begin
    sFileName := AGroup^.fgd[I].cFileName;
    if (AGroup^.fgd[I].dwFlags and FD_FILESIZE) = FD_FILESIZE then
    begin
      iSize := (AGroup^.fgd[I].nFileSizeLow and $7FFFFFFF);
    end
    else
    begin
      iSize := 0;
    end;
    _ProcessFileContents(ADataObject, I, string(sFileName), iSize);
  end;
end;

{------------------------------------------------------------------------------}

procedure TMyDataObjectHandler._ProcessUnicodeFiles(ADataObject : IDataObject;
                                                  AGroup      : PFileGroupDescriptorW);
var
  I: UINT;
  sFileName: WideString;
  iSize: Cardinal;
begin
  for I := 0 to AGroup^.cItems-1 do
  begin
    sFileName := AGroup^.fgd[I].cFileName;
    if (AGroup^.fgd[I].dwFlags and FD_FILESIZE) = FD_FILESIZE then
    begin
      iSize := (AGroup^.fgd[I].nFileSizeLow and $7FFFFFFF);
    end
    else
    begin
      iSize := 0;
    end;
    _ProcessFileContents(ADataObject, I, sFileName, iSize);
  end;
end;


{------------------------------------------------------------------------------}

function TMyDataObjectHandler._DoCopyFiles(const ADataObject : IDataObject) : HResult;
var
  Fetc       : FORMATETC;
  Medium     : STGMEDIUM;
  Enum       : IEnumFORMATETC;
  Group      : Pointer;
begin
  Result := ADataObject.EnumFormatEtc(DATADIR_GET, Enum);
  if FAILED(Result) then
    Exit;
  while (true) do
  begin
    Result := (Enum.Next(1, Fetc, nil));
    if (Result = S_OK) then
    begin
      if (Fetc.cfFormat = CF_FILEGROUPDESCRIPTORA)   or
         (Fetc.cfFormat = CF_FILEGROUPDESCRIPTORW)  or
         (Fetc.cfFormat = CF_HDROP) then
      begin
        Result := ADataObject.GetData(Fetc, Medium);
        if FAILED(Result) then
          Exit;
        try
          if (Medium.tymed = TYMED_HGLOBAL) then
          begin
            Group := GlobalLock(Medium.hGlobal);
            try
              if Fetc.cfFormat = CF_FILEGROUPDESCRIPTORW then
              begin
                _ProcessUnicodeFiles(ADataObject, PFileGroupDescriptorW(Group));
                break;
              end
              else if Fetc.cfFormat = CF_FILEGROUPDESCRIPTORA then
              begin
                _ProcessAnsiFiles(ADataObject, PFileGroupDescriptorA(Group));
                break;
              end
              else if Fetc.cfFormat = CF_HDROP then
              begin
                _ProcessDropFiles(ADataObject, PDropFiles(Group));
                break;
              end;
            finally
              GlobalUnlock(Medium.hGlobal);
            end;
          end;
        finally
          ReleaseStgMedium(Medium);
        end;
      end;
    end
    else
      break;
  end;
end;

{------------------------------------------------------------------------------}

//function TMyDataObjectHandler._ExtractFileNameWithoutExt(const FileName: string): string;
//begin
//  Result := ChangeFileExt(ExtractFileName(FileName), EmptyStr);
//end;

{------------------------------------------------------------------------------}

{ TMyMemoryStream }

function TMyMemoryStream.GetIStream: IStream;
var
  oStreamAdapter : TStreamAdapter;
  tPos           : Int64;
begin
  oStreamAdapter := TStreamAdapter.Create(Self);
  oStreamAdapter.Seek(0, 0, tPos);
  Result := oStreamAdapter as IStream;
end;

procedure TMyMemoryStream.LoadFromIStream(AStream : IStream; AFileSize : Cardinal);
var
  iPos : Int64;
  aStreamStat         : TStatStg;
  oOLEStream: TOleStream;
  HR: Int64;
begin
  oOLEStream := TOLEStream.Create(AStream);
  try
    Self.Clear;
    Self.Position := 0;
    try
      HR := Self.CopyFrom( oOLEStream, 0 );
    except
    on E : Exception do
    begin
      showMessage(E.ClassName + ' ' + E.Message);
    end;
    end;
    Self.Position := 0;
  finally
    oOLEStream.Free;
  end;
end;

end.

Answer 1

The problem is that in case of CF_FILEDESCRIPTORW or CF_FILEDESCRIPTORA Windows provide IStream which does not support Seek function and does not support correct StreamStat.cbSize field. So it is necessary to get stream size from nFileSizeLow and nFileSizeHigh fields of TFileDescriptor record. Also it is impossible to use TStream.CopyFrom(oOLEStream, 0) because in case of zero second argument TStream calls Seek function which is not supported and so you have EOleSysError exception.