frxunicodeutils.pas

这个是功能强大的报表软件

{*******************************************************}
{    The Delphi Unicode Controls Project                }
{                                                       }
{      http://home.ccci.org/wolbrink                    }
{                                                       }
{ Copyright (c) 2002, Troy Wolbrink ([e-mail]) }
{                                                       }
{*******************************************************}

unit frxUnicodeUtils;

interface

{$I frx.inc}

uses Windows, Classes, SysUtils
{$IFDEF Delphi10}
  , WideStrings
{$ENDIF};

type
  TWString = record
    WString: WideString;
    Obj: TObject;
  end;
{$IFDEF Delphi10}
  TfrxWideStrings = class(TWideStrings)
  private
    FWideStringList: TList;
    procedure ReadData(Reader: TReader);
{$IFDEF Delphi12}
    procedure ReadDataWOld(Reader: TReader);
{$ENDIF}
    procedure ReadDataW(Reader: TReader);
    procedure WriteDataW(Writer: TWriter);
  protected
    function Get(Index: Integer): WideString; override;
    procedure Put(Index: Integer; const S: WideString); override;
    function GetObject(Index: Integer): TObject; override;
    procedure PutObject(Index: Integer; Value: TObject); override;
    procedure AssignTo(Dest: TPersistent); override;
    procedure DefineProperties(Filer: TFiler); override;
    function GetTextStr: WideString; override;
    procedure SetTextStr(const Value: WideString); override;
    function GetCount: Integer; override;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure Clear; override;
    procedure Delete(Index: Integer); override;
    function Add(const S: WideString): Integer; override;
    procedure AddStrings(Strings: TWideStrings); override;
    function AddObject(const S: WideString; AObject: TObject): Integer; override;
    function IndexOf(const S: WideString): Integer; override;
    procedure Insert(Index: Integer; const S: WideString); override;
    procedure LoadFromFile(const FileName: WideString); override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure LoadFromWStream(Stream: TStream);
    procedure SaveToFile(const FileName: WideString); override;
    procedure SaveToStream(Stream: TStream); override;
    property Objects[Index: Integer]: TObject read GetObject write PutObject;
    property Strings[Index: Integer]: WideString read Get write Put; default;
    property Text: WideString read GetTextStr write SetTextStr;
  end;
{$ELSE}
  TWideStrings = class(TPersistent)
  private
    FWideStringList: TList;
    procedure ReadData(Reader: TReader);
    procedure ReadDataW(Reader: TReader);
    procedure WriteDataW(Writer: TWriter);
  protected
    function Get(Index: Integer): WideString;
    procedure Put(Index: Integer; const S: WideString);
    function GetObject(Index: Integer): TObject;
    procedure PutObject(Index: Integer; Value: TObject);
    procedure AssignTo(Dest: TPersistent); override;
    procedure DefineProperties(Filer: TFiler); override;
    function GetTextStr: WideString;
    procedure SetTextStr(const Value: WideString);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    function Count: Integer;
    procedure Clear;
    procedure Delete(Index: Integer);
    function Add(const S: WideString): Integer;
    procedure AddStrings(Strings: TWideStrings);
    function AddObject(const S: WideString; AObject: TObject): Integer;
    function IndexOf(const S: WideString): Integer;
    procedure Insert(Index: Integer; const S: WideString);
    procedure LoadFromFile(const FileName: WideString);
    procedure LoadFromStream(Stream: TStream);
    procedure LoadFromWStream(Stream: TStream);
    procedure SaveToFile(const FileName: WideString);
    procedure SaveToStream(Stream: TStream);
    property Objects[Index: Integer]: TObject read GetObject write PutObject;
    property Strings[Index: Integer]: WideString read Get write Put; default;
    property Text: WideString read GetTextStr write SetTextStr;
  end;
{$ENDIF}

{$IFNDEF Delphi6}
function Utf8Encode(const WS: WideString): AnsiString;
function UTF8Decode(const S: String): WideString;
function VarToWideStr(const V: Variant): WideString;
{$ENDIF}
function AnsiToUnicode(const s: AnsiString; Charset: UINT; CodePage: Integer = 0): WideString;
function _UnicodeToAnsi(const WS: WideString; Charset: UINT; CodePage: Integer = 0): Ansistring;
function OemToStr(const AnsiStr: AnsiString): AnsiString;
function CharSetToCodePage(ciCharset: DWORD): Cardinal;
function GetLocalByCharSet(Charset: UINT): Cardinal;


implementation

const
  sLineBreak = #13#10;
  WideLineSeparator = WideChar($2028);
  NameValueSeparator = '=';


{$IFNDEF Delphi6}
function Utf8Encode(const WS: WideString): AnsiString;
var
  L: Integer;
  Temp: AnsiString;

  function ToUtf8(Dest: PAnsiChar; MaxDestBytes: Cardinal;
           Source: PWideChar; SourceChars: Cardinal): Cardinal;
  var
    i, count: Cardinal;
    c: Cardinal;
  begin
    Result := 0;
    if Source = nil then Exit;
    count := 0;
    i := 0;
    if Dest <> nil then
    begin
      while (i < SourceChars) and (count < MaxDestBytes) do
      begin
        c := Cardinal(Source[i]);
        Inc(i);
        if c <= $7F then
        begin
          Dest[count] := AnsiChar(Char(c));
          Inc(count);
        end
        else if c > $7FF then
        begin
          if count + 3 > MaxDestBytes then
            break;
          Dest[count] := AnsiChar(Char($E0 or (c shr 12)));
          Dest[count+1] := AnsiChar(Char($80 or ((c shr 6) and $3F)));
          Dest[count+2] := AnsiChar(Char($80 or (c and $3F)));
          Inc(count,3);
        end
        else //  $7F < Source[i] <= $7FF
        begin
          if count + 2 > MaxDestBytes then
            break;
          Dest[count] := AnsiChar(Char($C0 or (c shr 6)));
          Dest[count+1] := AnsiChar(Char($80 or (c and $3F)));
          Inc(count,2);
        end;
      end;
      if count >= MaxDestBytes then count := MaxDestBytes-1;
      Dest[count] := AnsiChar(#0);
    end
    else
    begin
      while i < SourceChars do
      begin
        c := Integer(Source[i]);
        Inc(i);
        if c > $7F then
        begin
          if c > $7FF then
            Inc(count);
          Inc(count);
        end;
        Inc(count);
      end;
    end;
    Result := count+1; 
  end;

begin
  Result := '';
  if WS = '' then Exit;
  SetLength(Temp, Length(WS) * 3);
  L := ToUtf8(PChar(Temp), Length(Temp)+1, PWideChar(WS), Length(WS));
  if L > 0 then
    SetLength(Temp, L-1)
  else
    Temp := '';
  Result := Temp;
end;

function Utf8Decode(const S: String): WideString;
var
  L: Integer;
  Temp: WideString;

  function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal; Source: PChar; SourceBytes: Cardinal): Cardinal;
  var
    i, count: Cardinal;
    c: Byte;
    wc: Cardinal;
  begin
    if Source = nil then
    begin
      Result := 0;
      Exit;
    end;
    Result := Cardinal(-1);
    count := 0;
    i := 0;
    if Dest <> nil then
    begin
      while (i < SourceBytes) and (count < MaxDestChars) do
      begin
        wc := Cardinal(Source[i]);
        Inc(i);
        if (wc and $80) <> 0 then
        begin
          wc := wc and $3F;
          if i > SourceBytes then Exit;           // incomplete multibyte char
          if (wc and $20) <> 0 then
          begin
            c := Byte(Source[i]);
            Inc(i);
            if (c and $C0) <> $80 then  Exit;     // malformed trail byte or out of range char
            if i > SourceBytes then Exit;         // incomplete multibyte char
            wc := (wc shl 6) or (c and $3F);
          end;
          c := Byte(Source[i]);
          Inc(i);
          if (c and $C0) <> $80 then Exit;       // malformed trail byte

          Dest[count] := WideChar((wc shl 6) or (c and $3F));
        end
        else
          Dest[count] := WideChar(wc);
        Inc(count);
      end;
    if count >= MaxDestChars then count := MaxDestChars-1;
    Dest[count] := #0;
    end
    else
    begin
    while (i <= SourceBytes) do
    begin
      c := Byte(Source[i]);
      Inc(i);
      if (c and $80) <> 0 then
      begin
      if (c and $F0) = $F0 then Exit;  // too many bytes for UCS2
      if (c and $40) = 0 then Exit;    // malformed lead byte
      if i > SourceBytes then Exit;         // incomplete multibyte char

      if (Byte(Source[i]) and $C0) <> $80 then Exit;  // malformed trail byte
      Inc(i);
      if i > SourceBytes then Exit;         // incomplete multibyte char
      if ((c and $20) <> 0) and ((Byte(Source[i]) and $C0) <> $80) then Exit; // malformed trail byte
      Inc(i);
      end;
      Inc(count);
    end;
    end;
    Result := count+1;
  end;

begin
  Result := '';
  if S = '' then Exit;
  SetLength(Temp, Length(S));

  L := Utf8ToUnicode(PWideChar(Temp), Length(Temp)+1, PChar(S), Length(S));
  if L > 0 then
    SetLength(Temp, L-1)
  else
    Temp := '';
  Result := Temp;
end;

function VarToWideStrDef(const V: Variant; const ADefault: WideString): WideString;
begin
  if not VarIsNull(V) then
    Result := V
  else
    Result := ADefault;
end;

function VarToWideStr(const V: Variant): WideString;
begin
  Result := VarToWideStrDef(V, '');
end;
{$ENDIF}

function OemToStr(const AnsiStr: AnsiString): AnsiString;
begin
  SetLength(Result, Length(AnsiStr));
  if Length(Result) > 0 then
    OemToAnsiBuff(PAnsiChar(AnsiStr), PAnsiChar(Result), Length(Result));
end;

{ TWideStrings }
constructor {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.Create;
begin
  FWideStringList := TList.Create;
end;

destructor {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.Destroy;
begin
  Clear;
  FWideStringList.Free;
  inherited;
end;

procedure {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.Clear;
var
  Index: Integer;
  PWStr: ^TWString;
begin
  for Index := 0 to FWideStringList.Count-1 do
  begin
    PWStr := FWideStringList.Items[Index];
    if PWStr <> nil then
      Dispose(PWStr);
  end;
  FWideStringList.Clear;
end;

function {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.Get(Index: Integer): WideString;
var
  PWStr: ^TWString;
begin
  Result := '';
  if ( (Index >= 0) and (Index < FWideStringList.Count) ) then
  begin
    PWStr := FWideStringList.Items[Index];
    if PWStr <> nil then
      Result := PWStr^.WString;
  end;
end;

procedure {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.Put(Index: Integer; const S: WideString);
begin
  Insert(Index, S);
end;

function {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.GetObject(Index: Integer): TObject;
var
  PWStr: ^TWString;
begin
  Result := nil;
  if ( (Index >= 0) and (Index < FWideStringList.Count) ) then
  begin
    PWStr := FWideStringList.Items[Index];
    if PWStr <> nil then
      Result := PWStr^.Obj;
  end;
end;

procedure {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.PutObject(Index: Integer; Value: TObject);
var
  PWStr: ^TWString;
begin
  if ( (Index >= 0) and (Index < FWideStringList.Count) ) then
  begin
    PWStr := FWideStringList.Items[Index];
    if PWStr <> nil then
      PWStr^.Obj := Value;
  end;
end;

function {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.Add(const S: WideString): Integer;
var
  PWStr: ^TWString;
begin
  New(PWStr);
  PWStr^.WString := S;