xprocs.pas

详细说明:毕业论文中关于小型宾馆管理系统的详细设计毕 业论文中关于小型宾馆...一个酒店管理系统VB+Access [学生学籍管理系统(VB+Acess).zip] - !这个是刚刚编的毕业设计,可能

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],' .,:;-#''+*?=)(/&%$