mimechar.pas

delphi写的mib browser 源码,界面友好!

                inc(n);
                if c='-'
                  then break;
                if (c='=') or (pos(c,TableBase64)<1) then
                  begin
                    dec(n);
                    break;
                  end;
                s:=s+c;
              end;
            if s=''
              then s:='+'
              else s:=DecodeBase64(s);
            result:=result+s;
          end;
    end;
end;

{==============================================================================}
Function UCS2toUTF7 (value:string):string;
var
  s:string;
  b1,b2,b3,b4:byte;
  n,m:integer;
begin
  result:='';
  n:=1;
  while length(value)>=n do
    begin
      readmulti(value,n,2,b1,b2,b3,b4);
      if (b2=0)
        then if char(b1)='+'
          then result:=result+'+-'
          else result:=result+char(b1)
        else
          begin
            s:=char(b2)+char(b1);
            while length(value)>=n do
              begin
                readmulti(value,n,2,b1,b2,b3,b4);
                if b2=0 then
                  begin
                    dec(n,2);
                    break;
                  end;
                s:=s+char(b2)+char(b1);
              end;
            s:=EncodeBase64(s);
            m:=pos('=',s);
            if m>0 then
              s:=copy(s,1,m-1);
            result:=result+'+'+s+'-';
          end;
    end;
end;

{==============================================================================}
{DecodeChar}
Function DecodeChar(value:string;CharFrom:TMimeChar;CharTo:TMimeChar):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];
            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;

{==============================================================================}
{GetCurChar}
Function GetCurCP:TMimeChar;
var
  x:integer;
begin
  x:=getACP;
  result:=CP1252;
  if x=1250 then result:=CP1250;
  if x=1251 then result:=CP1251;
  if x=1253 then result:=CP1253;
  if x=1254 then result:=CP1254;
  if x=1255 then result:=CP1255;
  if x=1256 then result:=CP1256;
  if x=1257 then result:=CP1257;
  if x=1258 then result:=CP1258;
end;

{==============================================================================}
{GetCpfromID}
Function GetCPfromID(value:string):TMimeChar;
begin
  value:=uppercase(value);
  Result:=ISO_8859_1;
  if Pos('ISO-8859-10',value)=1 then
    begin
      Result:=ISO_8859_10;
      exit;
    end;
  if Pos('ISO-8859-2',value)=1 then
    begin
      Result:=ISO_8859_2;
      exit;
    end;
  if Pos('ISO-8859-3',value)=1 then
    begin
      Result:=ISO_8859_3;
      exit;
    end;
  if Pos('ISO-8859-4',value)=1 then
    begin
      Result:=ISO_8859_4;
      exit;
    end;
  if Pos('ISO-8859-5',value)=1 then
    begin
      Result:=ISO_8859_5;
      exit;
    end;
  if Pos('ISO-8859-6',value)=1 then
    begin
      Result:=ISO_8859_6;
      exit;
    end;
  if Pos('ISO-8859-7',value)=1 then
    begin
      Result:=ISO_8859_7;
      exit;
    end;
  if Pos('ISO-8859-8',value)=1 then
    begin
      Result:=ISO_8859_8;
      exit;
    end;
  if Pos('ISO-8859-9',value)=1 then
    begin
      Result:=ISO_8859_9;
      exit;
    end;
  if (Pos('WINDOWS-1250',value)=1) or
     (Pos('X-CP1250',value)=1) then
    begin
      Result:=CP1250;
      exit;
    end;
  if (Pos('WINDOWS-1251',value)=1) or
     (Pos('X-CP1251',value)=1) then
    begin
      Result:=CP1251;
      exit;
    end;
  if (Pos('WINDOWS-1252',value)=1) or
     (Pos('X-CP1252',value)=1) then
    begin
      Result:=CP1252;
      exit;
    end;
  if (Pos('WINDOWS-1253',value)=1) or
     (Pos('X-CP1253',value)=1) then
    begin
      Result:=CP1253;
      exit;
    end;
  if (Pos('WINDOWS-1254',value)=1) or
     (Pos('X-CP1254',value)=1) then
    begin
      Result:=CP1254;
      exit;
    end;
  if (Pos('WINDOWS-1255',value)=1) or
     (Pos('X-CP1255',value)=1) then
    begin
      Result:=CP1255;
      exit;
    end;
  if (Pos('WINDOWS-1256',value)=1) or
     (Pos('X-CP1256',value)=1) then
    begin
      Result:=CP1256;
      exit;
    end;
  if (Pos('WINDOWS-1257',value)=1) or
     (Pos('X-CP1257',value)=1) then
    begin
      Result:=CP1257;
      exit;
    end;
  if (Pos('WINDOWS-1258',value)=1) or
     (Pos('X-CP1258',value)=1) then
    begin
      Result:=CP1258;
      exit;
    end;
  if Pos('KOI8-R',value)=1 then
    begin
      Result:=KOI8_R;
      exit;
    end;
  if Pos('UTF-7',value)=1 then
    begin
      Result:=UTF_7;
      exit;
    end;
  if Pos('UTF-8',value)>0 then
    begin
      Result:=UTF_8;
      exit;
    end;
  if Pos('UCS-4',value)>0 then
    begin
      Result:=UCS_4;
      exit;
    end;
  if Pos('UCS-2',value)>0 then
    begin
      Result:=UCS_2;
      exit;
    end;
  if Pos('UNICODE',value)=1 then
    begin
      Result:=UCS_2;
      exit;
    end;
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';
      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';
      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 NeedEncode(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 IdealCoding(value:string;CharFrom:TMimeChar;CharTo:TSetChar):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:=Decodechar(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;

{==============================================================================}

begin
  exit;
  asm
    db 'Synapse character transcoding library by Lukas Gebauer',0
  end;
end.