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

    {P
     MM> QWK:
     MM> Can anybody write for me or send me a unit that reads QWK packets???

    I've wrote my one:
    NOTE: Here some bugs can be found.Report me as soon as you check that.

    ---8<--- Begin QWKUSE.PAS ---8<--- }

    Unit QWKUse;

    Interface

    USES DOS,CRT;

    Type QWKHead=Record
         NOM :ARRAY [0..6] Of Char;
         Date:ARRAY [7..$e] Of Char;
         Time:ARRAY [$f..$13] Of Char;
         to_:ARRAY [$14..$2c] Of Char;
         From:ARRAY [$2d..$45] Of Char;
         Subj:ARRAY [$46..$6a] Of Char;
         NOR :ARRAY [$6b..$72] Of Char;
         NOMB:ARRAY [$73..$78] Of Char;
         Res :ARRAY [$79..$7e] Of Char;
         End;
         MessageBlock=Array[1..128] Of CHAR;

    CONST CrLf=#13#10;

    Function GetMessageLength(msg:QWKHead):BYte;
    Procedure GetMessageTime(msg:QWKHead;Var Hour,Minute:Byte);
    Procedure GetMessageDate(msg:QWKHead;Var DD,MM,YY:Word);
    Function MessageNumber(msg:QWKHead):Word;
    Function  NumberOfReplay(msg:QWKHead):WORd;
    Function  Replay(msg:QWKHead):Boolean;
    Procedure NormalCrLf(Var s:String);
    Procedure DelChr(c:Char;S:String);

    Implementation

    Procedure DelChr;
    Var a:Byte;
    Begin
    For a:=1 To Length(s) Do If s[a]=c Then Begin Delete(s,a,1);Dec(a);End;
    End;

    Function GetMessageLength;
    Var s:String;
        c:Integer;
        len:Byte;
    Begin
    s:='';
    s:=s+msg.nomb;
    DelChr(' ',s);
    Val(s,len,c);
    Dec(Len);
    GetMessageLength:=len;
    End;

    Procedure GetMessageTime(msg:QWKHead;Var Hour,Minute:Byte);
    Var s,s1:String;
        c:INteger;
    Begin
    s1:='';s1:=s1+msg.time;
    s:=Copy(s1,1,2);
    Delete(s1,1,3);
    Val(s,hour,c);
    Val(s1,Minute,c);
    End;

    Procedure GetMessageDate(msg:QWKHead;Var DD,MM,YY:Word);
    VAR s,s1:String;
        c:INteger;
    Begin
    s1:='';s1:=s1+msg.date;
    s:=Copy(s1,1,2);
    Delete(s1,1,3);
    Val(s,mm,c);
    s:=Copy(s1,1,2);
    Delete(s1,1,3);
    Val(s,dd,c);
    Val(s1,yy,c);
    End;

    Function  MessageNumber(msg:QWKHead):Word;
    Var s:String;
        w:Word;
        c:Integer;
    Begin
    s:=msg.nom;
    DelChr(' ',s);
    Val(s,w,c);
    MessageNumber:=w;
    End;

    Function  NumberOfReplay(msg:QWKHead):WORd;
    Var s:String;
        w:Word;
        c:Integer;
    Begin
    s:=msg.nor;
    DelChr(' ',s);
    Val(s,w,c);
    NumberOfReplay:=w;
    End;

    Function  Replay(msg:QWKHead):Boolean;
    Begin
    Replay:=NumberOfReplay(msg)<>0;
    End;

    Procedure NormalCrLf(Var s:String);
    Var b,a:Byte;
    BEgin
    b:=Pos('',s);
    While b<>0 Do Begin Delete(s,b,1);Insert(crlf,s,b);b:=Pos('',s);End;
    End;

    End. ---8<---  End QWKUSE.PAS  ---8<---

    And here is example of usage:

    ---8<--- Begin QWKPMG.PAS ---8<---
    Program QWK_PMG;
    Uses CRT,Objects,PMG_Str1,QWKuse;

    Const box:Array [1..5] Of String=(
          'From:',
          'To  :',
          'Subj:',
          'Date:',
          'Time:');

    VAR Mes:Array [1..700] OF PString;
        MsgPtr:Array [1..100,1..2] Of LongINT;
        f2,f1:File;
        current,Total:Word;
        Header:QWKHEAD;
        a:Integer;
        c:Char;

    Function FillStr(c:Char;a:Byte);
    Var S:String;
        b:Byte;
    Begin
    s:='';
    For b:=1 To a s:=s+c;
    FillStr:=s;
    End;

    Procedure Draw;
    Var fields:Array [1..5] Of String;
        a:Byte;
    Begin
    Fields[1]:=''+Header.from;
    Fields[2]:=''+Header.To_;
    Fields[3]:=''+Header.Subj;
    Fields[4]:=''+Header.Date;
    Fields[5]:=''+Header.Time;
    TextColor(Cyan);
    For a:=1 To 5 Do WriteLn(box[a]);
    TextColor(Red);GotoXY(40,1);Write('Message ');
    TextColor(White);Write(Current);TextColor(red);
    Write(' of ');TextColor(White);Write(TOtal);
    TextBackGround(White);TextColor(Black);GotoXy(1,25);
    Write('"+" - next message  "-" - previouse message.',FillStr(' ',35));
    TextBackGround(Black);
    TextColor(LightGreen);
    For a:=1 To 5 Do
        Begin
        GotoXY(6,a);Write(fields[a]);
        End;
    TextColor(White);WriteLn(Crlf,FillSTR('Ä',79),CrLf);
    End;

    Procedure ReadMsg(n:LongInt);
    Var b,a:Byte;
        CurMsgPtr:LongInt;
        MsgBuf:MESsageBlock;
        s:String;
    Begin
    Current:=n;
    Seek(f1,MSgPtr[n,2]);
    BlockRead(f1,Header,SizeOf(Header));
    ClrScr;
    Draw;
    b:=0;
    FOR a:=1 To GetMessageLength(Header) Do
        BEGin
        BlockRead(f1,MsgBuf,128);
        s:='';s:=s+MsgBuf;
        NormalCrLf(s);
        While (Pos(CrLf,s)<>0) Or (s<>'') Do
              BEGin
                   Inc(b);
                   DisposeStr(MES[b]);
                   While Pos(CrLf,s)=1 Do Delete(s,1,2);
                   If Length(s)=0 Then s:=' ';
                   If Pos(CrLf,s)<>0 Then Mes[b]:=NewStr( Copy(s,1,Pos(CrLf,s)-1)
    )               Else Mes[b]:=NewStr(s);
                   If pos('>',Mes[b]^)<>0 Then TextColor(LightGray) Else
    TextColor(Cyan);               IF Pos(CrLf,s)<>0 Then WriteLn(Mes[b]^) Else
    Write(Mes[b]^) ;               If WhereY>22 Then
                      Begin
                           GotoXY(1,WhereY+1);
                           Write('Press any key to continue ...');
                           ReadKEY;
                           ClrScr;
                           Draw;
                      End;
                   If Pos(CrLf,s)<>0 Then Delete(s,1,Pos(CrLf,s)+1) Else s:='';

              End;

        End;
    End;

    Procedure InitPStrings;
    Var a:Word;
        s:String;
    Begin
    s:=FillSTR(' ',128);
    For a:=1 To 700 DO Mes[a]:=NewStr(s);
    End;

    Procedure InitMsgBase;
    Var a:word;
    Begin
    Seek(f1,$81);
    a:=1;
    While Not Eof(f1) Do
          Begin
               MsgPtr[a,2]:=FilePos(f1);
               BlockRead(f1,Header,SizeOf(Header));
               MsgPTR[a,1]:=MessageNumber(Header);
               Seek(f1,Filepos(f1)+128*GetMessageLength(Header)+1);
               Inc(a);
          End;
    Total:=a-1;
    END;

    Begin
    Assign(f1,'messages.dat');
    Reset(f1,1);
    InitMsgBase;
    a:=1;
    REpeat
    ReadMsg(a);
    c:=ReadKey;
    If c='+' Then Inc(A);
    If c='-' Then Dec(A);
    If a<1 Then a:=Total;

    if a>Total Then a:=1;

    UNTIL c=#27;
    End. ---8<---  End QWKPMG.PAS  ---8<---

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