[Back to MAIL SWAG index] [Back to Main SWAG index] [Original]

    Program Sig;

    { Description:  This is a little program which I wrote whose sole purpose }
    {               in life is to add signature lines to messages written in  }
    {               an offline mail reader.  The program scans a text file for}
    {               instances of /SIGx (where x is a number) and replaces them}
    {               with signature number x from a configuration file.       }

    { Requires:     USEFULL.PAS written by me. Email me if you don't have it.}
    {               ACOLOR.INC written by me.  Email me if you don't have it.}

    {               NOTE : they are Attached at the end of this unit }

    { Created:      March 1995 }

    { Author:       Tobin Fricke (tobin@mail.edm.net)                       }

    { If you use this, I'd appreciate it if you could send me a postcard    }
    { from where you live, or at least send me an email.  My email address  }
    { is tobin@mail.edm.net.  If that doesn't work, try using               }
    { fricke@roboben.engr.ucdavis.edu.  My postal address is:               }
    { 25001 El Cortijo Ln., Mission Viejo, CA 92691-5236, USA.  Thanks!     }

    {
    ; CyberSig configuration file example:
    @1
     ÚÄÄÄÄÄÄÄÄÄÄÄ¿
     ³ Light Ray ³
     ÀÄÄÄÄÄÄÄÄÄÄÄÙ
    @2
     Tobin T. Fricke
     TobinTech Engineering
     dr261@cleveland.freenet.edu
    }

    Uses CRT, Usefull;

    Const MyVersion='1.00';

    {$I ACOLOR.INC}

    Procedure Process(Config,Filename:String);
    Const ConfigF=0;      InputF=1;      OutputF=2;
    Var F:Array[0..2] of Text;
        N,S,W,Q:String;
        B:Byte;
        Rep:Boolean;
    begin
     Assign(F[ConfigF],Config);
     Assign(F[InputF],Filename);
     N:=TempFile('');
     Rename(F[InputF],N);
     Reset(F[InputF]);
     Assign(F[OutputF],Filename);
     Rewrite(F[OutputF]);
     Repeat
      Readln(F[InputF],S);
      If Pos('/SIG',UPSTRING(S))=1
       then
        begin
         Write('  `Bþ`3 Found '+S);
         Rep:=False;
         Reset(F[ConfigF]);
         B:=0;
         Repeat
          Readln(F[ConfigF],W);
          If W[1]<>';' then
           begin
            If W[1]='@' then B:=Val(del(W,1,1))
             else
              begin
               Q:=UpString('/SIG'+Str(B));
               if Q=UpString(S) then
                 begin
                  System.Writeln(F[OutputF],W);
                  Rep:=True;
                 end;
              end;
           end;
         Until EOF(F[ConfigF]);
         If Rep then Writeln(', Replaced with signature') else
                     Writeln(', Signature not found in config file');
         Close(F[ConfigF]);
        end
       else
        System.Writeln(F[OutputF],S);
     Until EOF(F[InputF]);
     Close(F[InputF]);
     Close(F[OutputF]);
     Erase(F[InputF]);
     Rename(F[OutputF],Filename);
    end;

    Begin
     clrScr;
     Writeln(' `4Cy`Cbe`FrSig Signature App`Cli`4er`8,`7 Version `F'+MyVersion+'`7');
     Writeln(' `9Copyright `1(`9C`1)`9 1995 by Tobin T`1.`9 Fricke`1,`9 All Rights Reserved`1.`7 ');
     Writeln(' `3Created At the `2Di`AGi`FTAL Fo`ARE`2ST `3(`B714`3)`B 586`3-`B6142 `928800`1bps`7');
     If (ParamCount<>2) or
        (Not FileExists(ParamStr(1))) or
        (Not FileExists(ParamStr(2)))
       then
      begin
       Writeln(' `EUSAGE: `F'+ParamStr(0)+' `8(`7CONFIG FILE`8) (`7FILENAME`8)`7');
       Writeln(' `8(`7CONFIG FILE`8) `3is the complete path and filename of your config file. ');
       Writeln(' `8(`7FILENAME`8) `3is the complete path and filename of the message file to process. ');
       If ParamCount=2 then
        begin
         If Not FileExists(ParamStr(1)) then Writeln(' `B Cannot find '+paramStr(1));
         If Not FileExists(ParamStr(2)) then Writeln(' `B Cannot find '+paramStr(2));
        end;
      end;
      Process(ParamStr(1),ParamStr(2));
    End.

    { ------------------- ACOLOR.INC ... CUT ---------}
    { Description: These routines allow one to embed color codes into strings }
    {              and have them print out nicely.  The format is ` followed  }
    {              by a character from 0 to 9, A to O, X or Y which represents}
    {              the color.                                                 }

    { Filename:    ACOLOR.INC }

    { Date:        March 1995   }
    { Author:      Tobin Fricke }

    { If you use this, I'd appreciate it if you could send me a postcard    }
    { from where you live, or at least send me an email.  My email address  }
    { is tobin@mail.edm.net.  If that doesn't work, try using               }
    { fricke@roboben.engr.ucdavis.edu.  My postal address is:               }
    { 25001 El Cortijo Ln., Mission Viejo, CA 92691-5236, USA.  Thanks!     }

    Procedure Write(S:String);
    begin
     Repeat
      If S[1]='`' then
       begin
        S[2]:=UpCase(S[2]);
        If S[2] IN ['0'..'9','A'..'O','X','Y'] then
         Begin
          If S[2] IN ['0'..'9'] then TextColor(Ord(S[2])-48);
          IF S[2] IN ['A'..'F'] then TextColor(Ord(S[2])-55);
          IF S[2] IN ['G'..'O'] then TextBackground(Ord(S[2])-71);
          IF S[2]='X' then if (TextAttr AND 128)=0 then TextAttr:=TextAttr+128;
          IF S[2]='Y' then if (TextAttr AND 128)=128 then TextAttr:=TextAttr-128;
          Delete(S,1,2);
         End;
       end
       else
       begin
        System.Write(S[1]);
        Delete(S,1,1);
       end;
     Until S='';
    end;

    Procedure Writeln(S:String);
    begin
     Write(S+#10+#13);
    end;

    Function RandomCase(S:String):String;
    Var B:Byte;
    begin
     For B:=1 to Length(S) do
      if random>0.5 then S[B]:=LoCase(S[B]) else S[B]:=UpCase(S[B]);
      RandomCase:=S;
    end;

    Function RandomColor(S:String):String;
    var B:Byte;
    begin
     For B:=Length(S) downto 1 do
      if Random>0.5 then Insert('`3',S,B) else Insert('`B',S,B);
     RandomColor:=S;
    end;

    Function RainBow(S:String;A:Byte):String;
    Begin
     If A<Length(S) then Insert('`8',S,A+3);
     If A<=Length(S) then Insert('`7',S,A+2);
     Insert('`F',S,A+1);
     Insert('`7',S,A);
     Insert('`8',S,0);
     S:=S+' ';
     Rainbow:=S;
    End;

    {------------------ CUT ---------------------}
    Unit Usefull;

    { Copyright (C) 1995 by Tobin T. Fricke, All Rights Reserved            }
    { Use this and have fun, but tell me first.  BBS 714-586-6142           }
    { Make sure to mention that you used this in your documentation of your }
    { program(s) if you do use it.  Thanks.                                 }
    { I didn't write all of the routines, but I wrote most of them.         }

    { If you use this, I'd appreciate it if you could send me a postcard    }
    { from where you live, or at least send me an email.  My email address  }
    { is tobin@mail.edm.net.  If that doesn't work, try using               }
    { fricke@roboben.engr.ucdavis.edu.  My postal address is:               }
    { 25001 El Cortijo Ln., Mission Viejo, CA 92691-5236, USA.  Thanks!     }

    { Updated May 1995 }

    Interface

    {$IFDEF WINDOWS}
    type
        { Date & time recored used by PackTime }
        { and UnpackTime }
      DateTime = record
        Year,Month,Day,Hour,Min,Sec: Word;
      end;
    {$ENDIF}

     Type MIDRecord = Record
         InfoLevel : Word;
         SerialNum : LongInt;   {This is the serial number...}
         VolLabel  : Array[1..11] of Char;
         FatType   : Array[1..8] of Char;
         End;

    {$IFNDEF OS2} Function Label_Fat(Var Mid : MidRecord; Drive : Word) : Boolean;
    {$ENDIF}
    Function LongToHex(L:Longint):String;
    Function  Center(S:String; B:Byte):String;
    {Center returns a S, centered with spaces, of length B }
    Function  Left(S:String; B:Byte):String;
    { returns a Left-Justied string, length B              }
    Function  PadRight(S:String; B:Byte; C:Char):String;
    { returns S padded with B of C on the Right            }
    Function  Right(S:String; B:Byte):String;
    { same as Left, but right-justifies                    }
    function  FileExists(FileName: String): Boolean;
    { does Filename Exist?                                 }
    Function  UpString(S:String):String;
    { Returns S in upper case                              }
    Function  LoString(S:String):String;
    { Returns S in lower case                              }
    Function  LoCase(C:Char):Char;
    { Returns C in lower case                              }
    Function  Str(X:integer):String;
    { Converts X to a string                               }
    Function  Strw(X:Word):String;
    { Convert a Word to a String                           }
    Function  Strl(X:LongInt):String;
    Function  StrR(X:Real):String;
    Function  WhatDir:String;
    Function  Val(S:String):Integer;
    Function  ValW(S:String):Word;
    Function  ValL(S:String):longint;
    Function  Rep(S:String; C:Word):String;
    Function  TempFile( Path: STRING ): STRING;
    Function  SizeOfFile(S:String):LongInt;
    Function  NameCaps(S:String):String;
    { Capitalize The First Letter Of Each Word             }
    Function  Del(S:String; Index: Integer; Count:Integer):String;
    { Delete, but as a function                            }
    Function  Strip_(S:String):String;
    { Changes _'s to spaces                                }
    Function  ActualFileSize:LongInt;
    { How big is your EXE?                                 }
    Procedure Lines(S:String);
    Procedure Lines50;              { Go into 50 lines-mode}
    Procedure Lines25;
    Procedure Lines35;
    {$IFNDEF OS2}
    Function  NetworkDrive(Drive:Char):Boolean;
    {$ENDIF}
    Function  StrBool(S:String):Boolean;
    Procedure SwapStr(Var A,B:String);
    { Swaps A and B:  C=A; A=B; B=C; }
    Procedure ConvertBase(BaseN:Byte; BaseNNumber:String;
                                      BaseZ:Byte; var BaseZNumber:String);
    { Converts base 2-36 to base 2-36                                  }
    Function WordWrap(S:String; Var Remainder:String; Len:Byte):String;
    { Tobin's wonder-word-wrap.                                        }
    Function AN(S:String):String;
    { prepends "a " or "an " to S, based on the first letter }
    Function LastDrive: Char;

    var UError:Word;

    Implementation

    {$IFDEF WINDOWS}
    Uses WinCRT, WinDOS;
    {$ELSE}
    Uses CRT, DOS;
    {$ENDIF}

    {$IFNDEF OS2}
    Function Label_Fat(Var Mid : MidRecord; Drive : Word) : Boolean;
    Var Result : Word;
    Var Regs   : Registers;
    Begin
         FillChar(Mid,SizeOf(Mid),0);
         FillChar(Regs,SizeOf(Regs),0);
         With Regs DO
         Begin
              AX := $440D;
              BX := Drive;
              CX := $0866;
              DS := Seg(Mid);
              DX := Ofs(Mid);
              Intr($21,Regs);
              Case AX of
                   $01 : Label_Fat := False;
                   $02 : Label_Fat := False;
                   $05 : Label_Fat := False;
                   Else Label_Fat := True;
              End;
         End;
    End;
    {$ENDIF}
    (*
    Var Mid : MidRecord;
    Begin
         ClrScr;
         If Label_Fat(Mid,0) Then
         With Mid DO
         Begin
              Writeln(SerialNum);
              Writeln(VolLabel);
              Writeln(FatType);
         End
         Else Writeln('Error Occured');
    End.
    *)

    Procedure ConvertBase(BaseN:Byte; BaseNNumber:String;
                                      BaseZ:Byte; var BaseZNumber:String);

    var
      I: Integer;
      Number,Remainder: LongInt;

    begin
     Number := 0;
     for I := 1 to Length (BaseNNumber) do
      case BaseNNumber[I] of
        '0'..'9': Number := Number * BaseN + Ord (BasenNumber[I]) - Ord ('0');
        'A'..'Z': Number := Number * BaseN + Ord (BasenNumber[I]) -
          Ord ('A') + 10;
        'a'..'z': Number := Number * BaseN + Ord (BasenNumber[I]) -
          Ord ('a') + 10;
        end; BaseZNumber := ''; while Number > 0 do
      begin
      Remainder := Number mod BaseZ;
      Number := Number div BaseZ;
      case Remainder of
        0..9: BaseZNumber := Char (Remainder + Ord ('0')) + BaseZNumber;
        10..36: BaseZNumber := Char (Remainder - 10 + Ord ('A')) + BaseZNumber;
        end;

    end; end;

    Procedure SwapStr(Var A,B:String);
    var C:String;
    begin
     C:=A;
     A:=B;
     B:=C;
    end;
    {$IFDEF XXX}
    Type Registers = record
                    case Integer of
                      0: (AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags: Word);
                      1: (AL,AH,BL,BH,CL,CH,DL,DH: Byte);
                  end;
    {$ENDIF}

    {$IFNDEF OS2}
    FUNCTION NetworkDrive (Drive:CHAR):BOOLEAN;
    {$Ifdef windows} var reg:Tregisters; {$else} var Reg:Registers; {$endif}
    var DosErrorCode:Word;
      BEGIN
        Drive := UpCase (Drive);            { Drive _must_ be 'A'..'Z'  }
        IF (Drive IN ['A'..'Z']) THEN BEGIN { make sure of 'A'..'Z'     }
          Reg.BL := ORD(Drive) - 64;      { 1 = A:, 2 = B:, 3 = C: etc. }
          Reg.AX := $4409;                { Dos fn: check if dev remote }
          MsDos (Reg);                    { call Dos' services          }
          IF ODD(Reg.FLAGS) THEN          { Dos reports function error? }
            DosErrorCode := Reg.AX        { yes: return Dos' error code }
          ELSE BEGIN                      {   else ...                  }
            DosErrorCode := 0;            { 0 = no error was detected   }
            IF ODD(Reg.DX SHR 12) THEN    { is Drive remote?            }
              NetworkDrive := TRUE        { yes: return TRUE            }
            ELSE
              NetworkDrive := FALSE;      { no: return FALSE            }
            {END IF ODD(Reg.DX...}
        END; {IF ODD(Reg.FLAGS)}
      END;    {IF Drive}
    END    {NetworkDrive};
    {$ENDIF}

    Function SizeofFile(S:String):LongInt;
    var F:File;
    begin
     Assign(F,S);
     FileMode:=0;
     Reset(F,1);
     SizeOfFile:=FileSize(F);
     Close(F);
    end;

    Function ActualFileSize:LongInt;
    var F:File;
    begin
     ActualFileSize:=SizeOfFile(ParamStr(0));
    end;

    Procedure Lines50; Assembler;
     ASM
      MOV AH, 11H
      MOV AL, 12H
      MOV BL, 0
      INT 10H
     END;

    Procedure Lines25; Assembler;
     ASM
      MOV AH, 11H
      MOV AL, 14H
      MOV BL, 0
      INT 10H
     END;

    Procedure Lines35; Assembler;
     ASM
      MOV AH, 11H
      MOV AL, 11H
      MOV BL, 0
      INT 10H
     END;

    Procedure Lines(S:String);
    Begin
     If Val(S)=50 then Lines50;
     If Val(S)=25 then Lines25;
     If Val(S)=35 then Lines35;
    End;

    Function Strip_(S:String):String;
    var B:Byte;
    begin
     For B:=1 to length(S) do if S[B]='_' then S[B]:=' ';
     Strip_:=S;
    end;

    Function Del(S:String; Index:Integer; Count:Integer):String;
    begin
     Delete(S,Index,Count);
     Del:=S;
    end;

    Function WhatDir:String;
    var s:String;
    begin
     GetDir(0,s);
     whatdir:=s;
    end;

    Function Str(X:integer):String;
    var S:String;
    Begin
     System.Str(X,S);
     Str:=S;
    End;

    Function StrL(X:LongInt):String;
    var S:String;
    Begin
     System.Str(X,S);
     StrL:=S;
    End;

    Function StrW(X:word):String;
    var S:String;
    Begin
     System.Str(X,S);
     StrW:=S;
    End;

    Function StrR(X:Real):String;
    var S:String;
    Begin
     System.Str(X,S);
     StrR:=S;
    End;

    Function Val(S:String):Integer;
    var A,B:Integer;
    begin
     System.Val(S,A,B);
     If B=0 then Val:=A else begin Val:=0; UError:=B; End;
    end;

    Function ValW(S:String):Word;
    var B:Integer;
        A:Word;
    begin
     System.Val(S,A,B);
     If B=0 then ValW:=A else begin ValW:=0; UError:=B; End;
    end;

    Function ValL(S:String):longint;
    var B:integer;
        A:longint;
    begin
     System.Val(S,A,B);
     If B=0 then Vall:=A else begin Vall:=0; UError:=B; End;
    end;

    Function Upstring(S:String):String;
    var
        I:Byte;
    begin
     for i := 1 to Length(s) do s[i] := UpCase(s[i]);
     Upstring:=S;
    end;

    Function LoCase(C:Char):Char;
    begin
     If (Ord(C)>64) and (Ord(C)<91) then
             LoCase:=Char(Ord(C)+32)
        else LoCase:=C;
    end;

    Function LoString(S:String):String;
    var
        I:Byte;
    begin
     for i := 1 to Length(s) do s[i] := LoCase(s[i]);
     Lostring:=S;
    end;

    Function NameCaps(S:String):String;
    var I:byte;
    begin
     S:=LoString(S);
     S[1]:=UpCase(S[1]);
     For I:=1 to Length(S) do
       If S[I]=' ' then
         if I<Length(S) then S[I+1]:=UpCase(S[I+1]);
     namecaps:=s;
    end;

    function FileExists(FileName: String): Boolean;
    { Boolean function that returns True if the file exists;otherwise,
     it returns False. Closes the file if it exists. }
    var
     F: file;
    begin
     {$I-}
     Filemode:=0;
     Assign(F, FileName);
     FileMode := 0;  {( Set file access to read only }
     Reset(F);
     Close(F);
     {$I+}
     FileExists := (IOResult = 0) and (FileName <> '');
    end;  { FileExists }

    Function Center(S:String; B:Byte):String;
    var A:Byte;
    Begin
     Repeat
      A:=Length(S) div 2;
      If A<(B Div 2) then S:=' '+S+' ';
     Until (Length(S) div 2)>=((B) Div 2);
     If Length(S)<B then S:=S+' ';
     Center:=S;
    End;

    Function Left(S:String; B:Byte):String;
    var A:Byte;
    Begin
     Repeat
      A:=Length(S);
      If A<B then S:=S+' ';
     Until Length(S)>=((B));
     While Length(S)>B do Delete(S,Length(S),1);
     Left:=S;
    End;

    Function  PadRight(S:String; B:Byte; C:Char):String;
    var A:Byte;
    Begin
     Repeat
      A:=Length(S);
      If A<B then S:=C+S;
     Until (Length(S)>=(B));
     PadRight:=S;
    End;

    Function Right(S:String; B:Byte):String;
    Begin
     Right:=PadRight(S,B,' ');
    End;

    Function Rep(S:String; C:Word):String;
    var W:Word;
        T:String;
    begin
     T:='';
     For W:=1 to C do T:=T+S;
     Rep:=T;
    end;

    Function StrBool(S:String):Boolean;
    begin
     S:=UpString(S);
     StrBool:=(Pos('T',S)>0);
    end;

    FUNCTION TempFile( Path: STRING ): STRING;
    VAR
     {$IFDEF WINDOWS}
       DateStr  : TDateTime;
     {$ELSE}
       DateStr  : DateTime;
     {$ENDIF}
       Trash    : WORD;
       Time     : LONGINT;
       FileName : STRING;
    Begin
     If (Path<>'') AND (Path[length(Path)]<>'\') Then Path := Path + '\';
     Repeat
      With DateStr Do
        Begin
         GETDATE( Year, Month, Day, Trash );
         GETTIME( Hour, Min, Sec, Trash );
        End;
      PackTime( DateStr, Time );
      {$R-,Q-}
      System.Str(Time,Filename);
      FileName := Copy(Filename,1,8);
      FileName := Filename+'.$$$';
      {$R+,Q+}
     Until Not FileExists(Path + FileName);
     TempFile := Path + FileName;
    END;

    Function WordWrap(S:String; Var Remainder:String; Len:Byte):String;
    Var W:String;
        I:Integer;
    begin
     If S[1]=' ' then delete(S,1,1);
     If Length(S)<=Len then
      begin
       WordWrap:=S;
       Remainder:='';
       Exit;
      end;

     For I:=Len downto 1 do
      begin
       If S[I]=' ' then
        begin
         WordWrap:=Copy(S,1,I);
         Remainder:=Copy(S,I,Length(S)-I+1);
         Exit;
        end;
      end;
    end;

    Function  AN(S:String):String;
    begin
     While S[1]=' ' do delete(S,1,1);
     If UPCASE(S[1]) IN ['A','E','I','O','U'] THEN INSERT('an ',S,1) ELSE
                                                   INSERT('a ',S,1);
     AN:=S;
    end;

    Function LastDrive: Char; Assembler;
    Asm
      mov   ah, 19h
      int   21h
      push  ax            { save default drive }
      mov   ah, 0Eh
      mov   dl, 19h
      int   21h
      mov   cl, al
      dec   cx
    @@CheckDrive:
      mov   ah, 0Eh       { check if drive valid }
      mov   dl, cl
      int   21h
      mov   ah, 19h
      int   21h
      cmp   cl, al
      je    @@Valid
      dec   cl            { check next lovest drive number }
      jmp   @@CheckDrive
    @@Valid:
      pop   ax
      mov   dl, al
      mov   ah, 0Eh
      int   21h           { restore default drive }
      mov   al, cl
      add   al, 'A'
    end;

    Function LongToHex(L:Longint):String;
    var S:string;
    begin
     ConvertBase(10,StrL(L),16,S);
     LongToHex:=S;
    end;

    End.

[Back to MAIL SWAG index] [Back to Main SWAG index] [Original]