第三章 实用程序

第三章 实用程序
本章提供了12个用TURBO PASCAL编写的实用程序,包括软锁驱动器的程序、锁硬盘逻辑分区的程序、稿纸排版打印程序、源程序列表程序、查找并替换程序、备份硬盘主引导记录程序、四通-PC文本文件双向转换程序、SPT文件和BMP文件的双向转换程序、数据库文件打卡程序、BATCH文件转换为COM文件的程序、机密文件的有效销毁程序、释放内存程序等12个。下面具体介绍每个程序的编写原理和使用方法。

§3.1 软锁驱动器程序

一般286或386微机都有一个容量极大的硬盘，为使用方便，在硬盘上要安装许多系统软件和专用软件，同时还有很多用户开发的应用程序，由于DOS系统的安全性比较差，软件、程序或数据往往容易被他人非法复制。怎样才能防止他人非法复制呢? 人们想出许多方法，其中有给硬盘加口令字，使子目录名变为隐含等多种方法，我向大家介绍一种使逻辑驱动器失效的防拷贝方法。巧妙地使用本节提供的程序，计算机从硬盘启动后，可以使软驱(包括A、B驱)均失效，当在C:/>提字符下打入A:并回车，则显示“Invalid drive specification”，键入B:时，同样显示此信息。这样在不得到许可时，非法用户是很难拷贝程序和软件的。

§3.1.1 获得驱动器路径表的方法

获得驱动器路径表需要用到未编入文档的DOS功能调用52H，该功能调用的用途是得到内部缓冲器的指针，该指针指向的表描述了与存储子系统有关的大多数DOS内部结构，返回指针存在ES:BX中。这个缓冲区的结构随DOS的主要版本而异，对DOS3.XX及以上版本，此表的偏移16H处为指向驱动器路径的远指针。
驱动器路径表由多个表项组成，每个表项均包含缺省值路径、磁头位置和各种标志和指针，表项的数目等于有效逻辑驱动器数加1，最后一表项的标志变量为零，没有任何有用数据。驱动器路径表项的结构如表3-1。
表3-1.驱动器路径表项的结构
殌┌────┬─────┬───────────────────────┐
│偏 移 │ 长 度 │ 说 明 │
├────┼─────┼───────────────────────┤
│ 0 │ 字 节 │ ASCIIZ格式的当前缺省值路径名,包含着逻辑驱动 │
│ │ (64) │ 器字母、冒号分隔符和起始符"/" │
│40H │ 双 字 │ 保留,置为0 │
│44H │ 字 节 │ 标志变量,所有有效项包含一个40H,最后一项包含0 │
│45H │ 双 字 │ 逻辑驱动器参数块的远指针 │
│49H │ 字 │ 此逻辑驱动器的当前块或磁道/扇区编号 │
│4BH │ 双 字 │ 远指针 │
│4FH │ 字 │ 未知存储 │
└────┴─────┴───────────────────────┘
殣 从表3-1可知，在驱动器路径表每个表项的偏移44H处的一个字节为该逻辑驱动器是否有效的标志，有效时为40H，为其它值则无效，所以要逻辑驱动器失效可以通过DOS功能调用52H，来修改这个标志为0即可。
作者用TURBO PASCAL和TASM编写一个程序SL.PAS，可以用来修改逻辑驱动器路径表，使逻辑驱动器失效和有效，源程序清单附后。

§3.1.2 使用方法

该程序采用命令行格式:
SL [d:] [/switch]
其中d代表驱动器,switch为开关,可取L和U,取时L执行锁驱动器过程,取U时解锁已锁的驱动器。典型用法：
SL -- 显示程序的帮助信息
SL C: -- 显示C逻辑盘的当前状态
SL C: /L -- 锁C逻辑盘
SL C: /U -- 解锁C逻辑盘
该程序只能在MS DOS 3.0以上的操作系统下工作。在对逻辑驱动器解锁时，程序提示输入口令，程序设定的口令是“ABCDEF”，在SOFTLOCK.ASM的源程序中可以找到。

§3.1.3 作用与效果

. 防止他人非法拷贝软件、程序或数据。
. 预防病毒的入侵：因为非机器管理人员在未得到许可时无法使用软驱，从而可以减少病毒入侵的机会。
该程序经过我的长期使用，非常有效，而且减少了病毒的入侵机会。每当交换数据前，我们均用防毒软件对软盘进行消毒，以致于病毒很难侵入系统，这对系统的安全和数据的保密都有很好的效果。

§3.1.5 源程序清单

程序1: SL.PAS

{ }
{ SL.PAS 1.0 }
{ Copyright (C) 1991 Dong Zhanshan }

program SoftLock;

var Drive,Switch: Char;

{$L SOFTLOCK}
procedure DriveState;
External;

procedure LockDrive;
External;

procedure UnLockDrive;
External;

function GetDriveNum: Byte;
External;

procedure Help;
begin
WriteLn('Syntax: SL [d:] [/Switch]');
WriteLn('Switch: /L = Lock the drive d:');
WriteLn(' /U = Unlock the drive d:');
WriteLn('Examples: SL -- Display help text');
WriteLn(' SL C: -- Display the state of drive C');
WriteLn(' SL C: /L -- Lock the drive C');
WriteLn(' SL C: /U -- Unlock the drive C');
WriteLn('Note: Only Using in MS DOS 3.0 and over');
end;

procedure Works;
begin
case Switch of
'L' : LockDrive;
'U' : UnLockDrive;
else WriteLn('The switch is invalid !');
end;
end;

procedure WriteError;
begin
WriteLn('The parameter is error !');
Writeln;
Help;
Halt;
end;

procedure GetParameter;
var TempStr: String[2];
TempChar: Char;
begin
if ParamCount > 0 then
begin
TempStr := ParamStr(1);
if TempStr[2] = ':' then
begin
TempChar := UpCase(tempstr[1]);
if TempChar in ['A'..'Z','a'..'z'] then
Drive := TempChar
else
WriteError;
end
else
WriteError;
end;
if ParamCount > 1 then
begin
TempStr := ParamStr(2);
if TempStr[1] = '/' then
begin
TempChar := UpCase(TempStr[2]);
if TempChar in ['L','U'] then
Switch := TempChar
else
WriteError;
end
else
WriteError;
end;
end;

begin
WriteLn('SL version 1.0 Copyright (c) 1991 Dong Zhanshan');
GetParameter;
if (Ord(Drive) >= 65) then
if (Ord(Drive) - 64 > GetDriveNum) then WriteError;
case ParamCount of
0 : Help;
1 : DriveState;
2 : Works;
else WriteError;
end;
end.

程序2: SOFTLOCK.ASM

; Turbo PASCAL 4.0-6.0
; Turbo Assembler include file for SL.PAS program
; Copyright (C) 1991 Dong Zhanshan

Title SoftLock
LOCALS @@

DOSSEG
.MODEL TPASCAL
.DATA
EXTRN Drive: Byte
.CODE
UnLockMsg1 DB 0dh,0ah,'Your password is correct, '
DB 'the drive is unlocked !',0dh,0ah,'$'
UnLockMsg2 DB 0dh,0ah,'Your password is not correct, '
DB 'the drive cannot be unlocked !',0dh,0ah
db 'Please ask system manager to get the password !'
db 0dh,0ah,'$'
LockState db 'The state of the drive is locked !',0dh,0ah,'$'
UnLockState db 'The state of the drive is unlocked !',0dh,0ah,'$'
LockMsg db 'This drive has been locked!',0dH,0ah,'$'
YourPsWd db 6 dup (0)
PsWdStr db 'ABCDEF'
PsWdMsg db 'Enter the PASSWORD : $'

;Function GetDriveNum:byte;

PUBLIC GetDriveNum

GetDriveNum:
push bp
sub ax,ax
mov ah,52h
int 21h
sub ah,ah
mov al,es:[bx+20h]
pop bp
ret

; Procedure DriveState;

PUBLIC DriveState

DriveState:
CALL GetAddress
MOV AX,ES:[BX]
CMP AX,40H
JNE @@1
mov dx,offset UnLockState
call DisplayMessenge
JMP @@2
@@1: mov dx,offset LockState
call DisplayMessenge
@@2: RET

; Procedure LockDrive

PUBLIC LockDrive

LockDrive:
CALL GetAddress
MOV AH,00
MOV ES:[BX],AH
MOV DX,OFFSET LockMsg
call DisplayMessenge
RET

; Procedure UnLockDrive

PUBLIC UnLockDrive

UnLockDrive:
CALL PassWord
CMP AL,01
JNE @@1
CALL GetAddress
MOV AH,40H
MOV ES:[BX],AH
mov dx,offset UnLockMsg1
call DisplayMessenge
JMP @@2
@@1:
mov dx,offset UnLockMsg2
call DisplayMessenge

@@2: RET

; Get Drive path address
; IN none
; OUT ES = Segment
; BX = Offset

GetAddress:
SUB AX,AX
MOV AH,52H
INT 21H
MOV AX,ES:[BX+18H]
PUSH AX
MOV AX,ES:[BX+16H]
MOV BX,AX
POP ES
sub ch,ch
mov cl,Drive
mov al,41h
sub cl,al
inc cl
@@1: ADD BX,51H
LOOP @@1
SUB BX,0dH
RET

; Get a password and check it
; IN none
; OUT none
; al = 0 --- invalid password
; al = 1 --- valid password

PassWord:
MOV DX,OFFSET PsWdMsg
call DisplayMessenge
MOV CX,06H
MOV BX,00H
@@1: MOV AH,00
INT 16H
MOV YourPsWd[BX],al
CALL WriteXChar
INC BX
LOOP @@1
MOV CX,06H
MOV BX,00H
@@2: MOV AL,YourPsWd[BX]
cmp PsWdStr[BX],AL
JNE @@3
INC BX
LOOP @@2
MOV AL,01H
JMP @@4
@@3: MOV AL,00
@@4: RET

; Write a char 'X' in current cursor on screen
; IN none
; OUT none

WriteXChar:
PUSH AX
PUSH BX
PUSH CX
MOV AH,0AH
MOV AL,'X'
MOV BH,00
MOV CX,1
INT 10H
MOV AH,03
MOV BX,00
INT 10H
INC DX
MOV AH,02
INT 10H
POP CX
POP BX
POP AX
RET

;Display messenge
;in DX = offset address
;out none

DisplayMessenge:
push ds
push cs
pop ds
mov ah,09h
int 21h
pop ds
ret

END

§3.2 锁硬盘逻辑盘程序

随着微处理器的更新换代，目前一般的中高档微机均配备有一个容量很大的硬盘机，小则几十MB，多则上百MB。在硬盘上要同时安装许多公用软件和用户文件，通常用户文件大多是个人的私有信息，不愿让他人随意查看和复制。报刊上介绍了多种硬盘的加密方法，多数是独占整个硬盘，禁止让不知道口令的用户使用。本人通过对硬盘逻辑盘结构的详细分析，提出了对硬盘的一个逻辑盘进行加密的有效方法，达到了独占一个硬盘逻辑盘的目的，从而圆满地解决了上述问题。

§3.2.1 逻辑盘的内部结构

FDISK把硬盘主引导记录存放在硬盘的第一个物理扇区，即0面0柱1扇区，在该扇区的1BEH-1FDH处(共64个字节)是硬盘的分区表，我们称这个分区表为主分区表，它由4个16字节的登记项组成，每个登记项描述一个特定的分区，其中各字节代表的意义见表3-2。
表3-2.分区表登记项各字节的意义
殌┌──┬──┬───────┬──┬───────┬───┬───┐
│ 意 │启动│ 分区开始 │系统│ 分区结束 │相对扇│扇 区 │
│ 义 │标志│头 扇区 柱体│标志│头 扇区 柱体│区数 │总 数 │
├──┼──┼───────┼──┼───────┼───┼───┤
│偏移│ 00 │01 02 03 │ 04 │05 06 07 │08-11 │12-15 │
└──┴──┴───────┴──┴───────┴───┴───┘
殣其中“系统标志”字节可以取以下不同的值：
01：DOS分区，该分区FAT表每项为12位；
02：XENIX分区；
04：DOS分区，该分区FAT表每项为16位；
05：扩展DOS分区；
06：大DOS分区，为MS DOS 4.00以上DOS版本在管理大于32MB盘或逻辑分区时所使用的标志，分区的FAT表每项为16位。
MS/PC DOS 3.30的FDISK程序把初始DOS分区信息放在主分区表的第一个登记项，而第二个登记项为扩展DOS分区信息，其余登记项为空。初始DOS分区代表C逻辑盘，扩展DOS分区的划分要根据它自己的分区表而定。扩展DOS分区的第一个扇区上记录有该扩展DOS分区的划分信息，这个分区被称为第一扩展DOS分区表，其中的第一个登记项记录着D逻辑盘的信息，第二个登记项记录了第二个扩展DOS分区的信息；第二个扩展DOS分区的第一个扇区记录了该扩展DOS分区的信息，其第一个登记项记录了E逻辑盘的信息，第二个登记项记录了第三个扩展DOS分区的信息；依此类推，可以找到所有扩展分区的信息。表3-3列出了一个62MB硬盘的所有分区信息。由表3-3可以知道，FDISK把硬盘的分区信息，以链表格式存放在硬盘的不同物理扇区上，每一个逻辑盘均有一个对应的分区信息表，且与一个物理扇区一一对应，如C盘与0面0柱1扇区对应，D盘与0面90柱1扇区对应。
表3-3.一个62MB硬盘分区信息表
殌┌────┬───┬──┬─────┬─────┬───┬───┬──┐
│ 定 位 │系 统│启动│ 分区开始 │ 分区结束 │相 对│总扇│逻辑│
│面 柱 扇│标 志│标志│面 柱 扇│面 柱 扇│扇 区│区 数│ 盘 │
├────┼───┼──┼─────┼─────┼───┼───┼──┤
│0 0 1│DOS-12│Yes │1 0 1 │7 89 26│ 26│ 18694│ C │
│ │EXTEND│No │0 90 1 │7 613 26│ 18720│108992│ │
├────┼───┼──┼─────┼─────┼───┼───┼──┤
│0 90 1│DOS-16│No │1 90 1 │7 289 26│ 26│ 41574│ D │
│ │EXTEND│No │0 290 1 │7 389 26│ 41600│ 20800│ │
├────┼───┼──┼─────┼─────┼───┼───┼──┤
│0 290 1│DOS-16│No │1 290 1 │7 389 26│ 26│ 20774│ E │
│ │EXTEND│No │0 390 1 │7 613 26│ 62400│ 46592│ │
├────┼───┼──┼─────┼─────┼───┼───┼──┤
│0 390 1│DOS-16│No │1 390 1 │7 613 26│ 26│ 46566│ F │
└────┴───┴──┴─────┴─────┴───┴───┴──┘
殣
§3.2.2 硬盘数据保密的原理

DOS对逻辑盘的管理是通过一个单链将若干个相互独立的连续盘区联系起来，每个连续的盘区均有一套完整的分区引导记录、FAT、文件目标和数据区。DOS在启动过程中，根据每个分区表中每个登记项的系统标志字节的内容来识别逻辑分区，如果该字节的值为DOS分区的有效值，则DOS将其视为有效分区，系统启动后，用户通过一逻辑盘使用这个分区；否则认为是无效分区，系统启动后，不为这个分区分配逻辑盘符，用户也就无法使用此分区，其数据也就暂时“隐含”起来了。
根据上述原理，我们可以使用BIOS提供的13H号中断完成硬盘分区表的读写和系统标志字节的更改，实现逻辑分区的锁闭与解锁，达到个人数据和机密数据的安全与保密。

§3.2.3 程序设计及其使用方法

程序设计的基本思路是：首先把分区表链读入内存，分析各分区的状态，根据用户的要求，若对某一分区加锁，则判断该分区的当前状态，如已锁，则返回，否则，对代表该分区的登记项的系统标志字节求反，提示用户输入口令，最后将修改了的分区表写回对应的物理扇区，重新启动机器后，该分区就“消失”了；解锁的过程基本同上，不过多了一道校验口令的过程。
本人应用TURBO PASCAL编写了一个程序HDL.PAS，经过编译生成执行文件后，在DOS系统下直接运行，能方便地完成硬盘逻辑分区的锁闭与解锁，并且可以加上用户自己的口令，某逻辑盘锁了以后，不知道口令的用户是无法打开的。
程序的使用方法很简单，其使用格式为:
HDL
其中d为逻辑分区对应的盘符，如C、D等，switch为选择开关，可以选：
L -- 为锁逻辑分区;
U -- 为解锁逻辑分区;
尖括号代表参数可以缺省。例如直接执行“HDL”显示程序的帮助信息；执行“HDL D:”显示D逻辑盘的当前状态；执行“HDL D: /L”锁D逻辑盘。

 

§3.2.4 源程序清单

{ HDL.PAS 1.1 }
{ Copyright (c) 1992,94 Dong Zhanshan }

program Hard_Disk_Lock;

{ This program may lock or unlock a logical partition }
{ of the hard disk. It was written by Dong Zhanshan in }
{ 1992.8 at CRI. }

uses disk;

var
{ store all partition information }
Buffer : array[1..24] of MBRT;
{ store states of all logical drive }
DriveState : array[1..24] of Boolean;
{ the number of logical drives }
DriveNum : byte;
Switch,Drive : char;

procedure reboot;
inline($EA/$00/$00/$FF/$FF); { jmp FFFF:0000 }

function readkey:char;
inline($b4/$07/ { mov ah,07 }
$cd/$21); { int 21h }

procedure Help; { the help information of this program }
begin
WriteLn('Syntax: HDL [d:] [/Switch]');
WriteLn('Switch: L = Lock the specifed drive');
WriteLn(' U = Unlock the specifed drive');
WriteLn('Examples: HDL -- Display help text');
WriteLn(' HDL D: -- Display the state of drive D:');
WriteLn(' HDL D: /L -- Lock the drive D:');
WriteLn(' HDL D: /U -- Unlock the drive D:');
end;

function FindExtendedPartition(p1:MBRT):byte;
{ find the position of extended dos partition }
var i : byte;
begin
FindExtendedPartition := 0;
for i := 1 to 4 do
begin
if (p1.PartitionTable[i].SysIndicator = 5)
or (not p1.PartitionTable[i].SysIndicator = 5)
then
begin
FindExtendedPartition := i;
exit;
end;
end;
end;

function FindDosPartition(p1:MBRT):byte;
{ find the position dos partition }
var i : byte;
begin
FindDosPartition := 0;
for i := 1 to 4 do
begin
if (p1.PartitionTable[i].SysIndicator in [1,4,6])
or (not p1.PartitionTable[i].SysIndicator in [1,4,6])
then
begin
FindDosPartition := i;
exit;
end;
end;
end;

procedure WriteError(S : string);
begin
WriteLn(S);
Halt;
end;

function ReadPassWord:string;
var ch : char;
tstr : string[6];
done : boolean;
i : byte;
begin
done := false;
i := 0;
tstr := '';
repeat
ch := readkey;
case ch of
#0 : ch := readkey;
#13 : done := true;
#27 : begin
done := true;
tstr := '';
end;
else begin
inc(i);
tstr := tstr + ch;
write('X');
if i = 6 then done := true;
end;
end;
until done;
ReadPassWord := Tstr;
end;

procedure SetPassword(var p1:MBRT);
var tstr1,tstr2 : string[6];
i : byte;
begin
for i := 0 to 6 do
begin
tstr1[i] := #0;
tstr2[i] := #0;
end;
repeat
write('Please enter password: ');
tstr1 := ReadPassWord;
writeln;
write('Please enter password again: ');
tstr2 := ReadPassWord;
writeln;
until tstr1 = tstr2;
move(tstr1[0],p1.MainBoot[439],7);
end;

function GetPassword(p1:MBRT) : boolean;
var tstr1,tstr2 : string[6];
i : byte;
begin
GetPassWord := false;
for i := 0 to 6 do
begin
tstr1[i] := #0;
tstr2[i] := #0;
end;
write('Please enter password: ');
tstr1 := ReadPassWord;
writeln;
move(p1.MainBoot[439],tstr2[0],7);
if tstr1 = tstr2 then GetPassWord := true;
end;

procedure LockDrive;
var StartCyl,StartSec : byte;
i,j : byte;
p : MBRT;
begin
i := ord(Drive) - ord('C') + 1;
if DriveState[i] then
begin
if i = 1 then
begin
StartCyl := 0;
StartSec := 1;
end
else
begin
j := FindExtendedPartition(Buffer[i-1]);
StartCyl := Buffer[i-1].PartitionTable[j].StartCylinder;
StartSec := Buffer[i-1].PartitionTable[j].StartSector;
end;
j := FindDosPartition(Buffer[i]);
Buffer[i].PartitionTable[j].SysIndicator :=
not Buffer[i].PartitionTable[j].SysIndicator;
SetPassWord(Buffer[i]);
p := Buffer[i];
ProcessPhysicalSector(3,$80,0,StartCyl,StartSec,1,p);
writeln('The drive ',Drive,': has been locked !');
reboot;
end
else
writeln('The drive ',Drive,': is locked !');
end;

procedure UnlockDrive;
var StartCyl,StartSec : byte;
i,j : byte;
p : MBRT;
begin
i:= ord(Drive) - ord('C') + 1;
if not DriveState[i] then
begin
if GetPassWord(Buffer[i]) then
begin
if i = 1 then
begin
StartCyl := 0;
StartSec := 1;
end
else
begin
j := FindExtendedPartition(Buffer[i-1]);
StartCyl := Buffer[i-1].PartitionTable[j].StartCylinder;
StartSec := Buffer[i-1].PartitionTable[j].StartSector;
end;
j := FindDosPartition(Buffer[i]);
Buffer[i].PartitionTable[j].SysIndicator :=
not Buffer[i].PartitionTable[j].SysIndicator;
p := buffer[i];
ProcessPhysicalSector(3,$80,0,StartCyl,StartSec,1,p);
writeln('The drive ',Drive,': has been unlocked !');
reboot;
end
else
WriteError('Your password is error, the drive '+
Drive + ': may not be unlocked !');
end
else
writeln('The drive ',Drive,': is unlocked !');
end;

procedure Works;
begin
case Switch of
'L' : LockDrive;
'U' : UnLockDrive;
end;
end;

procedure GetDriveState;
var i : byte;
begin
i := ord(Drive) - ord('C') + 1;
if DriveState[i] then
writeln('The drive ',Drive,': is unlocked !')
else
writeln('The drive ',Drive,': is locked !');
end;

procedure GetParameter;
var TempStr : String[2];
TempChar : Char;
begin
if ParamCount > 0 then
begin
TempStr := ParamStr(1);
if TempStr[2] = ':' then
begin
TempChar := UpCase(tempstr[1]);
if TempChar in ['A'..'Z'] then
Drive := TempChar
else
WriteError('Does not exist this drive !');
end
else
WriteError('The first parameter is error !');
end;
if ParamCount > 1 then
begin
TempStr := ParamStr(2);
if TempStr[1] = '/' then
begin
TempChar := UpCase(TempStr[2]);
if TempChar in ['L','U'] then
Switch := TempChar
else
WriteError('The switch is error !');
end
else
WriteError('The second parameter is error !');
end;
end;

procedure GetAllPartition;
var StartCyl,StartSec : word;
i,j,k : byte;
P : MBRT;
begin
StartCyl := 0;
StartSec := 1;
i := 0;
repeat
ProcessPhysicalSector(2,$80,0,StartCyl,StartSec,1,p);
j := FindExtendedPartition(p);
StartCyl := P.PartitionTable[j].StartCylinder;
StartSec := P.PartitionTable[j].StartSector;
inc(i);
Buffer[i] := p;
k := FindDosPartition(p);
if (P.PartitionTable[k].SysIndicator in [1,4,6])
then DriveState[i] := true;
until j = 0;
DriveNum := i;
end;

Procedure Init;
var i : byte;
begin
drive := #0;
for i := 1 to 24 do DriveState[i] := false;
end;

begin
WriteLn('HDL version 1.0, Copyright (C) 1992 Dong Zhanshan');
init;
GetParameter;
GetAllPartition;
if drive <> #0 then
if (Drive in ['A','B']) then
WriteError('Floppy diskette is not able to be locked !')
else if (Ord(Drive) >= 67) then
if (Ord(Drive) - 66 > DriveNum) then
WriteError('This logical drive does not exist !');
case ParamCount of
0 : Help;
1 : GetDriveState;
2 : Works;
else WriteError('Too many parameters !');
end;
end.

§3.3 稿纸排版打印程序

稿纸排版打印程序(SP)是一个通用的方格稿纸打印程序，用TURBO PASCAL编写，在中文、英文操作系统下均可运行。SP适用于中文文稿的方格稿纸格式输出，可打印中文、英文、图表混合的文稿，既清晰又美观，对科技文章的作者、文艺作品的作者以及其他写作爱好者，SP将是一个无与伦比的好帮手。SP可以省去你反复改稿誊稿的烦恼，使你从繁重的重复劳动中解脱出来，去干更有意义的工作。
杂志报纸的编辑部均要求文章的作者，把文稿用方格纸誊写清楚，以便送审与排版，避免不必要的差错，这就给文章的作者增加了负担。写文章的人皆把写文章比喻为“爬格子”，十分形象，象征着写文章的辛劳，我也是个“爬格子的”，苦则思变，怎样才能将“爬格子”变成一件赏心乐目的事呢?
我们已跨入了办公自动化的时代，很多以前由人做的事，现在都由计算机来完成。顺应时代潮流，跟上时代的步代，把“爬格子”的苦事交给计算机来完成。当文稿写成之后，录入计算机，然后用方格稿纸打印程序排版输出。

§3.3.1 程序设计的原则要求

科技文章一般均是中英文混合，且穿插一些图表，所以方格稿纸的排版的总原则是习惯化、规范化、简易化。
首先，要求图表与文字分别对待，图表做为一个整体直接输出，文字部分要求
中文、英文分别对待，中文字一格，英文连续排列；
其次，对文章的题标居中排版，对段落的开始要留两个空格；
其三，要正确分页并编码；
其四，要能够满足某些特殊要求；
别外还要考虑到，目前大多数人员是用WS或WPS编辑文本的，其文本中包含了许多排版符，这些字符均不是正常可见的ASCII字符，所以程序要对这些文本进行预处理后，再进行排版输出。
程序采用命令串格式，并提供了几个选择开关，由使用人员指定功能，使程序更加灵活方便。

§3.3.2 程序的主要功能

本程序采用采用了代码优代技术，代码紧凑，执行速度快。根据设计的原则要求，其难点主要是中英文分离及分类处理、图表的输出。
该程序的主要功能有三:
. 完成WS或WPS文本文件到纯ASCII文本文件的转换
. 完成纯ASCII文件的方格稿纸的排版
. 显示输出排版结果，打印输出排版结果

§3.3.3 使用方法

语法:
SP <输入文件> <输出文件> [<选择开关>]
其中“输入文件”为纯ASCII码格式的文件或WS与WPS的文本格式文件，“输出文件”为翻译成方格稿纸格式文本的输出文件，它可以在WPS系统下直接送打印机输出。
选择开关有:
/D = 显示翻译结果文本
/E = 删除翻译输出文件
/P = 打印翻译结果文本
/T = 当输入文件为WS或WPS文件时，转换此文件为纯ASCII码文件
当缺省选择开关时，SP只把输入文件翻译成方格稿纸格式的文件，而不送打印机输出。

§3.3.4 排版命令

(1) 命令格式:
①CTRL码
②CTRL码 数字 #
其中'CTRL码'有四种选择: ^C、^O、^S、^T，'数字'可为1-999之间的任意整数， '#'为命令结束符。
(2) 命令分类:
①行居中命令:
^C
②段排版命令:
^Sn#
其中n为0-20之间的任意整数，代表段落前所留空格数。
③行原样打印命令:
^On#
其中n为原样打印行数，在1-999之间。
④图表排版命令:
^Tn#
其中n为图表所占行数，在1-999之间。
5.板样
(1) WS文件(含排版命令)如下:
^C 方格稿纸打印软件SP V2.0
中国农科院棉花研究所 董占山
^S2# SP V2.0软件文件清单:
^O7# SP.DOC SP的使用手册，这个文件
SP.PAS SP的PASCAL源程序
SP.EXE SP的执行程序
DEMO1.TXT 一个演示文件
DEMO2.TXT 又一个演示文件
DEMO1.BAT DEMO1.TXT的批处理文件
DEMO2.BAT DEMO2.TXT的批处理文件
^S2# SP V2.0的主要功能及其选择开关简介如表1所示。
^T10# 表1.SP V2.0的主要功能及其选择开关
┌──────────┬──────────────┐
│ 主要功能 │ 选择开关 │
├──────────┼──────────────┤
│①转换WS文件 │ /D: 显示翻译结果文本 │
│②翻译文本为方格稿纸│ /E: 删除翻译输出文件 │
│ 格式的文件 │ /P: 打印翻译结果文本 │
│③打印输出稿纸文件 │ /T: 当输入文件为WS文件时， │
│ │ 转换WS文件为ASCII码文件│
└──────────┴──────────────┘

§3.3.5 源程序清单

{ SP.PAS 2.0 }
{ Copyright (c) 1991 Dong Zhanshan }

{$M 16000,$0,16000}

Program SP; { 方格稿纸排版打印程序 V2.0 }

uses crt,dos;

type
CtrlType = record { 定义排版命令类型 }
FMT : char;
Count : integer;
end;
const
WPS_1 = #$91#$81#$92#$94#$9b#$90#$99#$c1; { WPS的排版命令 }
WPS_2 = #$91#$80#$92#$85#$9b#$80#$99#$c0; { WPS的排版命令 }
CRCH = #$0D; { 定义回车符 }
ChiTabChar : array[1..5,1..2] of string[2] =( { 定义中文表格符 }
( '┌', { left upper corner }
'┐' ), { right upper corner }
( '└', { left down corner }
'┘' ), { right down corner }
( '─', { column }
'│' ), { row }
( '┬', { upper T }
'┴' ), { down T }
( '├', { left T }
'┤' ) { right T }
);
ConstCtrl : CtrlType = ( FMT : ^S; { 定义排版命令常量 }
Count : 2 );
display : boolean = false; { 显示控制常量 }
print : boolean = false; { 打印控制常量 }
erase : boolean = false; { 删除控制常量 }
trans : boolean = false; { 转换控制常量 }
CopyRight = 'MF SP Version 2.0 Copyright (c) 1990, 1991 MF Software Company';

var TempStr1,TempStr2,EStr,CStr, { 工作字符串变量 }
RegisterCH,ps1,ps2 : string; { 寄存剩余字符串 }
f1 : file; { 输入文件 }
f2 : text; { 输出文件 }
CR,Start,Chinese,English : boolean; { 布尔变量 }
CH : char; { 字符变量 }
FMTCom : CtrlType;{ 控制命令变量 }
PageNum,LineNum, { 页数, 行数 }
CurFileLen,len,Result : word; { 当前文件位置 }
TextLine,UpLine,DownLine : string; { 生成的文本行 }

procedure InitStr; { 初始化变量 }
begin
textline := ChiTabChar[3,2];
downline := ChiTabChar[5,1];
upline := ChiTabChar[5,1];
tempstr1 := '';
tempstr2 := '';
EStr := '';
CStr := '';
RegisterCh := '';
PageNum := 0;
LineNum := 0;
CurFileLen := 0;
Chinese := false;
English := false;
Start := true;
FMTCom := ConstCtrl;
end;

procedure AnStr1( s1 : string;
var S2 : string;
var len : word);
{ 在S1中找回车符, 并把回车以前的字符赋予S2 }
var i : integer;
begin
i := pos(CRCH,s1);
if i = 0 then i := pos(#$1A,S1);
if i <> 0 then
begin
CR := true;
move(s1,s2,i-1);
s2[0] := chr(i - 1);
len := i + 1;
end
else
begin
CR := false;
s2 := s1;
len := ord(s1[0]);
end;
end;

procedure DelSpace(var S : string);
{ 删除字符串S中的前导空格 }
begin
if start then
while (s[1] = ' ') and (ord(s[0]) > 1) do
begin
move(s[2] , s[1] , ord(s[0]) - 1);
s[0] := chr(ord(s[0]) - 1 );
end;
if (s[1] = ' ') and (ord(s[0]) = 1) then s[0] := chr(0);
end;

procedure GetChar( var S : string;
var Ch : char );
{ 从S中取一字符CH, 并把CH从S中删除 }
begin
ch := s[1];
move(s[2] , s[1] , ord(s[0]) - 1 );
s[0] := chr( ord(s[0]) - 1 );
end;

procedure ProcCtrlChar;
{ 取排版命令 }
Procedure SeekCount;
{ 给排版命令的COUNT赋值 }
var ts : string[3];
c,i : integer;
begin
i := 0;
ts := '';
repeat
GetChar(TempStr2,Ch);
if ch <> '#' then Ts := TS + ch;
inc(i);
until (ch = '#');
Val(Ts,FMTCom.Count,C);
end;

begin
case Ch of
^C : FMTCom.FMT := ^C;
^O,^S,^T :
begin
FMTCom.Fmt := ch;
SeekCount;
end;
else FMTCom := ConstCtrl;
end;
Start := true;
end;

procedure PrintPageTail;
{ 输出页尾 }
var i : integer;
begin
write(f2,ChiTabChar[2,1]);
for i:= 1 to 39 do write(f2,ChiTabChar[3,1]);
writeln(f2,ChiTabChar[2,2]);
writeln(f2,' 20x20=400 第 ',PageNum,' 页');
{ for i := 1 to 18 do writeln(f2); }
LineNum := 0;
end;

procedure PrintPageHead;
{ 输出页头 }
var i : integer;
begin
writeln(f2,WPS_1+' 稿 纸');
write(f2,WPS_2);
write(f2,ChiTabChar[1,1]);
for i:= 1 to 39 do write(f2,ChiTabChar[3,1]);
writeln(f2,ChiTabChar[1,2]);
end;

Procedure Writeline;
{ 输出文本行 }
begin
writeln(f2,Upline);
writeln(f2,Textline);
writeln(f2,Downline);
UpLine := ChiTabChar[5,1];
TextLine := ChiTabChar[3,2];
DownLine := ChiTabChar[5,1];
inc(LineNum);
if LineNum = 20 then
begin
inc(PageNum);
PrintPageTail;
PrintPageHead;
end;
end;

Procedure WriteSpaceLine( X : integer;
Done : boolean);
{ 输出X行空行, DONE为真时也输出页尾 }
var i : integer;
begin
for i := 1 to 19 do
begin
upline := upline
+ ChiTabChar[3,1]
+ ChiTabChar[4,1];
downline := downline
+ ChiTabChar[3,1]
+ ChiTabChar[4,2];
textline := textline
+ ' '
+ ChiTabChar[3,2];
end;
upline := upline
+ ChiTabChar[3,1]
+ ChiTabChar[5,2];
downline := downline
+ ChiTabChar[3,1]
+ ChiTabChar[5,2];
textline := textline
+ ' '
+ ChiTabChar[3,2];
for i := 1 to X do
begin
writeln(f2,Upline);
writeln(f2,Textline);
writeln(f2,Downline);
inc(LineNum);
end;
if done then
begin
inc(PageNum);
PrintPageTail;
end
else
begin
UpLine := ChiTabChar[5,1];
TextLine := ChiTabChar[3,2];
DownLine := ChiTabChar[5,1];
end;
end;

procedure ProcCstr;
{ 处理中文字串 }
begin
case ord(textline[0]) of
0..76 : begin
textline := textline
+ CStr[1]
+ CStr[2]
+ ChiTabChar[3,2];
upline := upline
+ ChiTabChar[3,1]
+ ChiTabChar[4,1];
Downline := Downline
+ ChiTabChar[3,1]
+ ChiTabChar[4,2];
if ord(CStr[0]) >= 4 then
begin
Move(CStr[3],CStr[1],ord(CStr[0])-2);
CStr[0] := chr(ord(CStr[0])-2);
ProcCStr;
end
else if ord(CStr[0]) = 3 then
RegisterCh := CStr[3];
end;
78..82 : begin
textline := textline
+ CStr[1]
+ CStr[2]
+ ChiTabChar[3,2];
upline := upline
+ ChiTabChar[3,1]
+ ChiTabChar[5,2];
Downline := Downline
+ ChiTabChar[3,1]
+ ChiTabChar[5,2];
writeline;
if ord(CStr[0]) >= 4 then
begin
Move(CStr[3],CStr[1],ord(CStr[0])-2);
CStr[0] := chr(ord(CStr[0])-2);
ProcCStr;
end
else if ord(CStr[0]) = 3 then
RegisterCh := CStr[3];
end;
end;
chinese := false;
CStr := '';
end;

 

procedure ProcEstr;
{ 处理英文字串 }
Procedure AddUpLine(X1,X2:integer);
var i : integer;
begin
for i := 1 to x1*2 do
upline := upline + ChiTabChar[3,1];
case x2 of
1 : begin
case ord(upline[0]) of
0..76 : upline := upline
+ ChiTabChar[3,1]
+ ChiTabChar[4,1];
78..82 : upline := upline
+ ChiTabChar[3,1]
+ ChiTabChar[5,2];
end;
end;
2 : begin
case ord(upline[0]) of
0..76 : upline := upline
+ ChiTabChar[3,1]
+ ChiTabChar[3,1];
78..82 : upline := upline
+ ChiTabChar[3,1]
+ ChiTabChar[5,2];
end;
end;
end;
end;

Procedure AddDownLine(X1,X2:integer);
var i : integer;
begin
for i := 1 to x1*2 do
Downline := Downline + ChiTabChar[3,1];
case x2 of
1 : begin
case ord(Downline[0]) of
0..76 : Downline := Downline
+ ChiTabChar[3,1]
+ ChiTabChar[4,2];
78..82 : Downline := Downline
+ ChiTabChar[3,1]
+ ChiTabChar[5,2];
end;
end;
2 : begin
case ord(Downline[0]) of
0..76 : Downline := Downline
+ ChiTabChar[3,1]
+ ChiTabChar[3,1];
78..82 : Downline := Downline
+ ChiTabChar[3,1]
+ ChiTabChar[5,2];
end;
end;
end;
end;

Procedure ProcEstr1;
var i, x : integer;
begin
i := ord(EStr[0]);
if i mod 4 = 0 then x := 4 else x := i mod 4;
case X of
1 : begin
AddUpLine(i div 4,1);
AddDownLine(i div 4,1);
TextLine := TextLine + EStr + ' ' + ChiTabChar[3,2];
end;
2 : begin
AddUpLine(i div 4,1);
AddDownLine(i div 4,1);
TextLine := TextLine + EStr + ChiTabChar[3,2];
end;
3 : begin
AddUpLine(i div 4,2);
AddDownLine(i div 4,2);
TextLine := TextLine + EStr + ' ';
end;
4 : begin
AddUpLine(i div 4 - 1,2);
AddDownLine(i div 4 - 1,2);
TextLine := TextLine + EStr;
end;
end;
end;
begin
if ord(EStr[0]) > 80 - ord(textline[0]) then
begin
tempstr1 := copy( EStr,
80 - ord(textline[0]) + 1,
ord(EStr[0]) -(80 - ord(textline[0]))
);
delete( EStr,
80 - ord(textline[0]) + 1,
ord(EStr[0]) -(80 - ord(textline[0]))
);
ProcEstr1;
writeline;
EStr := Tempstr1;
ProcEstr1;
end
else
ProcEstr1;
if ord(TextLine[0]) = 82 then writeline;
english := false;
EStr := '';
end;

Procedure ProcStr2;
{ 处理字符串 }
begin
repeat
GetChar(Tempstr2,Ch);
case ch of
#$20..#$7F : begin
if Chinese then ProcCStr;
English := true;
EStr := EStr + ch;
if ord(EStr[0]) >= 40 then ProcEStr;
end;
#$80..#$FF : begin
if English then ProcEStr;
Chinese := true;
CStr := CStr + ch;
if ord(CStr[0]) >= 20 then ProcCStr;
end;
end;
until tempstr2 = '';
if Chinese then ProcCStr;
if English then
begin
if CR then ProcEStr
else begin
RegisterCH := EStr;
EStr := '';
end;
end;
end;

Procedure ReadStr;
{ 从文件中读字符到一个串中, 然后生成TEMPSTR2 }
begin
{$I-} blockread(f1,tempstr1,250,result); {$I+}
move(Tempstr1[0],Tempstr2[1],result);
tempstr2[0] := chr(result);
tempstr1 := tempstr2;
AnStr1(tempstr1,tempstr2,len);
inc(CurFileLen,Len);
seek(f1,CurFileLen);
end;

Procedure StrSegmentProc;
{ 段排版处理 }
var i,x,c : integer;
Procedure CompleteLine;
var i : integer;
begin
for i := 1 to (78 - ord(Textline[0])) div 4 do
begin
TextLine := TextLine
+ ' '
+ ChiTabChar[3,2];
Upline := UpLine
+ ChiTabChar[3,1]
+ ChiTabChar[4,1];
Downline := DownLine
+ ChiTabChar[3,1]
+ ChiTabChar[4,2];
end;
TextLine := TextLine
+ ' '
+ ChiTabChar[3,2];
Upline := UpLine
+ ChiTabChar[3,1]
+ ChiTabChar[5,2];
Downline := DownLine
+ ChiTabChar[3,1]
+ ChiTabChar[5,2];
writeline;
start := true;
cr := false;
RegisterCh := '';
end;

begin
TempStr2 := ch + Tempstr2;
DelSpace(Tempstr2);
if start then
begin
if FMTCom.Count = 0 then ProcStr2
else
begin
for i := 1 to FMTCom.Count do
begin
TextLine := TextLine
+ ' '
+ ChiTabChar[3,2];
Upline := Upline
+ ChiTabChar[3,1]
+ ChiTabChar[4,1];
Downline := DownLine
+ ChiTabChar[3,1]
+ ChiTabChar[4,2];
end;
ProcStr2;
end;
Start := false;
end
else
ProcStr2;
if CR then
if (Ord(TextLine[0]) <> 2) then CompleteLine
else
begin
start := true;
cr := false;
RegisterCh := '';
end;
end;

procedure StrCenterProc;
{ 居中排版处理 }
Procedure LeaveMagSpace;
var i,j,k : integer;
Tstr1,Tstr2,Tstr3 : string;
begin
i := 80 - ord(textLine[0]);
j := i div 4;
Tstr1 := ChiTabChar[5,1];
Tstr2 := ChiTabChar[3,2];
Tstr3 := ChiTabChar[5,1];
for k := 1 to j div 2 do
begin
Tstr1 := Tstr1 + ChiTabChar[3,1] + ChiTabChar[4,1];
Tstr2 := Tstr2 + ' ' + ChiTabChar[3,2];
Tstr3 := Tstr3 + ChiTabChar[3,1] + ChiTabChar[4,2];
end;
UpLine := Tstr1 + UpLine;
TextLine := Tstr2 + TextLine;
DownLine := Tstr3 + DownLine;
if i mod 4 <> 0 then j := j + 1;
if j mod 2 <> 0 then j := j div 2 + 1
else j := j div 2;
for k := 1 to j - 1 do
begin
UpLine := UpLine
+ ChiTabChar[3,1]
+ ChiTabChar[4,1];
TextLine := TextLine
+ ' '
+ ChiTabChar[3,2];
DownLine := DownLine
+ ChiTabChar[3,1]
+ ChiTabChar[4,2];
end;
UpLine := UpLine
+ ChiTabChar[3,1]
+ ChiTabChar[5,2];
TextLine := TextLine
+ ' '
+ ChiTabChar[3,2];
DownLine := DownLine
+ ChiTabChar[3,1]
+ ChiTabChar[5,2];
end;
begin
TextLine := '';
UpLine := '';
DownLine := '';
Tempstr2 := Ch + Tempstr2;
DelSpace(Tempstr2);
ProcStr2;
LeaveMagSpace;
Writeline;
end;

Procedure StrOrigProc;
{ 原样输出排版处理 }
type
OrigStrPtr = ^OrigStrType;
OrigStrType = array[1..60] of string;
var
OrigStr : OrigStrPtr;
x,y,z,oldLineNum : integer;
Procedure MakeProc(x1,x2 : integer);
var i,j : integer;
begin
GetMem(OrigStr,x2*246);
OrigStr^[1] := ChiTabChar[5,1] ;
for i := 1 to 39 do
OrigStr^[1] := OrigStr^[1] + ChiTabChar[3,1];
Origstr^[1] := OrigStr^[1] + ChiTabChar[5,2];
for i := 2 to x2*3 - 1 do
begin
OrigStr^[i] := ChiTabChar[3,2] ;
for j := 1 to 39 do
OrigStr^[i] := OrigStr^[i] + ' ';
Origstr^[i] := OrigStr^[i] + ChiTabChar[3,2];
end;
if odd(x2) then OrigStr^[x2*3] := OrigStr^[1]
else OrigStr^[x2*3] := OrigStr^[2];
move(Tempstr2[1],OrigStr^[2][3],ord(Tempstr2[0]));
if x1 > 1 then
begin
for i := 2 to x1 do
begin
ReadStr;
move(Tempstr2[1],OrigStr^[i*2][3],ord(Tempstr2[0]));
end;
end;
for i := 1 to x2 do
begin
UpLine := OrigStr^[(i-1)*3 + 1];
TextLine := OrigStr^[(i-1)*3 + 2];
DownLine := OrigStr^[(i-1)*3 + 3];
WriteLine;
end;
FreeMem(OrigStr,x2*246);
TempStr2 := '';
end;

Procedure ProcManyLine(XX : integer);
begin
ReadStr;
if xx > 30 then
begin
MakeProc(30 , 20);
ProcManyLine(xx - 30);
end
else
if xx * 2 mod 3 <> 0 then MakeProc(xx , xx * 2 div 3 + 1)
else MakeProc(xx , xx * 2 div 3);
end;

begin
Tempstr2 := ch + Tempstr2;
X := FMTCom.Count;
y := X * 2;
if y mod 3 <> 0 then z := y div 3 + 1
else z := y div 3;
if z <= 20 - LineNum then MakeProc(x,z)
else
begin
OldLineNum := LineNum;
MakeProc( ((20 - LineNum)*3) div 2 , 20 - LineNum);
ProcManyLine(X -(20 - OldLineNum)*3 div 2);
end;
end;

Procedure StrTableProc;
{ 图表输出排版处理 }
type
OrigStrPtr = ^OrigStrType;
OrigStrType = array[1..60] of string;
var
OrigStr : OrigStrPtr;
x,y,z,OldLineNum : integer;
Procedure MakeProc(x1,x2 : integer);
var i,j : integer;
begin
GetMem(OrigStr,x2*246);
OrigStr^[1] := ChiTabChar[5,1] ;
for i := 1 to 39 do
OrigStr^[1] := OrigStr^[1] + ChiTabChar[3,1];
Origstr^[1] := OrigStr^[1] + ChiTabChar[5,2];
for i := 2 to x2*3 do
begin
OrigStr^[i] := ChiTabChar[3,2] ;
for j := 1 to 39 do
OrigStr^[i] := OrigStr^[i] + ' ';
Origstr^[i] := OrigStr^[i] + ChiTabChar[3,2];
end;
move(Tempstr2[1],OrigStr^[2][3],ord(Tempstr2[0]));
if x1 > 1 then
begin
for i := 2 to x1 do
begin
ReadStr;
move(Tempstr2[1],OrigStr^[i+1][3],ord(Tempstr2[0]));
end;
end;
for i := 1 to x2 do
begin
UpLine := OrigStr^[(i-1)*3 + 1];
TextLine := OrigStr^[(i-1)*3 + 2];
DownLine := OrigStr^[(i-1)*3 + 3];
WriteLine;
end;
FreeMem(OrigStr,x2*246);
TempStr2 := '';
end;

Procedure ProcManyLine(XX : integer);
begin
ReadStr;
if XX > 59 then
begin
MakeProc(59, 20);
XX := XX - 59;
ProcManyLine(XX);
end
else
if (xx+1) mod 3 <> 0 then MakeProc(xx , (xx + 1) div 3 + 1)
else MakeProc(xx , (xx + 1) div 3);
end;

begin
Tempstr2 := ch + Tempstr2;
X := FMTCom.Count;
y := X + 1;
if y mod 3 <> 0 then z := y div 3 + 1
else z := y div 3;
if z <= 20 - LineNum then MakeProc(x,z)
else
begin
OldLineNum := LineNum;
MakeProc( (20 - LineNum)*3 - 1, 20 - LineNum);
ProcManyLine(X - (20 - OldLineNum)*3 + 1);
end;
end;

Procedure AnStr2;
{ 分析TEMPSTR2 }
begin
repeat
GetChar(TempStr2,Ch);
case ch of
^C,^O,^S,^T : ProcCtrlChar;
#$20..#$FF :
case FMTCom.FMT of
^C : StrCenterProc;
^O : StrOrigProc;
^S : StrSegmentProc;
^T : StrTableProc;
end;
end;
until tempstr2 = '';
end;

Procedure ws_ascii(fn1 : string);
{ 转换WS文件为ASCII文件 }
var f1 : file;
f2 : text;
begin
assign(f1,fn1);
assign(f2,'$$$.$$$');
reset(f1,1);
rewrite(f2);
repeat
blockread(f1,ch,1);
case ch of
#$8D : begin
blockread(f1,ch,1);
blockread(f1,ch,1);
end;
#$0D : begin
blockread(f1,ch,1);
case ch of
#$8A : begin
write(f2,#$0D#$0A);
blockread(f1,ch,1);
end;
#$0A : write(f2,#$0D);
end;
end;
end;
write(f2,ch);
until eof(f1);
close(f1);
close(f2);
end;

Procedure help;
{ 帮助过程 }
begin
writeln('Syntax: SP []');
writeln('Options: /d = display the output file');
writeln(' /e = erase the output file');
writeln(' /p = print the output file');
writeln(' /t = translate the input file with WS_ASCII');
halt;
end;

function YesNo(s : string) : boolean;
{ 回答YES或NO }
begin
YesNo := false;
write(s,' ?(Y/N)');
ch := readkey;
writeln(ch);
if ch in ['y','Y'] then YesNo := true;
end;

function exist(filename : string) : boolean;
{ 判断文件是否存在 }
var f1 : text;
i : integer;
begin
assign(f1,filename);
{$I-} reset(f1); {$I+}
i := ioresult;
if i = 0 then exist := true
else exist := false;
end;

procedure ParseComline;
{ 命令行分析器 }
var i : integer;
procedure ProcComlineStr(s:string);
var i : integer;
begin
for i := 1 to ord(s[0]) do
s[i] := upcase(s[i]);
if s = '/D' then display := true;
if s = '/E' then erase := true;
if s = '/P' then print := true;
if s = '/T' then trans := true;
end;

begin
i := paramcount;
if i < 2 then help;
if i = 2 then exit;
case i of
3 : ProcComlineStr(paramstr(3));
4 : begin
ProcComlineStr(paramstr(3));
ProcComlineStr(paramstr(4));
end;
5 : begin
ProcComlineStr(paramstr(3));
ProcComlineStr(paramstr(4));
ProcComlineStr(paramstr(5));
end;
6 : begin
ProcComlineStr(paramstr(3));
ProcComlineStr(paramstr(4));
ProcComlineStr(paramstr(5));
ProcComlineStr(paramstr(6));
end;
end;
end;

Procedure translatetext(fn1,fn2 : string);
{ 翻译ASCII文件为方格稿纸文本文件 }
begin
assign(f1,fn1);
reset(f1,1);
assign(f2,fn2);
rewrite(f2);
InitStr;
PrintPageHead;
repeat { 主循环体 }
ReadStr;
TempStr2 := RegisterCH + TempStr2;
RegisterCh := '';
DelSpace(Tempstr2);
if TempStr2 <> '' then AnStr2 ;
until eof(f1);
WriteSpaceLine(20-LineNum,True);
close(f1);
close(f2);
end;

procedure DisplayText(fn : string);
var f1,f2 : text;
ts : string[79];
ch : char;
i : integer;
begin
assign(f1,fn);
reset(f1);
assigncrt(f2);
rewrite(f2);
i := 0;
repeat
readln(f1,ts);
writeln(f2,ts);
inc(i);
if i = 20 then
begin
i := 0;
ch := readkey;
end;
until (ch=#$1B) or eof(f1);
close(f1);
close(f2);
end;

{ 主程序 }
begin
writeln('SP Version 2.1 Copyright (c) 1990,94 Dong Zhanshan');
directvideo := false;
writeln(CopyRight);
PS1 := paramstr(1);
PS2 := paramstr(2);
ParseComline;
if not exist(PS1) then
begin
writeln('File not found !');
exit;
end;
if exist(PS2) then
if not YesNo('File exist ! Overwrite') then exit;
if trans then ws_ascii(PS1);
if trans then TranslateText('$$$.$$$',PS2)
else TranslateText(PS1,PS2);
if display then DisplayText(PS2);
if print then exec(getenv('COMSPEC'),'/C copy '+PS2+ ' prn >nul');
if erase then exec(getenv('COMSPEC'),'/C del '+PS2+' >nul');
if trans then exec(getenv('COMSPEC'),'/C del $$$.$$$ >nul');
end.

§3.4 源程序分页打印程序

程序编写完成之后，如要打印输出，在BASICA中，可用LLIST命令完成，对其它高级语言，则缺少特定打印命令，不过还可以用DOS功能来实现，但对源程序的输出求较高时，则无通用的命令。为解决这个困难，用TURBO PASCAL编写了一个源程序打印程序ASL.PAS。

§3.4.1 程序使用方法

ASL /H --- 获得ASL帮助文本
ASL 文件名 --- 分页打印源程序
ASL 文件名 /D --- 分页显示源程序
说明: “文件名”为DOS的有效文件名，必须写全名。如果要批量打印一批扩展名为.PAS的文件，则可以执行：
For %%a in (*.PAS) do ASL %%a

§3.4.2 源程序清单

{ ASL.PAS 1.2 }
{ Copyright (c) 1990,94 Dong Zhanshan }

program AdvancedSourceLister;

uses printer,dos,crt,astr;

var d1,m1,y1,w1,pagenumber,counter,sp1,sp2 : word;
lin,flnm,sw : string;
f1,f2 : text;

function Exist(Flnm:string):boolean;
var i : byte;
f1 : text;
begin
Exist := False;
assign(f1,Flnm);
{$I-}
reset(f1);
{$I+}
i := IoResult;
if i = 0 then
begin
Exist := True;
close(f1);
end;
end;

procedure PrintPageHead(var f3:text);
var i,h1,m,s,s100 : word;
begin
gettime(h1 , m , s , s100);
writeln(f3 , 'Advanced Print Program'
, Space(sp1), flnm,Space(sp2)
, wordtostr(y1 , 4), '-'
, wordtostr(m1 , 2), '-'
, wordtostr(d1 , 2), Space(3)
, wordtostr(h1 , 2), ':'
, wordtostr(m , 2), ':'
, wordtostr(s , 2)
);
writeln( f3 , fillchartostr(80 , '_') );
end;

procedure PrintPageTail(var f3:text);
var i : word;
begin
inc ( pagenumber );
writeln( f3 , fillchartostr(80 , '_') );
write ( f3 , fillchartostr(36 , ' ') );
writeln( f3 , '----' , pagenumber , '----' );
for i := 1 to 12 do writeln(f3);
counter := 0;
end;

procedure Print(var f3:text);
begin
inc(counter);
writeln(f3, lin);
if counter = 50 then
begin
PrintPageTail(f3);
PrintPageHead(f3);
end;
end;

procedure LastPageProcess(var f3:text);
var i : integer;
begin
for i := counter + 1 to 48 do writeln(f3);
PrintPageTail(f3);
end;

procedure ProcessTab(var lin : string);
var temp,temp1 : string;
i : integer;
ch : char;
begin
temp := '';
for i := 1 to length(lin) do
begin
ch := lin[i];
if ch = #9 then temp1 := FillCharToStr(8,' ')
else temp1 := ch;
temp := temp + temp1;
end;
lin := temp;
end;

Procedure p(var lin : string);
var lin1 : string;
begin
if length(lin) > 80 then
begin
lin1 := lin;
lin[0] := chr(80);
if sw = '/D' then print(f2) else print(lst);
delete(lin1 , 1 , 80);
lin := FillCharToStr(4 , ' ')+lin1;
p(lin);
end
else
if sw = '/D' then print(f2) else print(lst);
end;

begin
writeln('ASL Version 1.2 Copyright (c) 1990,94 Dong Zhanshan');
if paramstr(1) = '/H' then
begin
writeln('Advanced Source Lister Usage:');
writeln(' ASL /H --- ASL help messenge');
writeln(' ASL filename --- Print the file to printer');
writeln(' ASL filename /D --- Display the file to screen');
exit;
end;
case paramcount of
0 : begin
write('Filename : ');
readln(flnm);
sw := '';
end;
1 : begin
flnm := paramstr(1);
sw := '';
end;
2 : begin
flnm := paramstr(1);
sw := paramstr(2);
end;
end;
if not exist(flnm) then
begin
writeln('File not found !');
exit;
end;
sp1 := 18 - length(flnm) div 2;
sp2 := 36 - (sp1 + length(flnm));
lin := flnm; flnm := '';
UpperLower(flnm,lin);
assign(f1,flnm);
reset(f1);
if sw = '/D' then
begin
assigncrt(f2);
rewrite(f2);
end;
pagenumber := 0;
counter := 0;
getdate(y1,m1,d1,w1);
if sw = '/D' then PrintPageHead(f2)
else PrintPageHead(lst);
repeat
readln(f1,lin);
ProcessTab(lin);
P(lin);
until eof(f1);
if sw = '/D' then LastPageProcess(f2)
else LastPageProcess(lst);
close(f1);
if sw = '/D' then close(f2);
end.

 

§3.5 查找并替换程序

TURBO PASCAL系统盘上提供了一个十分实用的字符串查找程序GREP.COM,该程序可以在指定的一批文件中,查找一个或具有一定特征的字符串,查到后在屏幕上显示出来。但是，它不能把指定的字符串同时替换成另外一个字符串，然而在实际工作中，我们往往要对一批文件中的指定字符串进行替换，如果使用编辑程序，则需要一个一个进行，实在是让人难以忍受。作者用TURBO PASCAL编写了一个简单的字符串查找并替换程序GREP.PAS，经过编译，形成执行文件后可以在操作系统下批量地对指定文件进行处理。

§3.5.1 程序使用方法

GREP <文件名> <查找的字符串> [替换的字符串]
其中“文件名”是某一特定的文件名,不能用通配符,且必须写上文件的扩展名；“查找的字符串”为任意合法的字符和数字的组合；“替换的字符串”是指把从文件中找到的查找字符串转换成的字符串，如果省略此项，GREP程序只在指定文件中查找字符串，而不进行替换工作。

§3.5.2 源程序清单

{ GREP.PAS 1.0 }
{ Copyright (c) 1994 Dong Zhanshan }

program Find_Replace;

uses dos;

var
f1,f2 : text;
FindStr,ReplaceStr : string;
FindB,ReplaceB : boolean;
Flnm : string;

procedure GetComLine;
begin
Flnm := '';
FindStr := '';
ReplaceStr := '';
FindB := False;
ReplaceB := False;
Case ParamCount of
2 : begin
Flnm := ParamStr(1);
FindStr := ParamStr(2);
FindB := True;
end;
3 : begin
Flnm := ParamStr(1);
FindStr := ParamStr(2);
ReplaceStr := ParamStr(3);
ReplaceB := True;
end;
end;
end;

Procedure Help;
begin
Writeln('Syntex : GREP [replace string]');
halt;
end;

procedure Find;
var
str1 : string;
i,l : word;
begin
if FSearch(flnm,'') = '' then help;
assign(f1,flnm);
reset(f1);
l := 0;
repeat
readln(f1,str1);
inc(l);
i := pos(FindStr,str1);
if i <> 0 then
Writeln('[',Flnm, '] Line : ',l,' ',str1);
until eof(f1);
close(f1);
end;

procedure Replace;
var
str1,str2,str3 : string;
P: PathStr;
D: DirStr;
N: NameStr;
E: ExtStr;
i : integer;

begin
assign(f1,flnm);
reset(f1);
assign(f2,'temp');
rewrite(f2);
repeat
readln(f1,str2);
repeat
i := pos(FindStr,str2);
if i <> 0 then
begin
str3 := copy(str2,1,i-1);
delete(str2,1,i+Length(FindStr)-1);
str2 := str3 + ReplaceStr + str2;
end;
until i = 0;
writeln(f2,str2);
until eof(f1);
close(f1);
close(f2);
assign(f1,Flnm);
assign(f2,'temp');
fsplit(p,d,n,e);
str1 := n + '.bak';
rename(f1,str1);
rename(f2,Flnm);
end;

begin
WriteLn('GREP Version 1.0, Copyright (C) 1994 Dong Zhanshan');
GetComLine;
if Flnm = '' then Help;
if FindB then Find;
if ReplaceB then Replace;
end.

§3.6 备份硬盘主引导扇区程序

§3.6.1 硬盘主引导记录

用FDISK对硬盘进行分区时，它在硬盘的0面0道1扇区生成一个包含分区信息表、主引导程序的主引导记录，其作用是当系统加电或复位时，若从硬盘自举，ROM BIOS就会把硬盘该扇区的内容读到内存的0000:7C00处，并执行主引导程序，把活动分区的操作系统引导到内存。
作者用TURBO PASCAL编写了备份硬盘主引导扇区程序，程序清单附后。该程序短小精悍，使用方便。

§3.6.2 使用方法

在DOS系统下执行:
HMR
根据程序的提示,即可把硬盘上的主引导记录写到MRECORD.SAV的文件中;也可以根据提示把文件MRECORD.SAV中存储的内容写到硬盘的0面0柱1扇区。

§3.6.3 源程序清单

{ HMR.PAS 1.2 }
{ Copyright (c) 1990,94 Dong Zhanshan }

program HarddiskMainbootRecord;

uses Acrt,Disk;

const
MBRF = 'MRECORD.SAV';

var
mp : MBRT;
i : integer;
f1 : file;

begin
writeln('HMR Version 1.2 Copyright (c) 1990,94 Dong Zhanshan',^M^J);
if YesNo('Read the hard disk main boot record') then
begin
ProcessPhysicalSector(2,$80,0,0,1,1,mp);
if YesNo('Save the hard disk main boot record') then
begin
assign(f1,MBRF);
rewrite(f1,1);
blockwrite(f1,mp,512);
close(f1);
end;
end;
if YesNo('Write the hard disk main boot record') then
begin
if YesNo('Are you sure') then
begin
assign(f1,MBRF);
{$I-}reset(f1,1);{$I+}
i := ioresult;
if i = 0 then
begin
blockread(f1,mp,512);
close(f1);
ProcessPhysicalSector(3,$80,0,0,1,1,mp);
end
else writeln('Read file error');
end;
end;
writeln(#7,'Done !',#7);
end.

§3.7 四通-PC文本文件转换程序

四通高级中英文打字机具有极强的文字处理能力，而IBM PC/XT、AT则有很大的灵活性，有许多优秀的中文排版软件可用，所以在四通打字机与PC机之间传递文件有一定的必要性。四通打字机的汉字机内码与PC机CCDOS的汉字机内码的差别主要是高位字节不同，前者高位的ASCII码比后者的小80H，另一方面的差别是在四通打字机WP系统下录入的文件，其每个软回车(其ASCII码为8DH)前有两个特殊的编辑字符，第一个字符的ASCII码为8EH。
通过以上的分析，作者用TURBO PASCAL编写了一个用于转换两个机器之中文文本文件的程序STPC.PAS，该程序经编译生成执行文件即可使用。使用方法:
STPC <输入文件> <输出文件>
其中，若输入文件为四通打字机的文本文件，则输出文件为PC机CCDOS的文本文件;若输入文件为PC机CCDOS的文本文件，则输出文件为四通打字机的文本文件。用该程序转换生成的CCDOS格式文件，可在WS下直接编辑、修改或打印，而生成的四通打字机格式的文件， 能在四通机的WP系统下直接处理。
源程序清单如下：

program stpc;

var
f1,f2 : file;
ch,ch1 : char;
fil1,fil2 : string;

begin
fil1 := paramstr(1);
fil2 := paramstr(2);
assign(f1,fil1);
assign(f2,fil2);
reset(f1,1);
rewrite(f2,1);
repeat
blockread(f1,ch,1);
case ch of
#$A1..#$FF:
begin
blockwrite(f2,ch,1);
blockread(f1,ch,1);
ch1 := chr(ord(ch) + $80);
ch := ch1;
end;
#$8E:
begin
blockread(f1,ch,1);
blockread(f1,ch,1);
end;
end;
blockwrite(f2,ch,1);
until eof(f1);
close(f1);
close(f2);
end.

§3.8 SPT和BMP文件的双向转换程序

SPT是Super-CCDOS提供的一个黑白两色的图文编辑程序，PaintBrush是WINDOWS提供的一个彩色图形编辑程序，它们各有优点，SPT提供的逐点编辑对图形的精细加工特别好用，而PaintBrush对图形的放大缩小是SPT所没有的。如果能够使两个程序直接交换数据，则是一件令人赏心的事情。

§3.8.1 SPT和BMP文件结构分析

通过对SPT和PaintBrush的图形文件的格式进行分析发现，SPT的未压缩Super Star图形文件(*.SPT)和PaintBrush的BMP格式文件(*.BMP)均是按点阵(位映象)存放图形的，只是存放次序和组织方法不同，所以完全可以利用这两种文件进行数据交换。PaintBrush中的BMP格式有单色位映象、16色位映象、256色位映象以及24b位映象4种，这里只考虑单色位映象一种格式，在此格式中，1bit(位)代表一个象素点，1B(字节)代表8个象素点。
SPT文件和BMP文件都有一个文件头，其中记录了图形的宽度、高度、文件长度和标志信息。SPT文件头有64B，如图3-1所示。前16B为SPT的文件头的标志，第34字节开始为两字节的图形宽度，紧接其后的是图形的高度，单位均是象素点。BMP的文件头如图3-2所示，前2B为标志，后面的4B是文件长度(LongInt)，第11，12两字节是指向点阵信息的指针，即从第3EH+1个字节开始存放点阵数据，第19，20字节表示图形宽度，23，24字节表示高度，单位也是象素点，第29字节(01)表示该BMP文件为单色位映象格式。BMP文件头共用了62字节。
殌櫪
SPT文件标志
3910:0100 敁53 75 70 65 72 2D 53 74-61 72 20 46 69 6C 65 1A敋 Super-Star File.
3910:0110 00 01 00 00 00 00 00 00-00 00 00 00 C0 EE C3 F7 ................
3910:0120 40 00 敁F0 03敋 敁F4 01敋 01 00-00 00 00 00 00 00 00 00 @...............
3910:0130 00 00 00 00 00 00 00 00-00 00 00 00 00 00 00 00 ................
图形宽度 图形高度
(1000点) (500点)

图3-1.SPT图形文件头

BMP文件标志 文件长度 指向点阵信息的指针
3910:0100 敁42 4D敋 敁76 28 00 00敋 00 00-00 00 敁3E 00敋 00 00 28 00 BMv(......v...(.
3910:0110 00 00 敁7B 00敋 00 00 敁A0 00敋-00 00 01 00 敁01敋 00 00 00 ..{.............
3910:0120 00 00 00 00 00 00 00 00-00 00 00 00 00 00 00 00 ................
3910:0130 00 00 00 00 00 00 00 00-00 00 00 00 80 00 ..............
图形宽度 图形高度 单色位映象格式标志
(123点) (160点)

图3-2.BMP图形文件头
殣
櫬 紧接文件头之后，SPT和BMP文件都是图形的点阵信息，SPT文件从图形的第一行开始，依次为第二、第三、...、第n行，BMP文件恰恰相反，为第n行、第n-1行、...、第一行，其中n为图形的高度。设图形的宽度为width个象素点，高度为height个象素点，因SPT只取width为8的倍数，故每行占的字节数LineByte为(width div 8);BMP文件中的width任意，但每行所占字节数必为4的倍数，所以实际每行所需字节数LineByte=(width+7) div 8。
据上述分析，用TURBO PASCAL编写了一个SPT_BMP.PAS程序，以实现SPT和BMP文件的双向转换。进行数据转换时应注意两点:(1)在SPT系统中存图形时，要选SuperStar文件类别，非压缩存储格式;(2)在PaintBrush存图时，在存文件对话框中打开Option文件格式选项，选Monochromoe bitmap项，然后存盘。

§3.8.2 程序使用方法

程序的使用方法是:

SPT_BMP
开关有两个选项:
/BS --- BMP文件转换为SPT文件
/SB --- SPT文件转换为BMP文件

§3.8.3 源程序清单

{ SPT_BMP.PAS 1.0 }
{ Copyright (c) 1994 Dong Zhanshan }

program Transfer_SPT_BMP;

const
SPT_Head : array[1..64] of byte = (
$53,$75,$70,$65,$72,$2D,$53,$74,$61,$72,$20,$46,$69,$6C,$65,$1A,
$00,$01,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$61,$62,$63,$64,
$40,$00,$00,$00,$00,$00,$01,$00,$00,$00,$00,$00,$00,$00,$00,$00,
$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00);
BMP_Head : array[1..62] of byte = (
$42,$4D,$00,$00,$00,$00,$00,$00,$00,$00,$3E,$00,$00,$00,$28,$00,
$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$01,$00,$01,$00,$00,$00,
$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,
$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$FF,$FF,$FF,$00);
var
BMP_file,SPT_file : string;
ch : char;
BMP,SPT : file;
OneLine : array[1..1000] of char;
Width,Height,Bytes : word;
LineByte,Ofs,FileLength : longint;
Switch : string[3];
i : integer;

procedure DispError;
begin
if IOResult <>0 then
Begin
Writeln('File not found !');
halt;
end;
end;

procedure SPT_to_BMP;
var
i : integer;
begin
if pos('.',SPT_file) = 0 then SPT_file := SPT_file + '.SPT';
if pos('.',BMP_file) = 0 then BMP_file := BMP_file + '.BMP';
assign(SPT,SPT_file);
{$I-} reset(SPT,1); {$I+}
assign(BMP,BMP_file);
rewrite(BMP,1);
seek(SPT,34);
blockread(SPT,Width,2);
blockread(SPT,Height,2);
bytes := Width div 8;
LineByte := ((Bytes + 3) div 4) * 4;
FileLength := FileSize(SPT);
move(FileLength,BMP_Head[3],4);
move(Width,BMP_Head[19],2);
move(Height,BMP_Head[23],2);
blockwrite(BMP,BMP_Head,62);
for i := bytes to LineByte do OneLine[i] := #0;
for i := Height downto 1 do
begin
Ofs := bytes * (i-1) + 64;
seek(SPT,ofs);
blockread(SPT,OneLine,Bytes);
blockWrite(BMP,OneLine,LineByte);
end;
close(SPT);
close(BMP);
end;

procedure BMP_to_SPT;
var
i : integer;
begin
if pos('.',BMP_file) = 0 then BMP_file := BMP_file + '.BMP';
if pos('.',SPT_file) = 0 then SPT_file := SPT_file + '.SPT';
assign(BMP,BMP_file);
{$I-} reset(BMP,1); {$I+}
assign(SPT,SPT_file);
rewrite(SPT,1);
seek(BMP,18);
blockread(BMP,Width,2);
seek(BMP,22);
blockread(BMP,Height,2);
bytes := (Width + 7) div 8;
LineByte := ((Width + 31) div 32) * 4;
Width := bytes * 8;
move(Width,SPT_Head[35],2);
move(Height,SPT_Head[37],2);
blockwrite(SPT,SPT_Head,64);
for i := Height downto 1 do
begin
Ofs := LineByte * (i-1) + 62;
seek(BMP,ofs);
blockread(BMP,OneLine,linebyte);
blockwrite(SPT,OneLine,bytes);
end;
close(BMP);
close(SPT);
end;

procedure Help;
begin
Writeln('Syntex : SPT_BMP ');
halt;
end;

begin
Writeln('SPT_BMP Version 1.0 Copyright (c) 1994 Dong Zhanshan');
case ParamCount of
0,1,2 : help;
3 : begin
SPT_file := ParamStr(1);
BMP_file := ParamStr(2);
Switch := ParamStr(3);
end;
end;
for i := 2 to 3 do Switch[i] := UpCase(Switch[i]);
if Switch = '/SB' then SPT_to_BMP;
if Switch = '/BS' then BMP_to_SPT;
end.

3.9 数据库打卡程序PDBC.PAS

每个DBASE数据库文件均是许多数据的集合,是数据的仓库,是数据的电子银行。数据从纸张上进入计算机，是为了查询方便等。但当数据库建成并校正无误后，往往要打印一份或多份，以备案留底，用数据库管理软件的报表打印功能，可以打印出数据结果，但是其打印速度比较慢，当需要按表格格式一张一张输出每一个记录时，用DBASE软件就比较麻烦，作者用TURBO PASCAL编写了一个程序，它使用第二章的DBASE单元提供的功能，读取DBASE数据库文件的记录结构，然后构造一个空白的表格，接着读取每一个DBASE数据库记录,将其填入空白表格，最后输入到一个文本文件中。
该程序的使用方法是：
PDBC <数据库文件> <输出文件>
源程序清单:

{ PDBC.PAS 1.5 }
{ Copyright (c) 1991,94 Dong Zhanshan }

program PrintDBaseCard;
{ DBASE数据库卡片打印程序 }

uses crt,dos,DBase,AStr;

const
Frame : array[1..11] of string[2] =
('┌','┐','└','┘','├','┤','┬','┴','┼','─','│');
type
_line = array[1..50] of string;

var
RecInfo : StrucType; { 数据库结构 }
Rec : RecTypePtr; { 记录内容 }
line_ : _line; { 卡片内容 }
r : array[1..128,1..2] of integer; { 字段在卡片中的位置 }
NumLine : integer; { 卡片行数 }
fl1,fl2 : string[64]; { 文件名 }
f1 : file; { 数据库文件号 }

procedure tables;
{ 填空白表过程 }
var i,k,m,StartRecord,OTextAttr : integer;
FieldStr : string;
ch : char;
f2 : text;
begin
assign(f2,fl2);
rewrite(f2);
with RecInfo do
begin
write('Input start record(1..',NumRec:5,')---');
readln(StartRecord);
OTextAttr := TextAttr;
TextAttr := blink+0*16+15;
writeln('Working ...... ');
TextAttr := OTextAttr;
getmem(rec,LengthRec);
for m := StartRecord to NumRec do
begin
ReadRecord(f1,m,RecInfo,Rec);
for i := 1 to NumField do
begin
with Field^[i] do
begin
FieldStr := '';
for k := 1 to FldWidth do
FieldStr := FieldStr + rec^[k+FldOffset];
move(FieldStr[1],line_[r[i,2]+1][r[i,1]+2],length(FieldStr));
end;
end;
for i := 1 to NumLine do writeln(f2,line_[i]);
writeln(f2);
end;
end;
close(f2);
end;

procedure maketable;
{ 造空白表过程 }
var temp1,temp2 : string;
ii,ll : integer;
FldWidth1 : integer;
i,j,k,l,m,cw : integer;
_start,_end : boolean;
q,q1 : integer;
c,t : array [1..16] of integer;

function CalFldWidth(FieldNo : integer):integer;
{ 计算字段宽度函数 }
var
FldWidth1 : integer;
begin
with Recinfo.Field^[FieldNo] do
begin
if odd(length(FldName)) then FldName := FldName + #32;
if odd(FldWidth) then FldWidth1 := FldWidth + 1
else FldWidth1 := FldWidth;
CalFldWidth := FldWidth1 + length(FldName) + 4;
end;
end;

function inn(mm:integer):boolean;
var n : integer;
begin
for n := 1 to q do
if mm = c[n] then
begin
inn:= true;
exit;
end;
inn := false;
end;

procedure ChangeLine;
{ 换行过程 }
var ii : word;
begin
while k <= cw - 3 do
begin
temp2 := temp2 + #32#32;
if not inn(k) then temp1 := temp1 + Frame[10]
else temp1 := temp1 + Frame[8];
inc(k,2);
end;
if _start then temp1 := temp1 +Frame[2]
else temp1 := temp1 + Frame[6];
temp2 := temp2 +Frame[11];
line_[j] := temp1;
line_[j+1] := temp2;
inc(j,2);
temp1 := Frame[5];
temp2 := '';
k := 3;
if _start then _start := not _start;
q := q1;
for ii := 1 to 16 do c[ii] := t[ii];
for ii := 1 to 16 do t[ii] := 0;
q1 := 1;
end;

{ MakeTable过程开始 }
begin
i := 1; { 字段计数器 }
j := 1; { 行数计数器 }
k := 3; { 行内字符个数计数器 }
l := 1;
m := 1; { 循环计数器 }
q := 1; { 行内表格拐角计数器 }
q1 := 1; { 行内表格拐角计数器 }
FldWidth1 := 0;
_start := true;
_end := false;
temp2 := '';
temp1 := Frame[1];
for ii := 1 to 16 do c[ii] := 0;
for ii := 1 to 16 do t[ii] := 0;
write('Input line length(1..124)---');
readln(cw);
L := CalFldWidth(i);
while not _end do
begin
with RecInfo.Field^[i] do
begin
if odd(FldWidth) then FldWidth1 := FldWidth +1
else FldWidth1 := FldWidth ;
temp2 := temp2 +Frame[11] +Fldname + Frame[11] + space(FldWidth1);
for m := 1 to length(Fldname) do
begin
if not inn(k) then temp1 := temp1 + Frame[10]
else if ( m <> length(Fldname[i]) + 1 ) then temp1 := temp1 + Frame[8]
else temp1 := temp1 + Frame[9];
inc(m);
inc(k,2);
end;
r[i,1] := k;
r[i,2] := j;
t[q1] := k;
inc(q1);
if not inn(k) then temp1 := temp1 + Frame[7]
else temp1 := temp1 + Frame[9];
inc(k,2);
if odd(FldWidth ) then FldWidth1 := FldWidth +1
else FldWidth1 := FldWidth ;
for m := 1 to FldWidth1 do
begin
if not inn(k) then temp1 := temp1 + Frame[10]
else if m <> FldWidth1 + 1 then temp1 := temp1 + Frame[8]
else temp1 := temp1 + Frame[9];
inc(m);
inc(k,2);
end;
inc(i);
if i > RecInfo.NumField then _end := true;
ll := CalFldWidth(i);
if _end then ChangeLine
else if (ll + k) >= cw - 1 then ChangeLine
else
begin
t[q1] := k;
inc(q1);
if not inn(k) then temp1 := temp1 + Frame[7]
else temp1 := temp1 + Frame[9];
inc(k,2);
end;
end;
end;
temp1 := Frame[3];
i := 3;
while i <= cw-3 do
begin
if not inn(i) then temp1 := temp1 + Frame[10]
else temp1 := temp1 + Frame[8];
inc(i,2);
end;
temp1 := temp1 + Frame[4];
line_[j] := temp1;
NumLine := j;
end;

procedure help;
{ 显示帮助信息 }
begin
writeln('Syntex : PDBC DBASE_filename output_filename');
halt;
end;

{ 主程序开始 }
begin
writeln('PDBC Version 1.5 Copyright (c) 1991,94 Dong Zhanshan');
if paramcount<2 then help;
fl1 := paramstr(1);
if FSearch(fl1,'') = '' then exit;
fl2 := paramstr(2);
OpenDBase(fl1,f1,RecInfo);
MakeTable;
Tables;
CloseDBase(f1,RecInfo);
writeln(#7,#7,'End !!!');
end.

 

§3.10 BAT文件转换为COM的程序

众所周知，批处理文件具有编写和使用方便，占用内存少等独到的优点，特别是DOS 3.30以后的版本，又增加了许多新批命令，使批处理文件使用起来更得心应手。但批处理文件是用ASCII码存储的，这既是优点也是缺点。当你编写好一个软件后，其中要用到批处理文件，则会出现泄密的现象。怎样把批处理文件编译为命令文件，而得到一定程度的保密呢?

§3.10.1 批处理文件(.BAT)转换为命令文件(.COM)的技术原理

DOS的功能调用4BH是执行装入一个外部程序，并有选择地执行之，使用起来比较麻烦。DOS还提供了一个调用规则很简单的软中断2EH，可用之完成执行DOS内部和外部命令的要求。
中断2EH的调用规则:首先使用DOS功能调用4AH，开辟一个适当大小的缓冲区，然后，把DS:SI指向以命令串长度为先导的，以回车(0DH)为后缀的待执行命令串，然后执行中断。在执行2EH之后，除CS外的所有寄存器均被破坏，所以在执行中断调用之前，要把使用的寄存器保护起来，中断返回后再恢复之。
在批处理文件中，可以把命令等分成以下几类:①内部命令和外部命令，②标号，③注释，④条件语句，⑤转移语句，⑥循环语句。
对第一类命令，可以直接使用2EH实现;对第二类命令，只需在适当的地方构造一个标号即可;对第三类命令，在编译过程中，自动删除之;对第四类命令，要使用比较(CMP)与转移(JE，JNE等)来实现;对第五类命令，使用无条件转跳语句(JMP)来实现;而循环语句，即FOR语句，可以把它当作DOS命令来使用，只是要把"%%"符号改为"%"。
实现了以上的各类命令，再构造几各通用的子程序就可以完成BAT到COM文件的转换。需要构造的子程序有执行2EH的子程序，执行DOS返回的子程序和获得DOS命令行参数的子程序等。

§3.10.2 构造编译程序

要把BAT文件转换为COM文件，还需要有一个有效的编译程序，它主要把相应的BAT文件中相应的命令解译为汇编程序码或机器码，形成有效的ASM文件或COM文件，最后完成BAT到COM的编译工作。本文提供了一个将BATCH文件转换为COM文件的演示程序B2C.PAS。

§3.10.3 源程序清单

{ B2C.PAS 1.0 }
{ Copyright (c) 1993,94 Dong Zhanshan }

program Translate_Batch_to_COM;

uses dos;

const
Bat2ComHead : Array[1..81] of byte = (
$BB,$00,$10,$B4,$4A,$CD,$21,$0E,$1F,$2E,$8B,$0E,$51,$01,$BE,$51,
$01,$8B,$C6,$50,$5B,$51,$83,$C3,$02,$8B,$F3,$33,$DB,$8A,$1C,$53,
$56,$2E,$8C,$16,$4D,$01,$2E,$89,$26,$4F,$01,$CD,$2E,$0E,$1F,$2E,
$8B,$26,$4F,$01,$2E,$8E,$16,$4D,$01,$58,$5B,$59,$03,$C3,$50,$83,
$E9,$01,$83,$F9,$00,$75,$CD,$B8,$00,$4C,$CD,$21,$C3,$00,$00,$00,
$00);

var
str1 : string;
txtfl : text;
bfl : file of char;
buffer : array[1..10000] of char;
flnm : string;
TotalLength : word;

procedure RemoveSpace(Var str1:string);
var i : word;
begin
i := pos(' ',str1);
if i = 1 then
begin
delete(str1,1,1);
RemoveSpace(str1);
end;
end;

procedure RemoveDouble(Var str1:string);
var i : word;
begin
i := pos('%%',str1);
delete(str1,i,1);
if not (pos('%%',str1)=0) then RemoveDouble(str1);
end;

Procedure RemoveFlowerA( Var Str1:string);
var i : word;
begin
i := pos('@',str1);
if i = 1 then
delete(str1,1,1);
end;

procedure Transfer;
var strlen : word;
cmnum : word;
ch : char;
begin
assign(txtfl,flnm);
reset(txtfl);
cmnum := 0;
ch := char($0d);
TotalLength := 84;
repeat
readln(txtfl, str1);
removespace(str1);
removedouble(str1);
removeflowera(str1);
strlen := length(str1);
inc(cmnum);
move(str1, buffer[TotalLength], strlen + 1);
TotalLength := TotalLength + strlen + 1;
move(ch,buffer[TotalLength],1);
inc(TotalLength);
until eof(txtfl);
move(cmnum,buffer[82],2);
close(txtfl);
end;

procedure WriteBAT2COM;
var i : word;
begin
i := pos('.',flnm);
str1 := copy(flnm,1,i-1);
str1 := str1 + '.com';
move(BAT2COMHead,Buffer,81);
assign(bfl,str1);
rewrite(bfl);
for i := 1 to TotalLength do write(bfl,buffer[i]);
close(bfl);
end;

procedure Help;
begin
Writeln('Syntex : B2C Batch_filename');
halt;
end;

begin
writeln('B2C Version 1.0 Copyright (c) 1993,94 Dong Zhanshan');
case ParamCount of
0 : Help;
1 : Flnm := ParamStr(1);
else Help;
end;
if FSearch(flnm,'') = '' then help;
Transfer;
WriteBAT2COM;
end.

§3.11 机密文件的有效销毁程序

当删除一个DOS文件时，其实并未从磁盘上移走什么，这就给恢复文件提供了机会，某些人如果拥有合适的软件，就可以非法查看用户自以为已经销毁的数据。Norton Utilities和PC Tools都有实用程序能够从物理上真正删除文件，而避免文件被恢复，导致泄密。假如手头没有这类软件，可以使用下面的WIPE.PAS程序，可以实现同样的功能。
运行WIPE程序时，键入需要删除的文件名作为命令行参数。一旦用户确认确实希望删除该文件，程序即按美国国防部DOD5220.22M标准擦掉需要删除的机密数据。要删除的文件首先被写为'0'，再被写为'1'，如此重复3次，接着被写上一个随机值。再加上一个DOD标准中未说明的步骤，即在删除之前，先将文件名改为单字符文件名，如'X'，就能够使用恢复程序恢复机密文件的希望更加渺茫。
源程序清单:

{ WIPE.PAS 1.0 }
{ Copyright (c) 1994 Dong Zhanshan }

program Wipe_File;

{$I-,S-,R-}

uses Acrt;

var
f : file;
pass : integer;
ch : char;

procedure Stop;
begin
Writeln('Error Wiping file');
halt;
end;

procedure ErrorCheck;
begin
if IOResult <> 0 then Stop;
end;

procedure WipeWith(var f : file; c : char);
var i : longint;
r : word;
begin
Reset(f,1);
ErrorCheck;
for i := 1 to FileSize(f) do
begin
BlockWrite(f,c,1,r);
if r <> 1 then Stop;
end;
close(f);
ErrorCheck;
end;

Begin
Writeln('WIPE Version 1.0 Copyright (c) 1992 Vincent D. O''conner');
if ParamCount <> 1 then
begin
Writeln('Syntex : WIPE ');
exit;
end;
if not YesNo('Are you sure') then halt;
Randomize;
Assign(f,ParamStr(1));
ErrorCheck;
For pass := 1 to 3 do
begin
WipeWith(f,#0);
WipeWith(f,#1);
end;
WipeWith(f,chr(Random(256)));
Rename(f,'X');
ErrorCheck;
Erase(f);
ErrorCheck;
Writeln('Done!',#7);
end.

§3.12 释放内存程序

目前，一个好的TSR软件，应该在不需要时能够及时从内存中撤离，并且完全地把TSR占用的内存释放掉，供其它程序使用。例如CCDOS2.13H/SPDOS6.0F等；但是，也有一些软件在运行完后，不能及时从内存中撤离，浪费了内存空间，如SPDOS 5.0/UCDOS 1.0等。
由于DOS操作系统有640K常规内存的限制，如果不能有效地控制和释放内存中的各种TSR程序，在运行一些大型软件时就会发现内存不足的现象，往往就不得不重新启动系统，这样不仅浪费了宝贵的时间，而且也容易损坏机器。
要释放内存中TSR软件申请的内存资源，首先我们要恢复TSR软件运行前的中断向量表，其次是释放DOS分配给TSR的内存资源。我们知道当DOS装入一个程序时必须建立内存分配块，它是由一个16字节长的内存控制块(MCB)和以节为单位的内存块两部分组成。如果多个程序建立了多个内存分配块，这些分配块在内存中就形成一条内存控制链，用DOS服务52H，可以知道第一个内存控制块的地址，这对于释放内存资源是有用的。内存控制块的第一域为1字节标志位，4DH表示内存控制链没结束，05H表示结束。第二域为2字节长，为程序的PSP的地址。第三域为2字节长，为该内存分配块的长度，我们用当前内存控制块的地址与第三域值相加，结果就是下一个内存控制块的地址，这在释放内存时将用到。
当我们找到属于TSR的内存控制块后，通过DOS服务49H的调用就可以释放这块内存了，在调用该功能前需要将内存控制块所在段地址加1装入ES寄存器中。重复这个过程，从一个内存控制块移向另一个内存控制块并释放它，直到最后一块。
根据上述原理，用TURBO PASCAL编写一个内存资源释放程序RMEM.PAS，它修改了5H中断向量。此程序应该在要释放的TSR程序之前执行。当需要清除内存时，按下PRINT SCREEN键，即可释放其后装入的程序所占的内存了。该程序只需执行一次，即可多次使用。
源程序清单:

{ RMEM.PAS 1.0 }
{ Copyright (c) 1994 Dong Zhanshan }

{$M 1024,0,0}
Program Release_Memory;

uses dos;

type
intab = array[1..255] of longint;
var
inta : intab;
i : integer;
r : registers;
p : pointer;
mcb,mcb1end,mcb2end,tsrpsp : word;
str,flag : byte;

Procedure ramtsr;
interrupt;
label endl;
begin
r.ah := $52;
msdos(r);
mcb2end := memw[r.es:r.bx-2];
while (mem[mcb2end:0]) = $4d do
mcb2end := mcb2end + memw[mcb2end:3] + 1;
if mcb2end = mcb1end then goto endl;
mcb := mcb1end;
for i := 0 to 255 do
meml[0:4*i] := inta[i];
while (mem[mcb:0] = $4d) do
begin
tsrpsp := memw[mcb:1];
r.ah := $49;
r.es := mcb + 1;
msdos(r);
mcb := mcb + memw[mcb:3] + 1;
end;
endl:
r.ah := 0;
r.al := 3;
intr($10,r);
end;

begin
flag := 10;
getintvec($78,p);
move(p^,str,1);
if str = flag then
begin
writeln('Release Memory Has Installed !');
exit;
end
else
setintvec($78,@flag);
r.ah := $52;
msdos(r);
mcb1end := memw[r.es:r.bx-2];
while (mem[mcb1end:0] = $4d) do
mcb1end := mcb1end + memw[mcb1end:3] + 1;
writeln('Release Memory is already !');
setintvec($5,@ramtsr);
for i := 0 to 255 do
inta[i] := meml[0:4*i];
keep(0);
end.