Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/DBF2MEMO.ZIP/DBF2MEMO.PAS

Pascal/Delphi Source File | 1993-01-04 | 22.2 KB | 883 lines

{$C-}
{ Turbo Pascal program to copy dBASE III Char fields TO Memo files   }
{ By J. Troutman  74746,1567   5/8/85                                }
{ minor revisions 5/3/86 to allow proper access to dBASE III Plus files}
PROGRAM CharToMemo;

(* This program will copy designated character fields to a designated
   Memo field.  This was one of my early attempts at a Turbo Pascal
   program, so the code is rather rough at places.  However, it does
   show how to access both .DBF files and .DBT files.
   See DBF.PAS for some (slightly) more polished routines for
   accessing .DBF files.                                             *)

CONST
  VER = '1.01';
{Revised to fix incompatibility with dBASE III Plus files }

{  Start of Include file: GetStrng.pas}
(* GetStrng is a routine I used to use to validate user input.  There are
   several better routines for doing this in DL 1.  See EDIT.PAS (the one
   with uploaded with PPN [76703,3015] for a good example.               *)
{---------------------------------------------------------------------------}
TYPE
  Str80 = STRING[80];
  ValidChar = SET OF Char;

  PROCEDURE PutMessage(Message : Str80);
  VAR
    X, Y, L : Byte;

  BEGIN
  X := WhereX;
  Y := WhereY;
  L := Length(Message);
  IF L = 0 THEN
    BEGIN
    GoToXY(1, 25);
    ClrEol;
    END
  ELSE
    BEGIN
    GoToXY(((80-L) DIV 2), 25);
    Write(Message);
    END;
  GoToXY(X, Y);
  END;

  FUNCTION GetStrng(Valid : ValidChar;
                    InputLen, Row, Col : Byte;
                    Shift : Boolean) : Str80;

  CONST
    ErrorMessage : Str80 = 'Invalid key!  Please try again.';

  VAR
    Key : Char;
    Len : Byte;
    Mask,Temp : Str80;
    KeyError : Boolean;

  BEGIN
  Temp := '';
  KeyError := False;
  Len := 1;
  FillChar(Mask,SizeOf(Mask),$B0);
  Mask[0] := Chr(InputLen);
  GoToXY(Col, Row);
  Write(Mask);
  GoToXY(Col, Row);
  Read(Kbd, Key);
  WHILE Key <> ^M DO
    BEGIN
    IF Shift THEN Key := UpCase(Key);
    IF (Key IN Valid) AND (Len <= InputLen) THEN
      BEGIN
      Temp := Temp+Key;
      Len := Succ(Len);
      Write(Key);
      IF KeyError THEN
        BEGIN
        PutMessage('');
        KeyError := False;
        END;
      END
    ELSE
      BEGIN
      IF (Key = ^H) AND (Len <> 1) THEN
        BEGIN
        Len := Len-1;
        Write(^H+'_'+^H);
        Delete(Temp, Len, 1);
        IF KeyError THEN
          BEGIN
          PutMessage('');
          KeyError := False;
          END;
        END
      ELSE
        IF Key <> ^M THEN
          BEGIN
          KeyError := True;
          PutMessage(ErrorMessage);
          END;
      END;
    IF (InputLen = 1) AND (Len = 2) THEN
      Key := ^M
    ELSE
      Read(Kbd, Key);
    END;
  GetStrng := Temp;
  IF KeyError THEN PutMessage('');
  END;
{---------------------------------------------------------------------------}
{  End of Include File GetStrng.pas }

CONST
  BUFFSIZE = 25599;           { counting from 0 }
  MAX_BYTES_IN_RECORD = 4000; { dBASE III record limit }
  MAX_FIELDS_IN_RECORD = 128; { dBASE III field limit  }
  BYTES_IN_FILE_RECORD = 128; { Turbo BlockRead/Write default record  }
  BYTES_IN_MEMO_RECORD = 512; { dBASE III memo field record size }

TYPE
  HeaderType = ARRAY[0..31] OF Byte; { dBASE III header }
  FieldType = ARRAY[0..31] OF Byte; { dBASE III field definitions }
  DBFRecord = ARRAY[0..MAX_BYTES_IN_RECORD] OF Byte;
  Str255 = STRING[255];
  Str10 = STRING[10];
  BufferType = ARRAY[0..BUFFSIZE] OF Byte; { buffer for Block I/O }
  FileType = FILE;
  FieldRecord = RECORD
                  Name : Str10;
                  Typ : Char;
                  Len : Byte;
                  Dec : Byte;
                  Off : Integer;
                END;
  FieldArray = ARRAY[1..MAX_FIELDS_IN_RECORD] OF FieldRecord;
  MemoRecord = ARRAY[1..BYTES_IN_MEMO_RECORD] OF Byte;
  MemoFile = FILE OF MemoRecord;
  ChoiceArray = ARRAY[1..MAX_FIELDS_IN_RECORD] OF Integer;
  ByteFile = FILE OF Byte;

VAR
  InFile, OutFile : FILE;
  InBuffer, OutBuffer : BufferType;
  Header : HeaderType;
  FieldDesc : FieldType;
  Fields : FieldArray;
  DataRecord : DBFRecord;
  RemainingRecs : Real;
  NextMemo : Real;
  EndFile, FinalWrite : Boolean;
  NumberOfRecs : Real;
  MemoBuffer : MemoRecord;
  InMemo, OutMemo : MemoFile;
  CharChoice : ChoiceArray;
  LogicChoice, MemoChoice : Integer;
  Semicolon : Boolean;

  FUNCTION CheckKey : Boolean; { returns True if ^C pressed, False on   }
                               { any other key, pauses screen on ^S     }
  VAR
    Key : Char;

  BEGIN
  Read(Kbd, Key);
  CASE Key OF
    ^C : CheckKey := True;
    ^S : BEGIN
         Key := Chr(0);
         WHILE Key <> ^S DO Read(Kbd, Key);
         CheckKey := False;
         END;
  ELSE
  CheckKey := False;
  END;
  END;

  PROCEDURE PutB(VAR F : FileType;
                 VAR Buffer : BufferType;
                 B : Byte);

  CONST
    Recs : Integer = 25600;
    I : Integer = 0;

  BEGIN
  IF FinalWrite THEN
    BEGIN
    Recs := I;
    IF Recs <> 0 THEN BlockWrite(F, Buffer, Recs);
    END
  ELSE
    BEGIN
    Buffer[I] := B;
    I := Succ(I);
    IF I = Recs THEN
      BEGIN
      I := 0;
      BlockWrite(F, Buffer, Recs);
      END;
    END;
  END;

  FUNCTION GetB(VAR F : FileType;
                VAR Buffer : BufferType;
                VAR B : Byte) : Byte;

  CONST
    EndOfReads : Boolean = False;
    Recs : Integer = 25600;
    I : Integer = 25600;

  BEGIN
  IF (I = Recs) AND NOT EndOfReads THEN
    BEGIN
    I := 0;
    IF RemainingRecs < Recs THEN Recs := Trunc(RemainingRecs);
    {$I-} BlockRead(F, Buffer, Recs); {$I+}
    IF IOResult <> 0 THEN EndOfReads := True;
    RemainingRecs := RemainingRecs-Recs;
    IF RemainingRecs = 0 THEN EndOfReads := True;
    END;
  B := Buffer[I];
  GetB := B;
  I := Succ(I);
  IF EndOfReads AND (Succ(I) = Recs)
  THEN EndFile := True;
  END;

  FUNCTION CopyByte(VAR InFile, OutFile : FileType;
                    VAR InBuffer, OutBuffer : BufferType;
                    VAR B : Byte) : Byte;

  BEGIN
  PutB(OutFile, OutBuffer, GetB(InFile, InBuffer, B));
  CopyByte := B;
  END;

  PROCEDURE TootYourHorn;

  BEGIN
  NoSound;
  Sound(440); Delay(250); NoSound; Delay(20);
  Sound(440); Delay(250); NoSound; Delay(20);
  Sound(440); Delay(250); NoSound; Delay(20);
  Sound(352); Delay(1000); NoSound;
  END;

  FUNCTION OpenFile(VAR F : FileType; FileName : Str80) : Integer;

  BEGIN
  Assign(F, FileName);
  {$I-} Reset(F,1); {$I+}  {the '1' parameter sets the record size}
  OpenFile := IOResult;
  END;

  PROCEDURE CloseFiles;

  BEGIN
  PutB(OutFile, OutBuffer, 26);
  FinalWrite := True;
  PutB(OutFile, OutBuffer, 26);
  Close(OutFile);
  Close(InFile);
  Close(OutMemo);
  Close(InMemo);
  Halt;
  END;

  PROCEDURE HeaderError;

  BEGIN
  WriteLn;
  WriteLn('Database Header has been compromised.');
  WriteLn('I guess you will need someone better than I to fix this file!');
  CloseFiles;
  END;

  PROCEDURE Pause;

  BEGIN
  WriteLn;
  WriteLn('Press any key to continue . . .(^C to abort)');
  IF CheckKey THEN CloseFiles;
  END;

  PROCEDURE DisplayStructure(VAR FieldDesc : FieldType;
                             VAR Field : FieldRecord);

  VAR
    I : Integer;

  CONST
    Offset : Integer = 1;     {Offset of field within record }

  BEGIN
  WITH Field DO
    BEGIN
    I := 0;
    Name := '          ';
    REPEAT
    Name[Succ(I)] := Chr(FieldDesc[I]);
    I := Succ(I);
    UNTIL FieldDesc[I] = 0;
    Typ := Char(FieldDesc[11]);
    Len := FieldDesc[16];
    Dec := FieldDesc[17];
    Off := Offset;
    Offset := Offset+Len;
    Write('. ', Name, '    ', Typ, '      ', Len:3);
    IF Typ = 'N' THEN Write('     ', Dec:2);
    IF NOT(Typ IN ['C', 'N', 'L', 'M', 'D']) THEN HeaderError;
    END;
  END;

  PROCEDURE DisplayFields(VAR Fields : FieldArray;
                          FieldCount : Integer;
                          FTyp : Char);

  VAR
    I, R, C : Integer;
    S : Str80;

  BEGIN
  CASE FTyp OF
    'C' : S := 'Select one or more Character fields to convert to a Memo';
    'L' : S := 'Select a Logical field to indicate Memo presence';
    'M' : S := 'Select the destination Memo field';
  END;
  I := (80-Length(S)) DIV 2;
  Window(1, 1, 80, 25); ClrScr; GoToXY(1, 1);
  TextBackground(Yellow); TextColor(Blue); ClrEol;
  GoToXY(I, 1); Write(S);
  TextBackground(Blue); TextColor(Yellow);
  Window(1, 2, 80, 25); GoToXY(1, 1);
  R := 1; C := 1; I := 1;
  WHILE I <= FieldCount DO
    BEGIN
    WITH Fields[I] DO
      BEGIN
      IF Typ = FTyp THEN
        BEGIN
        GoToXY(C, R);
        Write(I:2, ' ', Name);
        R := Succ(R);
        IF R = 20 THEN C := C+15;
        IF C > 70 THEN BEGIN C := 1; Pause; ClrScr; END;
        END;
      END;
    I := Succ(I);
    END;
  END;

  FUNCTION GetField(FieldCount : Integer; S : Str80) : Integer;

  CONST
    Valid : ValidChar = ['0'..'9'];
  VAR
    I, Code : Integer;
    Done : Boolean;
    Response : Str80;

  BEGIN
  Window(1, 1, 80, 25);
  Done := False;
  WHILE NOT Done DO
    BEGIN
    GoToXY(1, 22); Write(S); I := Length(S)+1;
    Response := GetStrng(Valid, 3, 22, I, False);
    Val(Response, I, Code);
    IF (Code = 0) AND (I IN [0..FieldCount]) THEN
      BEGIN
      GetField := I;
      Done := True;
      END
    ELSE
      BEGIN
      GoToXY(10, 25);
      Write('Must be 0..', FieldCount:3);
      END;
    END;
  END;

  PROCEDURE SelectFields(VAR Fields : FieldArray;
                         FieldCount : Integer);

  VAR
    I, R, C, Code : Integer;
    Done, FinallyDone : Boolean;
    Response : Str80;
    Ch : Char;

  BEGIN
  FinallyDone := False;
  WHILE NOT FinallyDone DO BEGIN
  DisplayFields(Fields, FieldCount, 'C');
  Window(1, 22, 80, 25);
  ClrScr;
  I := 1; C := 1;
  Done := False;
  WHILE NOT Done DO
    BEGIN
    CharChoice[I] := GetField(FieldCount, 'Select Character fields:');
    IF CharChoice[I] = 0 THEN
      Done := True
    ELSE IF Fields[CharChoice[I]].Typ = 'C' THEN
      BEGIN
      GoToXY(C, 24);
      Write(CharChoice[I]:2, ',');
      C := C+3;
      I := Succ(I);
      END;
    END;
  Window(1, 1, 80, 25);
  ClrScr;
  I := 1;
  GoToXY(1, 1);
  WriteLn('The character fields you have chosen are:');
  WHILE CharChoice[I] <> 0 DO
    BEGIN
    WriteLn(CharChoice[I]:2, ' ', Fields[CharChoice[I]].Name);
    I := Succ(I);
    END;
  WriteLn('Are these fields correct? (Y/N)');
  Read(Kbd, Ch);
  IF UpCase(Ch) = 'Y' THEN FinallyDone := True;
  END;
  FinallyDone := False;
  WHILE NOT FinallyDone DO BEGIN
  DisplayFields(Fields, FieldCount, 'L');
  GoToXY(20, 20);
  Write('Choose one Logic field (not mandatory)');
  Window(1, 22, 80, 25);
  ClrScr;
  Done := False;
  WHILE NOT Done DO
    BEGIN
    LogicChoice := GetField(FieldCount, 'Select a Logic field:');
    IF LogicChoice = 0 THEN
      Done := True
    ELSE IF Fields[LogicChoice].Typ = 'L' THEN
      BEGIN
      Done := True;
      END;
    END;
  Window(1, 1, 80, 25);
  ClrScr;
  GoToXY(1, 1);
  IF LogicChoice > 0 THEN
    BEGIN
    WriteLn('The Logic field you have chosen is:');
    WriteLn(LogicChoice:2, ' ', Fields[LogicChoice].Name);
    END
  ELSE
    WriteLn('You have chosen no logic field.');
  WriteLn;
  WriteLn('Is this correct? (Y/N)');
  Read(Kbd, Ch);
  IF UpCase(Ch) = 'Y' THEN FinallyDone := True;
  END;
  FinallyDone := False;
  WHILE NOT FinallyDone DO BEGIN
  DisplayFields(Fields, FieldCount, 'M');
  GoToXY(20, 20);
  Write('Choose one Memo field ');
  Window(1, 22, 80, 25);
  ClrScr;
  Done := False;
  WHILE NOT Done DO
    BEGIN
    MemoChoice := GetField(FieldCount, 'Select a Memo field:');
    IF MemoChoice = 0 THEN
      BEGIN
      GoToXY(40, 23);
      Write('Must choose a Memo field');
      END
    ELSE IF Fields[MemoChoice].Typ = 'M' THEN
      Done := True;
    END;
  Window(1, 1, 80, 25);
  ClrScr;
  GoToXY(1, 1);
  WriteLn('The Memo field you have chosen is:');
  WriteLn(MemoChoice:2, ' ', Fields[MemoChoice].Name);
  WriteLn;
  WriteLn('Is this correct? (Y/N)');
  Read(Kbd, Ch);
  IF UpCase(Ch) = 'Y' THEN FinallyDone := True;
  END;

  END;                        {FinallyFinallyDone!}

  PROCEDURE DisplayHeader(VAR Header : HeaderType;
                          VAR RecordLength : Integer;
                          VAR HeaderLength : Integer);

  BEGIN
  WriteLn;
  WriteLn('Date of last update:  ', Header[2], '/', Header[3], '/', Header[1]);
  NumberOfRecs := (Header[4]*1)+
  (Header[5]*256)+
  (Header[6]*65536.0)+
  (Header[7]*16777216.0);
  WriteLn('Number of Records: ', NumberOfRecs:10:0);
  HeaderLength := Header[8]+(256*Header[9]);
  RecordLength := Header[10]+(256*Header[11]);
  END;

  PROCEDURE ReadMemo(VAR M : MemoFile;
                     VAR MemoBuffer : MemoRecord;
                     Ptr : Real);

  BEGIN
  LongSeek(M, Ptr);
  Read(M, MemoBuffer);
  END;

  PROCEDURE WriteMemo(VAR M : MemoFile;
                      VAR MemoBuffer : MemoRecord;
                      Ptr : Real);
  BEGIN
  LongSeek(M, Ptr);
  Write(M, MemoBuffer);
  FillChar(MemoBuffer, 512, #0);
  END;

  FUNCTION GetNextMemoPointer(VAR M : MemoFile) : Real;

  VAR
    MBuff : MemoRecord;

  BEGIN
  ReadMemo(M, MBuff, 0);
  GetNextMemoPointer := MBuff[1]*1.+
                        MBuff[2]*256.+
                        MBuff[3]*65536.+
                        MBuff[4]*16777216.;
  END;

  PROCEDURE PutM(VAR I : Integer; B : Integer);

  BEGIN
  MemoBuffer[I] := B;
  I := Succ(I);
  IF (I > 512) OR (B = 26) THEN
    BEGIN
    I := 1;
    WriteMemo(OutMemo, MemoBuffer, NextMemo);
    NextMemo := NextMemo+1;
    END;
  END;

  PROCEDURE PutMemo(VAR Memo : Str255);

  CONST
    I : Integer = 1;
    C : Integer = 1;

  VAR
    J, M : Integer;

    PROCEDURE EndOfLine;

    BEGIN
    PutM(I, $8D);
    PutM(I, $0A);
    C := 1;
    END;

  BEGIN
  M := Length(Memo);
  IF M <> 0 THEN
    BEGIN
    IF Memo = Chr(26) THEN
      BEGIN
      PutM(I, 26);
      C := 1;
      END
    ELSE
      BEGIN
      Memo := Memo+'*';
      J := 1;
      WHILE J <= M DO
        BEGIN
        IF C >= 65 THEN
          IF ((Memo[J] = ' ') AND (Memo[Succ(J)] <> ' '))
          OR (C >= 78) THEN EndOfLine;
        IF (Memo[J] = ';') AND (Semicolon) THEN
          EndOfLine
        ELSE
          BEGIN PutM(I, Ord(Memo[J])); C := Succ(C); END;
        J := Succ(J);
        END;
      END;
    END;
  END;

  PROCEDURE PutNextMemoPointer(VAR M : MemoFile; R : Real);

  VAR
    MBuff : MemoRecord;

  BEGIN
  FillChar(MBuff, 512, #0);
  MBuff[4] := Trunc(R/16777216.0);
  R := R-(MBuff[4]*16777216.0);
  MBuff[3] := Trunc(R/65536.0);
  R := R-(MBuff[3]*65536.0);
  MBuff[2] := Trunc(R/256);
  R := R-(MBuff[2]*256);
  MBuff[1] := Trunc(R);
  WriteMemo(M, MBuff, 0);
  END;

VAR
  RecordLength, FieldCount : Integer;

  PROCEDURE CopyOneRecord;

  VAR
    I, J, M, L : Integer;
    B : Byte;
    Memo : Str255;
    ThisMemo : Real;
    MemoPointer : Str10;
    MemoEntered : Boolean;

    PROCEDURE GetARecord;

    BEGIN
    I := 0;
    WHILE (I < RecordLength) AND (NOT EndFile) DO
      BEGIN
      DataRecord[I] := GetB(InFile, InBuffer, B);
      I := Succ(I);
      END;
    END;

    PROCEDURE PutARecord;

    BEGIN
    I := 0;
    WHILE (I < RecordLength) DO
      BEGIN
      B := DataRecord[I];
      PutB(OutFile, OutBuffer, B);
      I := Succ(I);
      END;
    END;

  BEGIN
  ThisMemo := NextMemo;
  GetARecord;
  I := 1; MemoEntered := False;
  WHILE CharChoice[I] <> 0 DO
    BEGIN
    WITH Fields[CharChoice[I]] DO
      BEGIN
      L := 1; Memo := ''; M := 0; J := Off;
      WHILE L <= Len DO
        BEGIN
        B := DataRecord[J];
        Memo := Memo+Chr(B);
        IF B <> 32 THEN M := L;
        L := Succ(L); J := Succ(J);
        END;
      IF M > 0 THEN
        BEGIN
        Memo[0] := Chr(M);
        Memo := Memo+' ';
        MemoEntered := True;
        WriteLn(Name, ' ', Memo);
        PutMemo(Memo);
        END;
      END;
    I := Succ(I);
    END;
  IF MemoEntered THEN
    BEGIN
    Memo := Chr(26);
    PutMemo(Memo);
    END;
  IF LogicChoice <> 0 THEN
    BEGIN
    IF MemoEntered THEN
      B := $59 {'Y'}
    ELSE
      B := $4E; {'N'}
    DataRecord[Fields[LogicChoice].Off] := B;
    END;
  IF MemoEntered THEN
    Str(ThisMemo:10:0, MemoPointer)
  ELSE
    Str(0:10, MemoPointer);
  J := Fields[MemoChoice].Off;
  FOR I := 1 TO 10 DO
    BEGIN
    DataRecord[J] := Ord(MemoPointer[I]);
    J := Succ(J);
    END;
  PutARecord;
  END;

  PROCEDURE SignOn;

  BEGIN
  ClrScr; GoToXY(10, 10);
  WriteLn('CTOM   -- a program to convert Char fields TO');
  GoToXY(20, 11); WriteLn('dBASE III Memo files (.DBT).');
  GoToXY(30, 13); WriteLn('Ver. ', VER);
  GoToXY(28, 15); WriteLn('by J. Troutman');
  GoToXY(20, 17); WriteLn('Ctrl-S Pauses -- Ctrl-C Aborts');
  GoToXY(1, 22); Pause;
  END;

VAR
  Found, Break : Boolean;
  HeaderLength, I, ByteCount : Integer;
  Col, Row : Integer;
  B : Byte;
  R, RecordCount : Real;
  InFileName, OutFileName, Response : Str80;

CONST
  ValidFileName :
  ValidChar = ['!', '#'..')', '-', '0'..'9', '@'..'Z', '_', '`', '{', '}', '~'];
  YesNo : ValidChar = ['Y', 'N'];

BEGIN                         { CharacterTOMemo }
EndFile := False; FinalWrite := False;
Break := False; Found := False; ByteCount := 0;
TextBackground(Blue);
TextColor(Yellow);
SignOn; ClrScr;
GoToXY(1, 5);
Write('Enter Source File Name (.DBF extension assumed): ');
WHILE NOT Found DO
  BEGIN
  InFileName := GetStrng(ValidFileName, 8, 5, 50, True)+'.DBF';
  IF OpenFile(InFile, InFileName) <> 0 THEN
    BEGIN
    GoToXY(1, 7);
    WriteLn('I cannot seem to find ', InFileName, '.');
    WriteLn('Could you run it by me again?');
    Pause; Window(1, 6, 80, 25); ClrScr; Window(1, 1, 80, 25);
    END
  ELSE Found := True;
  END;
RemainingRecs := LongFileSize(InFile);
GoToXY(1, 7);
WriteLn('There are ', RemainingRecs:7:0, ' bytes in ', InFileName, '.');
Found := False;
GoToXY(1, 10);
Write('Enter Destination File Name (.DBF assumed): ');
WHILE NOT Found DO
  BEGIN
  OutFileName := GetStrng(ValidFileName, 8, 10, 45, True)+'.DBF';
  GoToXY(1, 12);
  IF InFileName = OutFileName THEN
    Write('Sorry, but both files may not have the same name.')
  ELSE
    Found := True;
  END;
Assign(OutFile, OutFileName);
Rewrite(OutFile,1);
I := Length(InFileName);
InFileName[I] := 'T';
Assign(InMemo, InFileName);
{$I-} Reset(InMemo);          {$I-}
IF IOResult <> 0 THEN BEGIN WriteLn('Cannot find memo file'); Halt; END;
I := Length(OutFileName);
OutFileName[I] := 'T';
Assign(OutMemo, OutFileName);
Rewrite(OutMemo);
WriteLn(Output, 'Reading Header Data');
I := 0;
WHILE I < 32 DO BEGIN
Header[I] := CopyByte(InFile, OutFile, InBuffer, OutBuffer, B);
I := Succ(I);
ByteCount := Succ(ByteCount);
END;
WriteLn;
DisplayHeader(Header, RecordLength, HeaderLength);
Pause;
FieldCount := 0; Row := 1; Col := 1; ClrScr; GoToXY(Col, Row);
Write(' #  Field Name   Type  Length  Decimal');
Col := 41; GoToXY(Col, Row);
Write(' #  Field Name   Type  Length  Decimal');
Window(1, 2, 80, 25); Col := 1; ClrScr;
WHILE GetB(InFile, InBuffer, B) <> $0D DO
  BEGIN
  ByteCount := Succ(ByteCount);
  IF ByteCount > HeaderLength THEN HeaderError;
  I := 0;
  FieldDesc[I] := B;
  PutB(OutFile, OutBuffer, FieldDesc[I]);
  REPEAT
    I := Succ(I);
    FieldDesc[I] := CopyByte(InFile, OutFile, InBuffer, OutBuffer, B);
    ByteCount := Succ(ByteCount);
  UNTIL I = 31;
  FieldCount := Succ(FieldCount);
  GoToXY(Col, Row); Write(FieldCount:2);
  DisplayStructure(FieldDesc, Fields[FieldCount]);
  Row := FieldCount MOD 22+1;
  IF Row = 1 THEN
    IF Col = 41 THEN
      BEGIN
      Col := 1;
      GoToXY(1, 22);
      Pause;
      ClrScr;
      END
    ELSE
      Col := 41;
  IF KeyPressed THEN IF CheckKey THEN CloseFiles;
  END; {WHILE GetB(InFile, InBuffer, B) <> $0D}
PutB(OutFile, OutBuffer, B);  { the $0D byte }
GoToXY(1, 22);
ByteCount := Succ(ByteCount);
Write('          Total Length: ', RecordLength:4);

{The original dBASE III files inserted a NUL character after the $0D at the
 end of the header before the data began; Plus does not have this NUL
 character.  The following IF statement tests for the presence of the NUL.}

IF InBuffer[Succ(ByteCount)] = 0 THEN
  BEGIN
  B := CopyByte(InFile, OutFile, InBuffer, OutBuffer, B);
  ByteCount := Succ(ByteCount);
  END;
GoToXY(41, 22);
Write('HeaderLength  = ', HeaderLength);

{ After a dBASE file has been dConverted from II to III, there is frequently
  some muck left in the header until the file has been USEd in dBASE.  The
  following IF statement checks for the muck. }

IF HeaderLength > ByteCount THEN
  WHILE ByteCount < HeaderLength DO
    BEGIN
    B := CopyByte(InFile, OutFile, InBuffer, OutBuffer, B);
    ByteCount := Succ(ByteCount);
    END;

Pause;
SelectFields(Fields, FieldCount);
Window(1, 1, 80, 25); ClrScr; GoToXY(1, 10);
Write('Do you want semicolons converted to soft carriage returns?');
Response := GetStrng(YesNo, 1, 10, 60, True);
IF Response = 'Y' THEN Semicolon := True ELSE Semicolon := False;
NextMemo := GetNextMemoPointer(InMemo);
R := 0;
WHILE R < NextMemo DO
  BEGIN
  ReadMemo(InMemo, MemoBuffer, R);
  WriteMemo(OutMemo, MemoBuffer, R);
  R := R+1;
  END;
RecordCount := 0; Window(1, 1, 80, 25); ClrScr; GoToXY(1, 25);
TextBackground(Yellow); TextColor(Blue); ClrEol;
GoToXY(15, 25); Write('Ctrl-S to Pause     Ctrl-Break or Ctrl-C to abort');
TextBackground(Blue); TextColor(Yellow);
Window(1, 1, 80, 4); GoToXY(1, 2);
Write('Record Number:         1 of ', NumberOfRecs:10:0);
Write('  Next Memo Pointer:', NextMemo:10:0);
WHILE (NOT EndFile) AND (NOT Break) AND (RecordCount < NumberOfRecs) DO
  BEGIN
  RecordCount := RecordCount+1;
  Window(1, 1, 80, 4);
  GoToXY(15, 2); Write(RecordCount:10:0);
  GoToXY(60, 2); Write(NextMemo:10:0);
  Window(1, 5, 80, 24); ClrScr; GoToXY(1, 1);
  CopyOneRecord;
  PutNextMemoPointer(OutMemo, NextMemo);
  IF KeyPressed THEN Break := CheckKey;
  END;
TootYourHorn;
CloseFiles;
END.