[教程]为 Delphi 剪贴板加入 CF_HTML 数据支持

嗯，直接上代码，需要引用 QDAC 的 QString 单元，不支持太老版本的 Delphi，使用古董版的 Delphi 的请自己改写下：

uses clipbrd, qstring;
type
  THTMLClipboardFormatData = class helper for TClipboard
  private
    class procedure RegisterHtmlFormat;
    function GetAsHtml: String;
    procedure SetAsHtml(const Value: String);
  public
    property AsHtml: String read GetAsHtml write SetAsHtml;
  end;

var
  CF_HTML: WORD = 0;
//此处省略一万字
{ THTMLClipboardFormatData }

function THTMLClipboardFormatData.GetAsHtml: String;
var
  AHandle: THandle;
  pData: PQCharA absolute AHandle;
  AText: QStringW;
  p: PWideChar;
begin
  RegisterHtmlFormat;
  if Clipboard.HasFormat(CF_HTML) then
  begin
    AHandle := Clipboard.GetAsHandle(CF_HTML);
    try
      AText := Utf8Decode(pData, -1);
      p := PWideChar(AText);
      while (p^ <> '<') and (p^ <> #0) do
        SkipLineW(p);
      Result := p;
    finally
      GlobalUnlock(AHandle);
    end;
  end;
end;

class procedure THTMLClipboardFormatData.RegisterHtmlFormat;
begin
  if CF_HTML = 0 then
    CF_HTML := RegisterClipboardFormat('HTML Format');
end;

procedure THTMLClipboardFormatData.SetAsHtml(const Value: String);
var
  S: QStringA;
  AText: String;
  AHandle: THandle;
begin
  RegisterHtmlFormat;
  S := QString.Utf8Encode(Value);
  AText := Format('Version:0.9'#13#10 + //
    'StartHTML:%08u'#13#10 + //
    'EndHTML:%08u'#13#10 + //
    'StartFragment:%08u'#13#10 + //
    'EndFragment:%08u'#13#10 + //
    '<html><body>'#13#10 + //
    '<!--StartFragment -->'#13#10 + //
    '%s'#13#10 + //
    '<!--EndFragment-->'#13#10 + '</body></html>', [97, 172 + S.Length, 111,
    136 + S.Length, Value]);
  S := QString.Utf8Encode(AText);
  AHandle := GlobalAlloc(GMEM_DDESHARE, S.Length + 1);
  if AHandle <> 0 then
  begin
    try
      Move(PQCharA(S)^, GlobalLock(AHandle)^, S.Length + 1);
    finally
      GlobalUnlock(AHandle);
      Clipboard.SetAsHandle(CF_HTML, AHandle);
    end;
  end;
end;

用法是直接操作 Clipboard.AsHtml 属性就可以了，例如：

Clipboard.AsHtml:='<b>Very good</b>';

【示例】

ClipboardHtmlSupportDemo

运行效果：