在Delphi中将文件复制到剪贴板

Question

我正在尝试将文件复制到剪贴板.互联网上的所有例子都是一样的.我使用的是http://embarcadero.newsgroups.archived.at/public.delphi.nativeapi/200909/0909212186.html,但它不起作用.

我使用Rad Studio XE,然后传递完整的路径.在模式调试中,我收到一些警告,例如:

Debug Output:
Invalid address specified to RtlSizeHeap( 006E0000, 007196D8 )
Invalid address specified to RtlSizeHeap( 006E0000, 007196D8 )

我不确定我的环境是否相关:Windows 8.1 64位,Rad Studio XE.当我尝试粘贴剪贴板时,没有任何反应.此外,使用监视工具查看剪贴板,此工具显示错误.

代码是:

    procedure TfrmDoc2.CopyFilesToClipboard(FileList: string);
    var
      DropFiles: PDropFiles;
      hGlobal: THandle;
      iLen: Integer;
    begin
      iLen := Length(FileList) + 2;
      FileList := FileList + #0#0;
      hGlobal := GlobalAlloc(GMEM_SHARE or GMEM_MOVEABLE or GMEM_ZEROINIT,
        SizeOf(TDropFiles) + iLen);
      if (hGlobal = 0) then raise Exception.Create('Could not allocate memory.');
      begin
        DropFiles := GlobalLock(hGlobal);
        DropFiles^.pFiles := SizeOf(TDropFiles);
        Move(FileList[1], (PChar(DropFiles) + SizeOf(TDropFiles))^, iLen);
        GlobalUnlock(hGlobal);
        Clipboard.SetAsHandle(CF_HDROP, hGlobal);
      end;
    end;

更新:

对不起,我觉得很蠢.在我的项目中,我使用了无效的代码,有人提出的原始问题,而我在Stackoverflow中使用了Remy的代码,正确的解决方案.我以为我在项目中使用了Remy的代码.所以,现在,使用Remy的代码,一切都很好.抱歉这个错误.

Answer 1

您链接到的论坛帖子包含您问题中的代码,并询问它为什么不起作用.毫不奇怪,代码对你来说不再适用于你.

Remy给出的答案是ANSI和Unicode之间存在不匹配.代码适用于ANSI,但编译器是Unicode.

所以点击Remy的回复并按照说法行事:http://embarcadero.newsgroups.archived.at/public.delphi.nativeapi/200909/0909212187.html

基本上你需要调整代码来解释Unicode Delphi中2字节宽的字符,但我认为没有真正的目的在这里重复Remy的代码.

但是,我会说你可以比这段代码做得更好.这段代码的问题在于它将每个方面都混合成一个完成所有功能的大功能.更重要的是,该函数是GUI中表单的一种方法,它实际上是错误的.您可以重用代码的某些方面,但不能像这样考虑因素.

我将从一个将已知内存块放入剪贴板的函数开始.

procedure ClipboardError;
begin
  raise Exception.Create('Could not complete clipboard operation.');
  // substitute something more specific that Exception in your code
end;

procedure CheckClipboardHandle(Handle: HGLOBAL);
begin
  if Handle=0 then begin
    ClipboardError;
  end;
end;

procedure CheckClipboardPtr(Ptr: Pointer);
begin
  if not Assigned(Ptr) then begin
    ClipboardError;
  end;
end;

procedure PutInClipboard(ClipboardFormat: UINT; Buffer: Pointer; Count: Integer);
var
  Handle: HGLOBAL;
  Ptr: Pointer;
begin
  Clipboard.Open;
  Try
    Handle := GlobalAlloc(GMEM_MOVEABLE, Count);
    Try
      CheckClipboardHandle(Handle);
      Ptr := GlobalLock(Handle);
      CheckClipboardPtr(Ptr);
      Move(Buffer^, Ptr^, Count);
      GlobalUnlock(Handle);
      Clipboard.SetAsHandle(ClipboardFormat, Handle);
    Except
      GlobalFree(Handle);
      raise;
    End;
  Finally
    Clipboard.Close;
  End;
end;

我们还需要能够创建双空终止的字符串列表.像这样:

function DoubleNullTerminatedString(const Values: array of string): string;
var
  Value: string;
begin
  Result := '';
  for Value in Values do
    Result := Result + Value + #0;
  Result := Result + #0;
end;

也许您可能会添加一个接受TStrings实例的重载.

现在我们拥有了所有这些,我们可以集中精力制作CF_HDROP格式所需的结构.

procedure CopyFileNamesToClipboard(const FileNames: array of string);
var
  Size: Integer;
  FileList: string;
  DropFiles: PDropFiles;
begin
  FileList := DoubleNullTerminatedString(FileNames);
  Size := SizeOf(TDropFiles) + ByteLength(FileList);
  DropFiles := AllocMem(Size);
  try
    DropFiles.pFiles := SizeOf(TDropFiles);
    DropFiles.fWide := True;
    Move(Pointer(FileList)^, (PByte(DropFiles) + SizeOf(TDropFiles))^, 
      ByteLength(FileList));
    PutInClipboard(CF_HDROP, DropFiles, Size);
  finally
    FreeMem(DropFiles);
  end;
end;