controls/formsave/UStr.pas

   1 unit UStr;
   2
   3 interface
   4 function  space   (           n:integer):string ;
   5 function  replicate(ch:char;  n:integer):string ;{cä®à¬¨à®¢ âì áâà®ªã}
   6 function  trim    (str:string          ):string ;
   7 function  center  (str:string;n:integer):string ;
   8 function  UpSt    (  s:string          ):string;
   9 function  LoSt    (  s:string          ):string;
  10 function  lpad    (  s:string;n:integer;c:char):string;
  11 function  rpad    (  s:string;n:integer;c:char):string;
  12 function  addbackslash(p : string) : string;{à ¡®â  á ¨¬¥¥¬ path}
  13 function  match   (sm : string; var st: string) : boolean;
  14 function  lines   (p, l, s : longint) : string;
  15 function  LoCase  (c : char) : char;
  16 function  JustPathname(PathName : string) : string;
  17 function  JustFileName(PathName : string) : string;
  18 function  JustName    (PathName : string) : string;
  19 function  CRC16       (s        : string) : system.word;
  20
  21 implementation
  22
  23 function  space;
  24 var   i : integer;
  25 tempstr : string;
  26      begin
  27         tempstr:='';
  28         for i:=1 to n do tempstr:=tempstr+' ';
  29         space:=tempstr;
  30      end;
  31
  32 function  replicate;
  33 var   i : integer;
  34 tempstr : string;
  35      begin
  36         tempstr:='';
  37         for i:=1 to n do tempstr:=tempstr+ch;
  38         replicate:=tempstr;
  39      end;
  40
  41 function  trim;
  42 var i,j : integer;
  43 begin
  44    trim := '';
  45    if length(str) > 1 then begin
  46       j := 1;
  47       while str[j] = ' ' do inc(j);
  48       i := length(str);
  49       while str[i] = ' ' do dec(i);
  50       trim := copy(str, j, i - j + 1);
  51    end;
  52 end;
  53 function  center;
  54 var tempstr : string;
  55           j : integer;
  56      begin
  57         j := n - length(trim(str));
  58         if j > 0 then tempstr := space(j - j div 2) + trim(str) + space(j div 2)
  59                  else tempstr := trim(str);
  60         center := tempstr;
  61      end;
  62
  63 function UpSt;
  64 var t : string;
  65     i : integer;
  66 begin
  67    t := '';
  68    for i := 1 to length(s) do t := t + UpCase(s[i]);
  69    UpSt := t;
  70 end;
  71
  72 function LoSt;
  73 var t : string;
  74     i : integer;
  75 begin
  76    t := '';
  77    for i := 1 to length(s) do t := t + LoCase(s[i]);
  78    LoSt := t;
  79 end;
  80
  81 function lpad;
  82 begin
  83    lpad := replicate(c, n - length(s)) + s;
  84 end;
  85
  86 function rpad;
  87 begin
  88    rpad := s + replicate(c, n - length(s));
  89 end;
  90
  91     function addbackslash;
  92     begin
  93        if length(p) > 0 then
  94        if p[length(p)] = '\' then addbackslash := p
  95                              else addbackslash := p + '\'
  96                         else addbackslash := p;
  97     end;
  98
  99 function match(sm : string; var st: string) : boolean;
 100 var p : integer;
 101   _sm,
 102   _st : string;
 103 begin
 104    match := false;
 105    if (length(sm) > 0) and (length(st) > 0) then begin
 106       _sm := UpSt(sm);
 107       _st := UpSt(st);
 108       while pos(_sm, _st) > 0 do begin
 109          match := true;
 110          p     := pos(_sm, _st);
 111         _st    := copy(_st, 1, p - 1) + copy(_st, p + length(_sm), 250);
 112          st    := copy( st, 1, p - 1) + copy( st, p + length( sm), 250);
 113       end;
 114    end;
 115 end;
 116
 117 function lines;
 118 var o : string;
 119     i : longint;
 120     n : longint;
 121 begin
 122     if l > 0 then begin
 123        i := p * s div l;
 124        n := p * s * 2 div l;
 125        o := replicate('Û', i);
 126        if n > i * 2 then o := o + 'Ý';
 127        lines := o + space(s - length(o));
 128     end else lines := '';
 129 end;
 130
 131 function LoCase;
 132 var t : char;
 133 begin
 134    if (c >= 'A') and (c <= 'Z') then t := chr(ord(c) + 32)
 135                                 else t := c;
 136    LoCase := t;
 137 end;
 138
 139   function JustPathname(PathName : string) : string;
 140     {-Return just the drive:directory portion of a pathname}
 141   var
 142     I : Word;
 143   begin
 144     I := Succ(Word(Length(PathName)));
 145     repeat
 146       Dec(I);
 147     until (PathName[I] in ['\',':',#0]) or (I = 0);
 148
 149     if I = 0 then
 150       {Had no drive or directory name}
 151       JustPathname := ''
 152     else if I = 1 then
 153       {Either the root directory of default drive or invalid pathname}
 154       JustPathname := PathName[1]
 155     else if (PathName[I] = '\') then begin
 156       if PathName[Pred(I)] = ':' then
 157         {Root directory of a drive, leave trailing backslash}
 158         JustPathname := Copy(PathName, 1, I)
 159       else
 160         {Subdirectory, remove the trailing backslash}
 161         JustPathname := Copy(PathName, 1, Pred(I));
 162     end else
 163       {Either the default directory of a drive or invalid pathname}
 164       JustPathname := Copy(PathName, 1, I);
 165   end;
 166
 167   function JustFilename(PathName : string) : string;
 168     {-Return just the filename of a pathname}
 169   var
 170     I : Word;
 171   begin
 172     I := Succ(Word(Length(PathName)));
 173     repeat
 174       Dec(I);
 175     until (I = 0) or (PathName[I] in ['\', ':', #0]);
 176     JustFilename := Copy(PathName, Succ(I), 64);
 177   end;
 178
 179   function JustName(PathName : string) : string;
 180     {-Return just the name (no extension, no path) of a pathname}
 181   var
 182     DotPos : Byte;
 183   begin
 184     PathName := JustFileName(PathName);
 185     DotPos := Pos('.', PathName);
 186     if DotPos > 0 then
 187       PathName := Copy(PathName, 1, DotPos-1);
 188     JustName := PathName;
 189   end;
 190
 191
 192 function CRC16(s : string) : system.word;  { By Kevin Cooney }
 193 var
 194   crc : longint;
 195   t,r : byte;
 196 begin
 197   crc := 0;
 198   for t := 1 to length(s) do
 199   begin
 200     crc := (crc xor (ord(s[t]) shl 8));
 201     for r := 1 to 8 do
 202       if (crc and $8000)>0 then
 203         crc := ((crc shl 1) xor $1021)
 204           else
 205             crc := (crc shl 1);
 206   end;
 207   CRC16 := (crc and $FFFF);
 208 end;
 209
 210 end.