strfuncs.pas

木马源程序,供大家研究

  end;

end;

function AnsiToUtf7(value : WideString): AnsiString;

var

  SourceStart, SourceEnd: PWideChar;

  TargetStart, TargetEnd: PAnsiChar;

begin

  if value = '' then

    Result := ''

  else begin

    SetLength(Result, Length(value) * 7); // Assume worst case

    SourceStart := PWideChar(@value[1]);

    SourceEnd := PWideChar(@value[Length(value)]) + 1;

    TargetStart := PAnsiChar(@Result[1]);

    TargetEnd := PAnsiChar(@Result[Length(Result)]) + 1;

    if ConvertUCS2toUTF7(SourceStart, SourceEnd, TargetStart,

      TargetEnd, True, False) <> 0

    then

      raise Exception.Create(SBufferOverflow);

    SetLength(Result, TargetStart - PAnsiChar(@Result[1]));

  end;

end;

function AnsiToUnicode(value : WideString): AnsiString;

begin

  if Length(Value) = 0 then

    Result := ''

  else

    SetString(Result, PAnsiChar(@Value[1]), Length(Value) * SizeOf(WideChar))

end;

function UnicodeToAnsi(value : AnsiString): WideString;

begin

  if Length(Value) = 0 then

    Result := ''

  else

    SetString(Result, PWideChar(@Value[1]), Length(Value) div SizeOf(WideChar))

end;

function DosToUnix(value : string): string;

var

  ch : Char;

  I : Integer;

begin

  for I := 1  To Length(value) Do

  begin

    ch := value[i];

    case ch of

      #$D  : ;

      #$1A :

      begin

        result := result + #$04;

        break;

      End;

      else result := result + ch;

    end

   end;

end;

function UnixToDos(value : string): string;

var

  ch : Char;

  I : Integer;

begin

  for I := 1 To Length(value) Do

  begin

    ch := value[i];

    case ch of

      #$A   : result := result + #$D#$A;

      #$04  :

      begin

        result := result + #$1A;

        Break;

      end;

      else result := result + ch;

    end

  end;

end;

function DecodeMime(value : string): string;

const

  c_strBase64 = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';

  //Base64字符集

var

  StrBin : String;

  nIndex : Integer;

  I : Integer;

Begin

  StrBin := '';

  {查找Base64字符，并转换为二进制}

  for nIndex := 1 To Length(value) Do

  begin

    I := Pos(value[nIndex], c_strBase64);

    If (I > 0) Then {填满6位，满足Base64编码原则}

      StrBin := strBin + Dec2Bin(i - 1, 6)

    {无输入字符时候，使用等号输出（这样的写法应该是错误的，但目前想不出好的写法）}

    else If (value[nIndex] = '=') Then

      StrBin := StrBin + '000000';

  end;

  {转换为8位长的字符}

  for nIndex := 1 To Trunc(Length(strBin) / 8) Do

    result := result + Chr(Bin2Dec(Copy(strBin, (nIndex - 1) * 8 + 1, 8)));

end;

function DecodeQP(value : string): string;

var

  nIndex, nLength : Integer;

Begin

  nIndex := 1;

  nLength := Length(value);

  while (nIndex <= nLength) Do

  begin

    If (value[nIndex] = '=') and (nIndex + 2 <= nLength) And

      (((value[nIndex + 1] >= 'A') and (value[nIndex + 1] <= 'F')) or

      ((value[nIndex + 1] >= '0') and (value[nIndex + 1] <= '9'))) and

      (((value[nIndex + 2] >= 'A') and (value[nIndex + 2] <= 'F')) or

      ((value[nIndex + 2] >= '0') and (value[nIndex + 2] <= '9'))) then

    begin

      result := result + Chr(Hex2Dec(Copy(value, nIndex + 1, 2)));

      Inc(nIndex, 3);

    end

    else Begin

      result := result + value[nIndex];

      Inc(nIndex);

    end;

  end;

end;

function DecodeHZ(value : string): string;

var

  nBeginIndex, nEndIndex : Integer;

  S, S1, StrBin : String;

  nIndex : Integer;

Begin

  result := value;

  {查找编码字串标志}

  nBeginIndex := Pos('~{', result);

  nEndIndex := Pos('~}', result);

  while ((nBeginIndex > 0) And (nBeginIndex < nEndIndex)) do

  begin

    s := copy(result, nBeginIndex + 2, nEndIndex - nBeginIndex - 2);

    S1 := '';

    for nIndex := 1 To Length(s) Do

    begin

      If (ord(S[nIndex]) <= 127) Then

      Begin

        {填满8位，满足HZ编码原则}

        StrBin := Dec2Bin(ord(S[nIndex]), 8);

        {最高位置1}

        StrBin[1] := '1';

        S1 := S1 + Chr(Bin2Dec(StrBin));

      end;

    end;


    {替换原来的编码字串}

    Delete(result, nBeginIndex, nEndIndex - nBeginIndex + 2);

    Insert(s1, result, nBeginIndex);

    {查找编码字串标志}

    nBeginIndex := Pos('~{', result);

    nEndIndex := Pos('~}', result);

  end;

end;

function StrSimilar(s1, s2: string): Integer;

var

  hit: Integer; // Number of identical chars

  p1, p2: Integer; // Position count

  l1, l2: Integer; // Length of strings

  pt: Integer; // for counter

  diff: Integer; // unsharp factor

  hstr: string; // help var for swapping strings

  test: array [1..255] of Boolean; // Array shows is position is already tested

begin


  // Test Length and swap, if s1 is smaller

  // we alway search along the longer string

  if Length(s1) < Length(s2) then begin

    hstr:= s2;

    s2:= s1;

    s1:= hstr;

  end;


  // store length of strings to speed up the function

  l1:= Length (s1);

  l2:= Length (s2);

  p1:= 1;  p2:= 1;  hit:= 0;


  // calc the unsharp factor depending on the length

  // of the strings.  Its about a third of the length


  diff:= Max (l1, l2) div 3 + ABS (l1 - l2);


  // init the test array

  for pt:= 1 to l1 do

    test[pt]:= False;


  // loop through the string

  repeat

    // position tested?

    if not test[p1] then begin

      // found a matching character?

      if (s1[p1] = s2[p2]) and (ABS(p1-p2) <= diff) then begin

        test[p1]:= True;

        // increment the hit count

        Inc (hit);

        // next positions

        Inc (p1);

        Inc (p2);

        if p1 > l1 then p1:= 1;

      end else begin

        // Set test array

        test[p1]:= False;

        Inc (p1);


        // Loop back to next test position if end of the string

        if p1 > l1 then begin

          while (p1 > 1) and not (test[p1]) do

            Dec (p1);

          Inc (p2)

        end;

      end;

    end else begin

      Inc (p1);


      // Loop back to next test position if end of string

      if p1 > l1 then begin

        repeat

          Dec (p1);

        until (p1 = 1) or test[p1];

        Inc (p2);

      end;

    end;

  until p2 > Length(s2);

  // calc procentual value

  Result:= 100 * hit DIV l1;

end;

function StrCompare(Source, Pattern: String): Boolean;

var

  pSource: Array [0..255] of Char;

  pPattern: Array [0..255] of Char;

  function MatchPattern(element, pattern: PChar): Boolean;

    function IsPatternWild(pattern: PChar): Boolean;

    var

      t: Integer;

    begin

      Result := StrScan(pattern,'*') <> nil;

      if not Result then Result := StrScan(pattern,'?') <> nil;

    end;

  begin

    if 0 = StrComp(pattern,'*') then

      Result := True

    else if (element^ = Chr(0)) and (pattern^ <> Chr(0)) then

      Result := False

    else if element^ = Chr(0) then

      Result := True

    else begin

      case pattern^ of

        '*': begin

          if MatchPattern(element,@pattern[1]) then

            Result := True else

            Result := MatchPattern(@element[1],pattern);

        end;

        '?': Result := MatchPattern(@element[1],@pattern[1]);

        else begin

          if element^ = pattern^ then

            Result := MatchPattern(@element[1],@pattern[1]) else

            Result := False;

        end;

      end;

    end;

  end;

begin

  StrPCopy(pSource,source);

  StrPCopy(pPattern,pattern);

  Result := MatchPattern(pSource,pPattern);

end;

function StrUpset(value : WideString): widestring;

var

  l, i : Integer;

  uR : WideString;

begin

  l := Length(value);

  uR := value;

  for I := 1 to L do

    uR[i] := value[l - i + 1];

  result := uR;

end;

function StrCorrect(value, Source, Target : widestring): string;

var

  I, P : integer;

begin

  for I := 1 To Length(value) Do

  begin

    P := Pos(value[I], Source);

    If (P <> 0) and (P <= Length(Target)) then value[i] := Target[P];

  end;

  result := value;

end;

function NumberSwitch(value : WideString; Source, Target : Integer): string;

var

  sSource, sTarget : widestring;

begin

  case Source of

    INT_CHINESE_NUMBER : sSource := '○一二三四五六七八九零壹贰叁肆伍陆柒捌玖';

    INT_CHINESE_SIMPLE_NUMBER : sSource := '○一二三四五六七八九';

    INT_CHINESE_TRADITION_NUMBER : sSource := '零壹贰叁肆伍陆柒捌玖';

    INT_ARABIC_NUMERALS : sSource := '01234567890123456789';

  end;

  case Target of

    INT_CHINESE_NUMBER : sTarget := '○一二三四五六七八九零壹贰叁肆伍陆柒捌玖';

    INT_CHINESE_SIMPLE_NUMBER : sTarget := '○一二三四五六七八九';

    INT_CHINESE_TRADITION_NUMBER : sTarget := '零壹贰叁肆伍陆柒捌玖';

    INT_ARABIC_NUMERALS : sTarget := '01234567890123456789';

  end;

  result := StrCorrect(value, sSource, sTarget);

end;

function TabulationSwitch(value : WideString; format : integer): string;

const

  TabulationChars : array[1..11] of WideString = (

    '─━┄┅┈┉',

    '│┃┆┇┊┋',

    '┌┍┎┏',

    '┐┑┒┓',

    '└┕┖┗',

    '┘┘┚┛',

    '├┝┞┟┠┡┢┣',

    '┤┥┦┧┨┩┪┫',

    '┬┭┮┯┰┱┲┳',

    '┴┵┶┷┸┹┺┻',

    '┼┽┾┿╀╁╂╃╄╅╆╇╈╉╊╋'

  );

  sDouble : widestring = '═║╔╗╚╝╠╣╦╩╬';

  sWide   : widestring = '━┃┏┓┗┛┣┫┳┻╋';

  sThin   : widestring = '─│┌┐└┘├┤┬┴┼';

var

  I : Integer;

  J : Integer;

  R : WideString;

Begin

  case format of

    INT_CREWEL : R := sDouble;

    INT_MONGLINE_WIDE : R := sWide;

    INT_MONGLINE_THIN : R := sThin;

  end;

  for I := 1 To Length(value) do

    for j := 1 to 11 do

      if Pos(value[I], TabulationChars[J]) <> 0 then begin

        value[I] := R[J];

        break;

      end;

  Result := value;

end;

function CurrencySwitch(value : string; Format : Integer): string;

var

  i : integer;

  cur : string;

begin

  for i := 1 to length(value) do

  begin

    if (value[i] = '.') and (cur <> '') then

      cur := cur + '.' else

    if value[i] in ['0'..'9'] then

      cur := cur+value[i] else

    if cur = '' then

      result := result + value[i]

    else begin

      value := value + CurrencySwitch(strtoFloat(cur), format);

      cur := '';

    end;

  end;

  if cur <> '' then

    result := result + CurrencySwitch(strtoFloat(cur), format);

end;

function CurrencySwitch(value : Real; Format : Integer): string;

var

  sCurrency : widestring;

  function GetCurrency(I : Integer): string;

  begin

    result := '';

    If I <= Length(sCurrency) then result := sCurrency[I]

  end;

  function RightStr(value : string): string;

  begin

    result := value[Length(value)-1]+value[Length(value)];

  end;

var

  s : string;

  i : integer;

  w : integer;

begin

  case format of

    INT_CURRENCY_CHINESE_SIMPLE : sCurrency := '元十百千万十百千亿十百千';

    INT_CURRENCY_CHINESE_TRADITION : sCurrency := '圆拾佰仟萬拾佰仟億拾佰仟';

    INT_NUMERICAL_CHINESE_SIMPLE : sCurrency := '点十百千万十百千亿十百千';

    INT_NUMERICAL_CHINESE_TRADITION : sCurrency := '點拾佰仟萬拾佰仟億拾佰仟';

  end;

  s := FloatToStr(abs(value));

  w := pos('.', s);

  If w = 0 Then w := length(s) + 1;

  for i := 1 to w-1 do

  begin

    If s[i]<>'0' Then

      result := result + s[i] + GetCurrency(w - i);


    //防止零重复出现