xprocs.pas

很久以前用delphi写的一个SQLServer外部的企业管理器

function strPadChC(const S: String; C: Char; Len: Integer): String;
begin
  Result:=S;
  while Length(Result)<Len do
  begin
    Result:=Result+C;
    if Length(Result)<Len then Result:=C+Result;
  end;
end;

function strPadL(const S: String; Len: Integer): String;
begin
  Result:=strPadChL(S,BLANK,Len);
end;

function strPadC(const S: String; Len: Integer): String;
begin
  Result:=strPadChC(S,BLANK,Len);
end;


function strPadR(const S: String; Len: Integer): String;
begin
  Result:=strPadChR(S,BLANK,Len);
end;

function strPadZeroL(const S: String; Len: Integer): String;
begin
  Result:=strPadChL(strTrim(S),ZERO,Len);
end;

function strCut(const S: String; Len: Integer): String;
begin
  Result:=strLeft(strPadR(S,Len),Len);
end;

function strRight(const S: String; Len: Integer): String;
begin
  if Len>=Length(S) then
    Result:=S
  else
    Result:=Copy(S,Succ(Length(S))-Len,Len);
end;

function strAddSlash(const S: String): String;
begin
  Result:=S;
  if strLastCh(Result)<>SLASH then Result:=Result+SLASH;
end;

function strDelSlash(const S: String): String;
begin
  Result:=S;
  if strLastCh(Result)=SLASH then Delete(Result,Length(Result),1);
end;

function strSpace(Len: Integer): String;
begin
  Result:=StrMake(BLANK,Len);
end;

function strToken(var S: String; Seperator: Char): String;
var
  I               : Word;
begin
  I:=Pos(Seperator,S);
  if I<>0 then
  begin
    Result:=System.Copy(S,1,I-1);
    System.Delete(S,1,I);
  end else
  begin
    Result:=S;
    S:='';
  end;
end;

function strTokenCount(S: String; Seperator: Char): Integer;
begin
  Result:=0;
  while S<>'' do begin            { 29.10.96 sb }
    StrToken(S,Seperator);
    Inc(Result);
  end;
end;

function strTokenAt(const S:String; Seperator: Char; At: Integer): String;
var
  j,i: Integer;
begin
  Result:='';
  j := 1;
  i := 0;
  while (i<=At ) and (j<=Length(S)) do
  begin
    if S[j]=Seperator then
       Inc(i)
    else if i = At then
       Result:=Result+S[j];
    Inc(j);
  end;
end;

procedure strTokenToStrings(S: String; Seperator: Char; List: TStrings);
var
  Token: String;
begin
  List.Clear;
  Token:=strToken(S,Seperator);
  while Token<>'' do
  begin
    List.Add(Token);
    Token:=strToken(S,Seperator);
  end;
end;

function strTokenFromStrings(Seperator: Char; List: TStrings): String;
var
  i: Integer;
begin
  Result:='';
  for i:=0 to List.Count-1 do
     if Result<>'' then
       Result:=Result+Seperator+List[i]
     else
       Result:=List[i];
end;

function strUpper(const S: String): String;
begin
  Result:=AnsiUpperCase(S);
end;

function strOemAnsi(const S:String):String;
begin
 {$IFDEF Win32}
  SetLength(Result,Length(S));
 {$ELSE}
  Result[0]:=Chr(Length(S));
 {$ENDIF}
  OemToAnsiBuff(@S[1],@Result[1],Length(S));
end;

function strAnsiOem(const S:String): String;
begin
 {$IFDEF Win32}
  SetLength(Result,Length(S));
 {$ELSE}
  Result[0]:=Chr(Length(S));
 {$ENDIF}
  AnsiToOemBuff(@S[1],@Result[1],Length(S));
end;

function strEqual(const S1,S2: String): Boolean;
begin
  Result:=AnsiCompareText(S1,S2)=0;
end;

function strCompU(const S1,S2: String) : Boolean;
begin
  Result:=strEqual(strLeft(S2,Length(S1)),S1);
end;

function strComp(const S1,S2: String) : Boolean;
begin
  Result:=strLeft(S2,Length(S1))=S1;
end;

function strContains(const S1,S2: String): Boolean;
begin
  Result:=Pos(S1,S2) > 0;
end;

function strContainsU(const S1,S2: String): Boolean;
begin
  Result:=strContains(strUpper(S1),strUpper(S2));
end;

function strNiceNum(const S: String) : String;
var
  i    : Integer;
  Seps : set of Char;
begin
  Seps:=[ThousandSeparator,DecimalSeparator];
  Result:= ZERO;
  for i := 1 to Length(S) do
    if S[i] in DIGITS + Seps then
    begin
      if S[i] = ThousandSeparator then
         Result:=Result+DecimalSeparator
      else
         Result:=Result+S[i];
      if S[i] In Seps then Seps:=[];
    end
end;

function strNiceDate(const S: String): String;
begin
  Result:=strNiceDateDefault(S, DateToStr(Date));
end;

function  strNiceDateDefault(const S, Default: String): String;
(* sinn der Procedure:
   Irgendeinen String 黚ergeben und in ein leidlich brauchbares Datum verwandeln.
   Im Wesentlichen zum Abfangen des Kommazeichens auf dem Zehnerfeld.
   eingabe 10 = R點kgabe 10 des Laufenden Monats
   eingabe 10.12 = R點kgabe des 10.12. des laufenden Jahres.
   eingabe 10.12.96 = R點kgabe des Strings
   eingabe 10,12,96 = R點kgabe 10.12.95 (wird dann won STRtoDATE() gefressen)
   Eine Plausbilit鋞skontrolle des Datums findet nicht Statt.
   Geplante Erweiterung:
   eingabe: +14  = R點kgabe 14 Tage Weiter
   eingabe: +3m  = R點kgabe 3 Monate ab Heute
   eingabe: +3w  = R點kgabe 3 Wochen (3*7 Tage) ab Heute
   Das gleiche auch R點kw鋜ts mit  Minuszeichen
   eingabe: e oder E oder f  = N鋍hster Erster
   eingabe: e+1m Erster des 黚ern鋍hsten Monats
   Da l溥t sich aber noch trefflich weiterspinnen

   EV. mit Quelle rausgeben, damit sich die Engl鋘der und Franzosen an
   Ihren Datumsformaten selbst erfreuen k鰊nen und wir die passenden umsetzungen
   bekommen. *)
var
  a        : array [0..2] of string[4];
  heute    : string;
  i,j      : integer;
begin
  a[0]:='';
  a[1]:='';
  a[2]:='';
  heute := Default;

  j := 0;
  for i := 0 to length(S) do
    if S[i] in DIGITS then
      a[j] := a[j]+S[i]
    else if S[i] in [DateSeparator] then Inc(j);
  for i := 0 to 2 do
  if Length(a[i]) = 0 then
    if I=2 then
      a[i] :=copy(heute,i*3+1,4)
    else
      a[i] := copy(heute,i*3+1,2)
  else
    if length(a[i]) = 1 then
      a[i] := '0'+a[i];

  Result:=a[0]+DateSeparator+a[1]+DateSeparator+a[2];
  try
    StrToDate(Result);
  except
    Result:=DateToStr(Date);
  end;
end;

function strNiceTime(const S: String): String;
var
  a   : array[0..2] of string[2];
  i,j : integer;
begin
  j:= 0;
  a[0]:= '';
  a[1]:='';
  a[2]:='';
  for i:= 1 to length(S) do
  begin
    if S[i] in DIGITS then
    begin
      a[j] := a[j]+S[i];
    end
    else if S[i] in ['.',',',':'] then
      inc(J);
    if j > 2 then exit;
  end;
  for J := 0 to 2 do
    if length(a[j]) = 1 then a[j] := '0'+a[j] else
    if length(a[j]) = 0 then a[j] := '00';
  Result := a[0]+TimeSeparator+a[1]+TimeSeparator+a[2];
end;

function strNicePhone(const S: String): String;
var
  L : Integer;
begin
  if Length(S) > 3 then
  begin
    L:=(Length(S)+1) div 2;
    Result:=strNicePhone(strLeft(S,L))+SPACE+strNicePhone(strRight(S,Length(S)-L));
  end else
    Result := S;
end;

function strReplace(const S: String; C: Char; const Replace: String): String;
var
  i : Integer;
begin
  Result:='';
  for i:=Length(S) downto 1 do
    if S[i]=C then Result:=Replace+Result
              else Result:=S[i]+Result;
end;

function strPos(const aSubstr,S: String; aOfs: Integer): Integer;
begin
  Result:=Pos(aSubStr,Copy(S,aOfs,(Length(S)-aOfs)+1));
  if (Result>0) and (aOfs>1) then Inc(Result,aOfs-1);
end;

procedure strChange(var S:String; const Src, Dest: String);
var
  P : Integer;
begin
  P:=Pos(Src,S);
  while P<>0 do
  begin
    Delete(S,P,Length(Src));
    Insert(Dest,S,P);
    Inc(P,Length(Dest));
    P:=strPos(Src,S,P);
  end;
end;

function strChangeU(const S,Source, Dest: String): String;
var
  P    : Integer;
  aSrc : String;
begin
  Result:=S;
  aSrc:=strUpper(Source);
  P:=Pos(aSrc,strUpper(Result));
  while P<>0 do
  begin
    Delete(Result,P,Length(Source));
    Insert(Dest,Result,P);
    Inc(P,Length(Dest));
    P:=strPos(aSrc,strUpper(Result),P);
  end;
end;


function strCmdLine: String;
var
  i: Integer;
begin
  Result:='';
  for i:=1 to ParamCount do Result:=Result+ParamStr(i)+' ';
  Delete(Result,Length(Result),1);
end;

{ sends a string to debug windows inside the IDE }
{$IFDEF Win32}
procedure strDebug(const S: String);
var
  P    : PChar;
  CPS  : TCopyDataStruct;
  aWnd : hWnd;
begin
  aWnd := FindWindow('TfrmDbgTerm', nil);
  if aWnd <> 0 then
  begin
    CPS.cbData := Length(S) + 2;
    GetMem(P, CPS.cbData);
    try
      StrPCopy(P, S+CR);
      CPS.lpData := P;
      SendMessage(aWnd, WM_COPYDATA, 0, LParam(@CPS));
    finally
      FreeMem(P, Length(S)+2);
    end;
  end;
end;
{$ENDIF}

function strSoundex(S: String): String;
const
  CvTable : array['B'..'Z'] of char = (
    '1', '2', '3', '0', '1',   {'B' .. 'F'}
    '2', '0', '0', '2', '2',   {'G' .. 'K'}
    '4', '5', '5', '0', '1',   {'L' .. 'P'}
    '2', '6', '2', '3', '0',   {'Q' .. 'U'}
    '1', '0', '2', '0', '2' ); {'V' .. 'Z'}
var
  i,j : Integer;
  aGroup,Ch  : Char;

  function Group(Ch: Char): Char;
  begin
    if (Ch in ['B' .. 'Z']) and not (Ch In ['E','H','I','O','U','W','Y']) then
       Result:=CvTable[Ch]
    else
       Result:='0';
  end;

begin
  Result := '000';
  if S='' then exit;

  S:= strUpper(S);
  i:= 2;
  j:= 1;
  while (i <= Length(S)) and ( j<=3) do
  begin
    Ch := S[i];
    aGroup := Group(Ch);
    if (aGroup <> '0') and (Ch <> S[i-1]) and
       ((J=1) or (aGroup <> Result[j-1])) and
       ((i>2) or (aGroup <> Group(S[1]))) then
    begin
      Result[j] :=aGroup;
      Inc(j);
    end;
    Inc(i);
  end; {while}

  Result:=S[1]+'-'+Result;
end;

function strByteSize(Value: Longint): String;

  function FltToStr(F: Extended): String;
  begin
    Result:=FloatToStrF(Round(F),ffNumber,6,0);
  end;

begin
  if Value > GBYTE then
    Result:=FltTostr(Value / GBYTE)+' GB'
  else if Value > MBYTE then
    Result:=FltToStr(Value / MBYTE)+' MB'
  else if Value > KBYTE then
    Result:=FltTostr(Value / KBYTE)+' KB'
  else
    Result:=FltTostr(Value) +' Byte';   { 04.08.96 sb }
end;

const
  C1 = 52845;
  C2 = 22719;

function strEncrypt(const S: String; Key: Word): String;
var
  I: Integer;
begin
 {$IFDEF Win32}
  SetLength(Result,Length(S));
 {$ELSE}
   Result[0]:=Chr(Length(S));
 {$ENDIF}
  for I := 1 to Length(S) do begin
    Result[I] := Char(Ord(S[I]) xor (Key shr 8));
    Key := (Ord(Result[I]) + Key) * C1 + C2;
  end;
end;

function strDecrypt(const S: String; Key: Word): String;
var
  I: Integer;
begin
 {$IFDEF Win32}
  SetLength(Result,Length(S));
 {$ELSE}
   Result[0]:=Chr(Length(S));
 {$ENDIF}
  for I := 1 to Length(S) do begin
    Result[I] := char(Ord(S[I]) xor (Key shr 8));
    Key := (Ord(S[I]) + Key) * C1 + C2;
  end;
end;

function  strLastCh(const S: String): Char;
begin
  Result:=S[Length(S)];
end;

procedure strStripLast(var S: String);
begin
  if Length(S) > 0 then Delete(S,Length(S),1);
end;

procedure strSearchReplace(var S:String; const Source, Dest: String; Options: TSRoptions);
var hs,hs1,hs2,hs3: String;
var i,j : integer;

begin
 if  srCase in Options then
  begin
   hs := s;
   hs3 := source;
  end
 else
  begin
   hs:= StrUpper(s);
   hs3 := StrUpper(Source);
  end;
 hs1:= '';
 I:= pos(hs3,hs);
 j := length(hs3);
 while i > 0 do
 begin
   delete(hs,1,i+j-1); {Anfang Rest ge鋘dert 8.7.96 KM}
   hs1 := Hs1+copy(s,1,i-1); {Kopieren ge鋘dert 8.7.96 KM}
   delete(s,1,i-1); {L鰏chen bis Anfang posge鋘dert 8.7.96 KM}
   hs2 := copy(s,1,j); {Bis ende pos Sichern}
   delete(s,1,j); {L鰏chen bis ende Pos}
   if    (not (srWord in Options))
       or (pos(s[1],' .,:;-#''+*?=)(/&%$