Скопировать HTML-код в буфер обмена

Code:

function FormatHTMLClipboardHeader(HTMLText: string): string;

const

  CrLf = #13#10;

begin

Result := 'Version:0.9' + CrLf;

  Result := Result + 'StartHTML:-1' + CrLf;

  Result := Result + 'EndHTML:-1' + CrLf;

  Result := Result + 'StartFragment:000081' + CrLf;

  Result := Result + 'EndFragment:°°°°°°' + CrLf;

  Result := Result + HTMLText + CrLf;

  Result := StringReplace(Result, '°°°°°°', Format('%.6d', [Length(Result)]), []);

end;

//The second parameter is optional and is put into the clipboard as CF_HTML.

//Function can be used standalone or in conjunction with the VCL clipboard so long as

//you use the USEVCLCLIPBOARD conditional define

//($define USEVCLCLIPBOARD}

//(and clipboard.open, clipboard.close).

//Code from https://www.lorriman.com

procedure CopyHTMLToClipBoard(const str: string; const htmlStr: string = '');

var

  gMem: HGLOBAL;

  lp: PChar;

  Strings: array[0..1] of string;

  Formats: array[0..1] of UINT;

  i: Integer;

begin

  gMem := 0;

  {$IFNDEF USEVCLCLIPBOARD}

  Win32Check(OpenClipBoard(0));

  {$ENDIF}

  try

    //most descriptive first as per api docs

   Strings[0] := FormatHTMLClipboardHeader(htmlStr);

    Strings[1] := str;

    Formats[0] := RegisterClipboardFormat('HTML Format');

    Formats[1] := CF_TEXT;

    {$IFNDEF USEVCLCLIPBOARD}

    Win32Check(EmptyClipBoard);

    {$ENDIF}

    for i := 0 to High(Strings) do

    begin

      if Strings[i] = '' then Continue;

      //an extra "1" for the null terminator

     gMem := GlobalAlloc(GMEM_DDESHARE + GMEM_MOVEABLE, Length(Strings[i]) + 1);

      {Succeeded, now read the stream contents into the memory the pointer points at}

      try

        Win32Check(gmem <> 0);

        lp := GlobalLock(gMem);

        Win32Check(lp <> nil);

        CopyMemory(lp, PChar(Strings[i]), Length(Strings[i]) + 1);

      finally

        GlobalUnlock(gMem);

      end;

      Win32Check(gmem <> 0);

      SetClipboardData(Formats[i], gMEm);

      Win32Check(gmem <> 0);

      gmem := 0;

    end;

  finally

    {$IFNDEF USEVCLCLIPBOARD}

    Win32Check(CloseClipBoard);

    {$ENDIF}

  end;

end;

// Example:

procedure TForm1.Button1Click(Sender: TObject);

begin

  CopyHTMLToClipBoard('SwissDelphiCenter', 'SwissDelphiCenter');

end;