Power-Programmierung/CD1.mdf/pascal/library/dos/nicol/sti_strn/sti_strn.pas

Pascal/Delphi Source File | 1991-04-06 | 6.3 KB | 272 lines

Unit STI_STRN;

interface

function MakeStr(SLen,Character : byte) : string;
function LoCase(Inch : char) : char;
function UpCaseStr(InStr : string) : string;
function LoCaseStr(InStr : string) : string;

procedure Delete_One_Word(Var Instring : string; Pos : byte);
procedure LeftTrimStr(Var Instring : string);
procedure RightTrimStr(Var Instring : string);
procedure Centre_String(Var InString : string; Width : byte; PackChar : char);
procedure UpCase_One_Word(Var Instring : string; Pos : byte);
procedure LoCase_One_Word(Var Instring : string; Pos : byte);
procedure UpCaseStr2(Var InStr : string);
procedure LoCaseStr2(Var InStr : string);
procedure Strip(var Line : string; var Len : byte; Break : string);
procedure Parse(var Line,Word : string; Break : string);
procedure Replace(var Target,OldStr,NewStr : string; MaxLen : Byte);


implementation

{---------------------------------------------------------------------------}

function MakeStr(SLen,Character : byte) : string;

Var
  Dummy : string;

begin
  FillChar(Dummy[1],SLen,Character);
  Dummy[0] := char(SLen);
  MakeStr := Dummy;
end;

{---------------------------------------------------------------------------}

function LoCase(Inch : char) : char;

begin
  if Inch in ['A'..'Z'] then
    LoCase := char(ord(Inch)+32)
  else
    LoCase := Inch;
end;

{---------------------------------------------------------------------------}

function UpCaseStr(InStr : string) : string;

Var
  Loop : byte;

begin
  for Loop := 1 to Length(InStr) do
    InStr[Loop] := UpCase(InStr[Loop]);
  UpCaseStr := InStr;
end;

{---------------------------------------------------------------------------}

function LoCaseStr(InStr : string) : string;

Var
  Loop : byte;

begin
  for Loop := 1 to Length(InStr) do
    InStr[Loop] := LoCase(InStr[Loop]);
  LoCaseStr := InStr;
end;

{---------------------------------------------------------------------------}

procedure Delete_One_Word(Var Instring : string; Pos : byte);

Var
  Pos2 : byte;

begin
  Pos2 := Pos;
  if Instring[Pos2] <> ' ' then
    begin
      while Instring[Pos2] <> ' ' do
        Inc(Pos2);
    end
  else
    begin
      while Instring[Pos2] = ' ' do
        Inc(Pos2);
    end;
  Instring := Copy(Instring,1,Pos-1) + Copy(Instring,Pos2,255);
end;

{---------------------------------------------------------------------------}

procedure LeftTrimStr(Var Instring : string);

Var
  Pos : byte;

begin
  Pos := 1;
  while (Instring[Pos] < #33) and (Pos < Length(Instring)) do
    Inc(Pos);
  Instring := Copy(Instring,Pos,256);
end;

{---------------------------------------------------------------------------}

procedure RightTrimStr(Var Instring : string);

Var
  Pos : byte;

begin
  Pos := length(InString);
  while (Instring[Pos] < #33) and (Pos > 0) do
    Dec(Pos);
  Instring := Copy(Instring,1,Pos);
end;

{---------------------------------------------------------------------------}

procedure Centre_String(Var InString : string; Width : byte; PackChar : char);

begin
  LeftTrimStr(InString);
  RightTrimStr(InString);
  if Length(Instring) < Width then
   begin
     Instring := MakeStr((Width - Length(InString)) div 2,ord(PackChar)) +
                 InString +
                 MakeStr((Width - Length(InString)) div 2,ord(PackChar));
   end;
end;

{---------------------------------------------------------------------------}

procedure UpCase_One_Word(Var Instring : string; Pos : byte);

begin
  if Instring[Pos] = ' ' then
    Exit
  else
    begin
      while Instring[Pos] <> ' ' do
        begin
          Instring[Pos] := UpCase(Instring[Pos]);
          Inc(Pos);
        end;
    end;
end;

{---------------------------------------------------------------------------}

procedure LoCase_One_Word(Var Instring : string; Pos : byte);

begin
  if Instring[Pos] = ' ' then
    Exit
  else
    begin
      while Instring[Pos] <> ' ' do
        begin
          Instring[Pos] := LoCase(Instring[Pos]);
          Inc(Pos);
        end;
    end;
end;

{---------------------------------------------------------------------------}

procedure UpCaseStr2(Var InStr : string);

begin
  InStr := UpCaseStr(InStr);
end;

{---------------------------------------------------------------------------}

procedure LoCaseStr2(Var InStr : string);

begin
  InStr := LoCaseStr(InStr);
end;

{---------------------------------------------------------------------------}

procedure Strip(var Line : string; var Len : byte; Break : string);
{
       purpose       pull out all chars in Break from start of Line
       last update   09 Jul 85
}
var
  Indx               : byte;

begin
  Len := Length(Line);
  if Len > 0 then begin
    Indx := 0;
    while (pos(Line[Indx+1],Break) <> 0) and (Indx < Len) do
      Indx := Indx + 1;
    Delete(Line,1,Indx);
    Len := Len - Indx;
  end
end; { of proc Strip }

{---------------------------------------------------------------------------}

procedure Parse(var Line,Word : string; Break : string);
{
       purpose       removes first word in Line and returns it in Word
       last update   23 Jun 85
}
var
  Len,Indx           : byte;
begin
  Word := '';
  Strip(Line,Len,Break);
  if Len = 0
    then Exit;
  Indx := 0;
  while not (pos(Line[Indx+1],Break) <> 0) and (Indx < Len) do
    Indx := Indx + 1;
  Word := Copy(Line,1,Indx);
  Delete(Line,1,Indx);
  Strip(Line,Len,Break)
end; { of proc Parse }

{---------------------------------------------------------------------------}

procedure Replace(var Target,OldStr,NewStr : string; MaxLen : Byte);
{
       purpose       look for all instances of OldStr and replace with NewStr
       last update   09 Jul 85
}
var
  TarLen,OldLen,IncLen,Indx
                     : Integer;
begin
  TarLen := Length(Target);
  OldLen := Length(OldStr);
  IncLen := Length(NewStr) - OldLen;
  Indx := Pos(OldStr,Target);
  while Indx > 0 do begin
    if TarLen + IncLen <= MaxLen then begin
      Delete(Target,Indx,OldLen);
      Insert(NewStr,Target,Indx);
      TarLen := TarLen + IncLen;
      Indx := Pos(OldStr,Target)
    end
    else Indx := 0
  end
end; { of proc Replace }

{---------------------------------------------------------------------------}

begin
end.