[DUG] Copy WideString to the clipboard

Stefan Mueller muellers at orcl-toolbox.com
Mon Sep 10 15:38:14 NZST 2007


Here is a code snippet of the old TNT Widestring library:

 

 

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

{
}

{    Tnt Delphi Unicode Controls
}

{      http://www.tntware.com/delphicontrols/unicode/
}

{        Version: 2.2.3
}

{
}

{    Copyright (c) 2002-2006, Troy Wolbrink (troy.wolbrink at tntware.com)
}

{
}

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

 

unit TntClipBrd;

 

interface

 

uses

  Classes, Windows, Clipbrd;

 

type

  TTntClipboard = class(TClipboard

  private

    function GetAsWideText: WideString;

    procedure SetAsWideText(const Value: WideString);

  public

    property AsWideText: WideString read GetAsWideText write SetAsWideText;

    property AsText: WideString read GetAsWideText write SetAsWideText;

  end;

 

function TntClipboard: TTntClipboard;

 

implementation

 

{ TTntClipboard }

 

function TTntClipboard.GetAsWideText: WideString;

var

  Data: THandle;

begin

  Open;

  Data := GetClipboardData(CF_UNICODETEXT);

  try

    if Data <> 0 then

      Result := PWideChar(GlobalLock(Data))

    else

      Result := '';

  finally

    if Data <> 0 then GlobalUnlock(Data);

    Close;

  end;

  if (Data = 0) or (Result = '') then

    Result := inherited AsText

end;

 

procedure TTntClipboard.SetAsWideText(const Value: WideString);

begin

  Open;

  try

    inherited AsText := Value; {Ensures ANSI compatiblity across platforms.}

    SetBuffer(CF_UNICODETEXT, PWideChar(Value)^, (Length(Value) + 1) *
SizeOf(WideChar));

  finally

    Close;

  end;

end;

 

//------------------------------------------

 

var

  GTntClipboard: TTntClipboard;

 

function TntClipboard: TTntClipboard;

begin

  if GTntClipboard = nil then

    GTntClipboard := TTntClipboard.Create;

  Result := GTntClipboard;

end;

 

initialization

 

finalization

  GTntClipboard.Free;

 

end.

 

 

 

Kind Regards,
Stefan Mueller 



-------------- next part --------------
An HTML attachment was scrubbed...
URL: http://www.adventureeducation.co.nz/pipermail/delphi/attachments/20070910/b2aff170/attachment.html


More information about the Delphi mailing list