synachar.pas

很不错的东东

  end;
end;

{==============================================================================}
function CharsetConversion(Value: string; CharFrom: TMimeChar;
  CharTo: TMimeChar): string;
begin
  Result := CharsetConversionEx(Value, CharFrom, CharTo, Replace_None);
end;

{==============================================================================}
function CharsetConversionEx(Value: string; CharFrom: TMimeChar;
  CharTo: TMimeChar; const TransformTable: array of Word): string;
var
  uni: Word;
  n, m: Integer;
  b: Byte;
  b1, b2, b3, b4: Byte;
  SourceTable, TargetTable: array[128..255] of Word;
  mbf, mbt: Byte;
begin
  GetArray(CharFrom, SourceTable);
  GetArray(CharTo, TargetTable);
  mbf := 1;
  if CharFrom in SetTwo then
    mbf := 2;
  if CharFrom in SetFour then
    mbf := 4;
  mbt := 1;
  if CharTo in SetTwo then
    mbt := 2;
  if CharTo in SetFour then
    mbt := 4;

  if CharFrom = UTF_8 then
    Value := UTF8toUCS4(Value);
  if CharFrom = UTF_7 then
    Value := UTF7toUCS2(Value);
  Result := '';

  n := 1;
  while Length(Value) >= n do
  begin
    ReadMulti(Value, n, mbf, b1, b2, b3, b4);
    if mbf = 1 then
      if b1 > 127 then
      begin
        uni := SourceTable[b1];
        uni := ReplaceUnicode(uni, TransformTable);
        b1 := Lo(uni);
        b2 := Hi(uni);
      end;
    // b1..b4 - Unicode Char
    uni := b2 * 256 + b1;
    if (b3 <> 0) or (b4 <> 0) then
    begin
      b1 := Ord(NotFoundChar);
      b2 := 0;
      b3 := 0;
      b4 := 0;
    end
    else
      if mbt = 1 then
        if uni > 127 then
        begin
          b := Ord(NotFoundChar);
          for m := 128 to 255 do
            if TargetTable[m] = uni then
            begin
              b := m;
              Break;
            end;
          b1 := b;
          b2 := 0;
        end
        else
          b1 := Lo(uni);
    Result := Result + WriteMulti(b1, b2, b3, b4, mbt)
  end;

  if CharTo = UTF_7 then
    Result := UCS2toUTF7(Result);
  if CharTo = UTF_8 then
    Result := UCS4toUTF8(Result);

end;

{==============================================================================}
{$IFDEF LINUX}

function GetCurCP: TMimeChar;
begin
  Result := GetCPFromID(nl_langinfo(_NL_CTYPE_CODESET_NAME));
end;

{$ELSE}

function GetCurCP: TMimeChar;
begin
  case GetACP of
    1250:
      Result := CP1250;
    1251:
      Result := CP1251;
    1253:
      Result := CP1253;
    1254:
      Result := CP1254;
    1255:
      Result := CP1255;
    1256:
      Result := CP1256;
    1257:
      Result := CP1257;
    1258:
      Result := CP1258;
  else
    Result := CP1252;
  end;
end;

{$ENDIF}

{==============================================================================}
function GetCPFromID(Value: string): TMimeChar;
begin
  Value := UpperCase(Value);
  Result := ISO_8859_1;
  if Pos('ISO-8859-10', Value) = 1 then
    Result := ISO_8859_10
  else
  if Pos('ISO-8859-13', Value) = 1 then
    Result := ISO_8859_13
  else
  if Pos('ISO-8859-14', Value) = 1 then
    Result := ISO_8859_14
  else
  if Pos('ISO-8859-15', Value) = 1 then
    Result := ISO_8859_15
  else
  if Pos('ISO-8859-2', Value) = 1 then
    Result := ISO_8859_2
  else
  if Pos('ISO-8859-3', Value) = 1 then
    Result := ISO_8859_3
  else
  if Pos('ISO-8859-4', Value) = 1 then
    Result := ISO_8859_4
  else
  if Pos('ISO-8859-5', Value) = 1 then
    Result := ISO_8859_5
  else
  if Pos('ISO-8859-6', Value) = 1 then
    Result := ISO_8859_6
  else
  if Pos('ISO-8859-7', Value) = 1 then
    Result := ISO_8859_7
  else
  if Pos('ISO-8859-8', Value) = 1 then
    Result := ISO_8859_8
  else
  if Pos('ISO-8859-9', Value) = 1 then
    Result := ISO_8859_9
  else
  if (Pos('WINDOWS-1250', Value) = 1) or (Pos('X-CP1250', Value) = 1) then
    Result := CP1250
  else
  if (Pos('WINDOWS-1251', Value) = 1) or (Pos('X-CP1251', Value) = 1) then
    Result := CP1251
  else
  if (Pos('WINDOWS-1252', Value) = 1) or (Pos('X-CP1252', Value) = 1) then
    Result := CP1252
  else
  if (Pos('WINDOWS-1253', Value) = 1) or (Pos('X-CP1253', Value) = 1) then
    Result := CP1253
  else
  if (Pos('WINDOWS-1254', Value) = 1) or (Pos('X-CP1254', Value) = 1) then
    Result := CP1254
  else
  if (Pos('WINDOWS-1255', Value) = 1) or (Pos('X-CP1255', Value) = 1) then
    Result := CP1255
  else
  if (Pos('WINDOWS-1256', Value) = 1) or (Pos('X-CP1256', Value) = 1) then
    Result := CP1256
  else
  if (Pos('WINDOWS-1257', Value) = 1) or (Pos('X-CP1257', Value) = 1) then
    Result := CP1257
  else
  if (Pos('WINDOWS-1258', Value) = 1) or (Pos('X-CP1258', Value) = 1) then
    Result := CP1258
  else
  if Pos('KOI8-R', Value) = 1 then
    Result := KOI8_R
  else
  if (Pos('KAMENICKY', Value) > 0) or (Pos('895', Value) > 0) then
    Result := CP895
  else
  if (Pos('LATIN-2', Value) > 0) or (Pos('852', Value) > 0) then
    Result := CP852
  else
  if Pos('UTF-7', Value) = 1 then
    Result := UTF_7
  else
  if Pos('UTF-8', Value) > 0 then
    Result := UTF_8
  else
  if Pos('UCS-4', Value) > 0 then
    Result := UCS_4
  else
  if Pos('UCS-2', Value) > 0 then
    Result := UCS_2
  else
  if Pos('UNICODE', Value) = 1 then
    Result := UCS_2
end;

{==============================================================================}
function GetIDFromCP(Value: TMimeChar): string;
begin
  case Value of
    ISO_8859_2:
      Result := 'ISO-8859-2';
    ISO_8859_3:
      Result := 'ISO-8859-3';
    ISO_8859_4:
      Result := 'ISO-8859-4';
    ISO_8859_5:
      Result := 'ISO-8859-5';
    ISO_8859_6:
      Result := 'ISO-8859-6';
    ISO_8859_7:
      Result := 'ISO-8859-7';
    ISO_8859_8:
      Result := 'ISO-8859-8';
    ISO_8859_9:
      Result := 'ISO-8859-9';
    ISO_8859_10:
      Result := 'ISO-8859-10';
    ISO_8859_13:
      Result := 'ISO-8859-13';
    ISO_8859_14:
      Result := 'ISO-8859-14';
    ISO_8859_15:
      Result := 'ISO-8859-15';
    CP1250:
      Result := 'WINDOWS-1250';
    CP1251:
      Result := 'WINDOWS-1251';
    CP1252:
      Result := 'WINDOWS-1252';
    CP1253:
      Result := 'WINDOWS-1253';
    CP1254:
      Result := 'WINDOWS-1254';
    CP1255:
      Result := 'WINDOWS-1255';
    CP1256:
      Result := 'WINDOWS-1256';
    CP1257:
      Result := 'WINDOWS-1257';
    CP1258:
      Result := 'WINDOWS-1258';
    KOI8_R:
      Result := 'KOI8-R';
    CP895:
      Result := 'CP-895';
    CP852:
      Result := 'CP-852';
    UCS_2:
      Result := 'Unicode-1-1-UCS-2';
    UCS_4:
      Result := 'Unicode-1-1-UCS-4';
    UTF_8:
      Result := 'UTF-8';
    UTF_7:
      Result := 'UTF-7';
  else
    Result := 'ISO-8859-1';
  end;
end;

{==============================================================================}
function NeedCharsetConversion(const Value: string): Boolean;
var
  n: Integer;
begin
  Result := False;
  for n := 1 to Length(Value) do
    if Ord(Value[n]) > 127 then
    begin
      Result := True;
      Break;
    end;
end;

{==============================================================================}
function IdealCharsetCoding(const Value: string; CharFrom: TMimeChar;
  CharTo: TMimeSetChar): TMimeChar;
var
  n, m: Integer;
  min, x: Integer;
  s, t: string;
begin
  Result := ISO_8859_1;
  s := '';
  for n := 1 to Length(Value) do
    if Ord(Value[n]) > 127 then
      s := s + Value[n];
  min := 128;
  for n := Ord(Low(TMimeChar)) to Ord(High(TMimeChar)) do
    if TMimeChar(n) in CharTo then
    begin
      t := CharsetConversion(s, CharFrom, TMimeChar(n));
      x := 0;
      for m := 1 to Length(t) do
        if t[m] = NotFoundChar then
          Inc(x);
      if x < min then
      begin
        min := x;
        Result := TMimeChar(n);
        if x = 0 then
          Break;
      end;
    end;
end;

end.