请问如何编程通过并口传输文件，有没有相关的控件？(50分)

[?]

{Writen by Cat Software}

unit FileTransfer;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons, ExtCtrls, FileCtrl, ComCtrls;

const
BlockSize = 64512; {64510 bytes of data + 2 bytes checksum
this block could be much bigger but the next implementation
will be in DMA in stead of programmed IO and DMA blocks are
limited to 64Kb
besides the dos version also has a limitted blocksize and t
his
way the 2 versions could be compatible}

type
TFloatFormat = (ffGeneral);
FileType = ARRAY[0..BlockSize-1] of byte;

TForm1 = class(TForm)
Edit1: TEdit;
DirectoryListBox1: TDirectoryListBox;
FileListBox1: TFileListBox;
DriveComboBox1: TDriveComboBox;
Bevel1: TBevel;
Send: TBitBtn;
Receive1: TBitBtn;
Close: TBitBtn;
Bevel2: TBevel;
CheckBox1: TCheckBox;
CheckBox2: TCheckBox;
CheckBox3: TCheckBox;
CheckBox4: TCheckBox;
Label5: TLabel;
Label6: TLabel;
Label7: TLabel;
Label8: TLabel;
Label9: TLabel;
Label10: TLabel;
Label11: TLabel;
Label12: TLabel;
Label14: TLabel;
Label15: TLabel;
ProgressBar1: TProgressBar;
ComboBox2: TComboBox;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Label13: TLabel;
Label16: TLabel;
Label17: TLabel;
Label18: TLabel;
Label19: TLabel;
Label20: TLabel;
Bevel3: TBevel;
ProgressBar2: TProgressBar;
procedure CloseClick(Sender: TObject);
procedure FileListBox1Click(Sender: TObject);
procedure SendClick(Sender: TObject);
procedure Receive1Click(Sender: TObject);
procedure ComboBox2Change(Sender: TObject);
procedure InitialisePort;
procedure ResetPort;

private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation
var
LPTnAddress, ECRAddress, DCRAddress, DSRAddress, ecpDFifoAddress, cnfgAAddress,
cnfgBAddress: word;
Size, RealBlockSize, ThisBlockSize: integer;
LengthOfName, NumberOfBlocks: integer;
Implement: (EightBit, SixteenBit, ThirtytwoBit);
fname: string;
AttrByte: integer;
NameString: string[255];
f: file;
FileData: FileType;
CSCOk,Error, ImplementationNr: byte;
NoFile, ImplementTest: Boolean;
{$R *.DFM}

Procedure TForm1.ResetPort;
begin
Label12.Show;
ProgressBar1.Position:=0;
ASM
mov dx,ECRAddress
mov al,$04 {SPP mode,FIFO will be reset when going to ECP mode}
out dx,al

mov al,$74 {ECP mode, FIFO reset}
out dx,al

mov dx,DCRAddress
mov al,$08; {reset control lines}
out dx,al
end;
Exit;
end;

Procedure TForm1.InitialisePort;
begin
ASM {initialisation}
mov ax,LPTnAddress
inc ax
mov [DSRAddress],ax {LPTnAddress + $001, Device Status Register}
inc ax
mov [DCRAddress],ax {LPTnAddress + $002, Device Control Register}
add ax,$3FE
mov [ecpDFifoAddress],ax {LPTnAddress + $400, ECP data FIFO}
mov [cnfgAAddress],ax {LPTnAddress + $400, Configuration Register A}
inc ax
mov [cnfgBAddress],ax {LPTnAddress + $401, Configuration Register B}
inc ax
mov [ECRAddress],ax {LPTnAddress + $402, Extended Control Register}

mov dx,ECRAddress
mov al,$04 {SPP mode,FIFO will be reset when going to ECP mode}
out dx,al
mov al,$F4 {configuration A mode, get type of port (8, 16 or 32 bit)}
out dx,al

mov dx,cnfgAAddress {get the implementation number which corresponds with the
type of the port}
in al,dx
and al,$70
shr al,4
mov [ImplementationNr],al

mov dx,ECRAddress
mov al,$74 {ECP mode, no IRQ of nFault, no DMA and no service IRQ}
out dx,al
end;

IF ImplementationNr=0 THEN
Begin
Implement:=SixteenBit;
Label15.Caption:='16-bit implementation';
ImplementTest:=true;
end;
IF ImplementationNr=1 THEN
Begin
Implement:=EightBit;
Label15.Caption:='8-bit implementation';
ImplementTest:=true;
end;
IF ImplementationNr=2 THEN
Begin
Implement:=SixteenBit; {32-bit implementation never found, does it exist?}
Label15.Caption:='32-bit implementation, 16-bit used';
ImplementTest:=true;
end;
IF ImplementationNr>2 THEN
Begin
Label15.Caption:='Not a valid ECP port';
ImplementTest:=false;
end;
end;

Procedure ReceiveCheckSumCheck;
Begin
ASM
mov ecx,$00FFFFFF {load time-out counter}
mov dx,ECRAddress
@fifoNotEmpty: {wait for empty FIFO, this kind of polling is frequently us
ed in the program}
in al,dx
test al,$01 {test FIFO-full bit}
jnz @fifoEmpty
dec ecx {time-out counter}
jnz @fifoNotEmpty
mov [Error],1 {time-out occured}
jmp @end

@fifoEmpty:
mov dx,DCRAddress {Request for result of check sum}
mov al,$00 {Selectln low, results in nFault high for receiver}
out dx,al

mov ecx,$00FFFFFF
mov dx,DSRAddress
@WaitForAck: {Waits till receiver is done with checksum}
in al,dx
test al,$08 {nFault high, comes from nSelectLn low}
jnz @GotAcknowledge
dec ecx
jnz @WaitForAck
mov [Error],1
jmp @end

@GotAcknowledge: {gets checksum result: PError, comes from nInit}
and al,$20
shr al,4
mov [CSCOk],al

mov dx,ECRAddress {reset FIFO}
mov al,$14
out dx,al
mov al,$74
out dx,al

mov dx,DCRAddress {send acknowledge, reset control lines}
mov al,$08; {nSelectln high, results in nFault low for receiver}
out dx,al

@end:
end;
end;

Procedure SendCheckSumCheck;
Begin
ASM
mov ecx,$00FFFFFF
mov dx,DSRAddress
@WaitSend: {waiting for sender to request checksum result}
in al,dx
test al,$08 {wait for nFault to be high (nSelectln is set low)}
jnz @SendCheckSum
dec ecx
jnz @WaitSend
mov [Error],1
jmp @end

@SendCheckSum:
mov dx,ECRAddress {reset FIFO BEFORE ReceiveCheckSumCheck resets his FIFO
}
mov al,$14 {else some bytes may get lost during reseting}
out dx,al
mov al,$74
out dx,al

mov dx,DCRAddress {send checksum result: nInit, results in PError}
mov al,CSCOk
shl al,2
out dx,al

mov dx,DSRAddress
mov ecx,$00FFFFFF
@WaitReceive: {wait for acknowledge of sender}
in al,dx
test al,$08 {wait for nFault to be low (nSelectln is set high)}
jz @GotAcknowledge
dec ecx
jnz @WaitReceive
mov [Error],1
jmp @end

@GotAcknowledge:
mov dx,DCRAddress {reset control lines}
mov al,$28
out dx,al

@end:
end;
end;

Procedure ReceiveSynchronisation; {basicly the same as ReceiveCheckSumCheck}
Begin
ASM
mov ecx,$1FFFFFFF {large timeout counter to give enough time to click the
button}
mov dx,DSRAddress
@WaitSend: {waiting for sender to request synchro}
in al,dx
test al,$08 {wait for nFault to be high (nSelectln is set low)}
jnz @GotRequest
dec ecx
jnz @WaitSend
mov [Error],1
jmp @end

@GotRequest:
mov dx,ECRAddress {reset FIFO}
mov al,$14
out dx,al
mov dx,ECRAddress
mov al,$74
out dx,al

mov dx,DCRAddress {send acknowledge}
mov al,$00
out dx,al

mov ecx,$00FFFFFF
mov dx,DSRAddress
@WaitReceive: {wait for acknowledge of sender}
in al,dx
test al,$08 {wait for nFault to be low (nSelectln is set high)}
jz @GotAcknowledge
dec ecx
jnz @WaitReceive
mov [Error],1
jmp @end

@GotAcknowledge:
mov dx,DCRAddress {reset controllines, read}
mov al,$28
out dx,al

@end:
end;
end;

Procedure SendSynchronisation; {basicly the same as SendCheckSumCheck}
Begin
ASM
mov dx,DCRAddress {Request for result of check sum}
mov al,$00 {Selectln low, results in nFault high for receiver}
out dx,al

mov ecx,$1FFFFFFF
mov dx,DSRAddress
@WaitForAck: {Waits till receiver send acknowledge}
in al,dx
test al,$08 {nFault high, comes from nSelectLn low}
jnz @GotAcknowledge
dec ecx
jnz @WaitForAck
mov [Error],1
jmp @end

@GotAcknowledge:
mov dx,ECRAddress {reset FIFO}
mov al,$14
out dx,al
mov al,$74
out dx,al

mov dx,DCRAddress {send acknowledge, reset control lines, write}
mov al,$08; {nSelectln high, results in nFault low for receiver}
out dx,al

@end:
end;
end;

procedure TForm1.CloseClick(Sender: TObject);
begin
Application.Terminate;
end;

procedure TForm1.FileListBox1Click(Sender: TObject); {procedure to change the att
ribute of a file}
begin
NoFile:=FALSE;
AttrByte:=0;
Edit1.Text:=ExtractRelativePath(ExtractFileDir(FileListBox1.FileName)+'/', File
ListBox1.FileName);
Edit1.OEMConvert:=TRUE;
fname:=Edit1.Text;
NameString:=Edit1.Text;
AttrByte:=FileGetAttr(fname);

AssignFile(f,fname);
reset(f);
CloseFile(f);
IF (IOResult <> 0) OR (fname = '') THEN
Begin
Label12.Caption:='File not found!';
NoFile:=TRUE;
end
ELSE
Begin
Label12.Caption:=fname + ' selected';
Label12.Update;
end;

If AttrByte AND faReadOnly = faReadOnly
then
CheckBox1.Checked:=True
else
CheckBox1.Checked:=False;
If AttrByte AND faHidden = faHidden
then
CheckBox2.Checked:=True
else
CheckBox2.Checked:=False;
If AttrByte AND faSysFile = faSysFile
then
CheckBox3.Checked:=True
else
CheckBox3.Checked:=False;
If AttrByte AND faArchive = faArchive
then
CheckBox4.Checked:=True
else
CheckBox4.Checked:=False;
end;

procedure TForm1.SendClick(Sender: TObject); {procedure to send a file}
var
Time1, Time2, BlockTime1, BlockTime2, BlockTransferRate, TransferRate: Double;
Tel, BlockCount: Integer;

begin
Label6.Caption:=''; {clear the messages}
Label8.Caption:='';
Label10.Caption:='';
Label12.Caption:='';
Label18.Caption:='';
Label19.Caption:='';
Label20.Caption:='';
Label6.Update;
Label8.Update;
Label10.Update;
Label12.Update;
Label18.Update;
Label19.Update;
Label20.Update;
BlockTime1:=0;
BlockTime2:=0;

IF NOT ImplementTest THEN
Begin
Label12.Caption:='No valid port selected!';
Exit;
End;

IF NoFile THEN
Begin
Label12.Caption:='No valid file selected!';
Exit;
End;


NameString:=Edit1.Text;
LengthOfName:=ByteToCharLen(NameString, 254)+1;

AssignFile(f,NameString);
reset(f,1);
IF (IOResult <> 0) OR (fname = '') THEN
Begin
Label12.Caption:='File not found!';
ResetPort;
end;

Label18.Caption:=NameString;
Label19.Caption:=IntToStr(BlockSize);
Label18.Update;
Label19.Update;

SendSynchronisation; {wait for receiver to be ready}

IF Error=1 THEN
Begin
Label12.Caption:='01 ECP timeout, data transfer is aborted';
ResetPort;
end;

Time1:=Now;

Size:=FileSize(f);

NumberOfBlocks:=Size DIV (BlockSize-2);
IF (Size MOD (BlockSize-2))<>0 THEN NumberOfBLocks:=NumberOfBlocks+1;

Label6.Caption:=IntToStr(NumberOfBlocks);
Label8.Caption:=IntToStr(Size);
Label6.Update;
LAbel8.Update;

Error:=0;
ASM
mov ecx,$0FFFFFFF
mov dx,ECRAddress
@fifoNotEMPTY_SendBlockSize: {wait for FIFO to be empty (should be) and repor
t stall}
in al,dx
test al,$01
jnz @fifoEMPTY_SendBlockSize
dec ecx
jnz @fifoNotEMPTY_SendBlockSize
mov [Error],1
jmp @end

@fifoEMPTY_SendBlockSize:
mov dx,ecpDFifoAddress
mov eax,Size {loads eax with Size}
out dx,al {send low byte of low word}
mov al,ah
out dx,al {send high byte of low word}
shr eax,16 {move high word to low word}
out dx,al {send low byte high word}
mov al,ah
out dx,al {send low byte high word}

mov eax,LengthOfName {load eax with length of the filename}
mov [Tel],eax {load loop counter with length}
out dx,al {send length of the filename}

lea ebx,NameString {get address of string containing filename}

@LoopSendName: {return of loop 'Tel'}
mov ecx,$000FFFFF
mov dx,ECRAddress
@fifoFULL_SendName: {wait for FIFO to be empty and report stall}
in al,dx
test al,$02
jz @fifoNotFULL_SendName
dec ecx
jnz @fifoFULL_SendName
mov [Error],1
jmp @end

@fifoNotFULL_SendName: {transmit data}
mov dx,ecpDFifoAddress
mov al,[ebx] {move byte of NameString in al}
out dx,al {send it}
inc ebx {point at next byte}
dec [Tel]
cmp [Tel],0
jnz @LoopSendName {until Tel=0}

mov eax,$05
add eax,LengthOfName {compute the number of bytes send}
cmp al,$0F {lower than 16?}
jnb @16BytesSend
mov cl,$10 {compute number of bytes to reach a block of 16 bytes}
sub cl,al

@FillFIFO: {send some extra bytes to fill a FIFO = 16 bytes}
out dx,al
dec cl
jnz @FillFIFO
jmp @end

@16BytesSend:
test al,$01 {number of bytes send odd or even?}
jz @end
out dx,al {send extra byte to support 16 bit FIFO}
@end:
end;

IF Error=1 THEN
Begin
Label12.Caption:='02 ECP timeout, data transfer is aborted';
ResetPort;
end;

SendSynchronisation; {second synchro to clear FIFO}

ProgressBar1.Max:=NumberOfBlocks;
ProgressBar1.Step:=1;

Case Implement OF {different implementation for 8 bit and 16 bit ECP ports}
EightBit:
Begin
FOR BlockCount:=1 TO NumberOfBlocks DO
Begin
BlockRead(f,FileData,BlockSize-2,RealBlockSize); {read blocksize-2 by
tes of file at once}
IF BlockCount=1 THEN BlockTime1:=Now; {used to compute block transfer
rate}
REPEAT
ASM
lea ebx,FileData {get address of data to be send}
xor ax,ax
mov ecx,RealBlockSize {load ecx with RealBlockSize}
@ChecksumLoop: {compute checksum by xor-ing with the byte and r
otate the word to left}
xor al,[ebx]
rol ax,1
inc ebx
dec ecx
jnz @CheckSumLoop
mov [ebx],ax {store checksum after data block}

mov edx,RealBlockSize {load edx with RealBlockSize}
inc edx {last 2 bytes are checksum}
inc edx
mov eax,edx
shr edx,4 {get RealBlockSize div 16}
and eax,$0F {is block divideble by 16?}
cmp eax,0
jz @BlockDivideble16
inc edx {if not: increse number of 16 byte blocks by 1}
@BlockDivideble16:
mov [Tel],edx {load the loopcounter 'Tel'}

lea ebx,FileData {get address of data to be send}

@LoopSendData: {return}
mov ecx,$00FFFFFF
mov dx,ECRAddress
@fifoNotEMPTY_SendData: {wait for FIFO to be empty and report s
tall}
in al,dx
test al,$01
jnz @fifoEMPTY_SendData
dec ecx
jnz @fifoNotEMPTY_SendData
mov [Error],1
jmp @end

@fifoEMPTY_SendData: {transmit data in a burst of 16 bytes}
mov cl,$10 {loads loopcounter with 16}
mov dx,ecpDFifoAddress
@Loop16Bytes: {return of loop}
mov al,[ebx] {send a byte of the data}
out dx,al
inc ebx
dec cl
jnz @Loop16Bytes {until 16 bytes are send}
dec [Tel]
cmp [Tel],0
jnz @LoopSendData {until Tel=0}

@end:
end;

IF Error=1 THEN
Begin
Label12.Caption:='03 ECP timeout, data transfer aborted';
ResetPort;
end;

ReceiveCheckSumCheck;

IF Error=1 THEN
Begin
Label12.Caption:='04 ECP timeout, data transfer is aborted';
ResetPort;
end;

IF CSCOk=0 THEN
Begin
Label12.Caption:='Checksum error on block'+IntToStr(BlockCount)
;
Label12.update;
end;
UNTIL CSCOk<>0;
ProgressBar1.StepIt;
IF BlockCount=1 THEN BlockTime2:=Now; {used to compute block transfer
rate}
End;
End;

SixteenBit: {basicly the same as 8 bit but instead of sending a byte, send a
word}
Begin
FOR BlockCount:=1 TO NumberOfBlocks DO
Begin
BlockRead(f,FileData,BlockSize-2,RealBlockSize);
IF BlockCount=1 THEN BlockTime1:=Now;
REPEAT
ASM
lea ebx,FileData {compute checksum}
xor ax,ax
mov ecx,RealBlockSize
@ChecksumLoop:
xor al,[ebx]
rol ax,1
inc ebx
dec ecx
jnz @CheckSumLoop
mov [ebx],ax

mov edx,RealBlockSize {determine number of 16 byte blocks}
inc edx
inc edx
mov eax,edx
shr edx,4
and eax,$0F
cmp eax,0
jz @BlockDivideble16
inc edx
@BlockDivideble16:
mov [Tel],edx {load the loopcounter 'Tel'}

lea ebx,FileData {get address of FileData}

@LoopSendData: {return}
mov ecx,$00FFFFFF
mov dx,ECRAddress
@fifoNotEMPTY_SendData: {wait for FIFO to be empty and report s
tall}
in al,dx
test al,$01
jnz @fifoEMPTY_SendData
dec ecx
jnz @fifoNotEMPTY_SendData
mov [Error],1
jmp @end

@fifoEMPTY_SendData: {transmit data in a burst of 16 bytes}
mov cl,$08 {loads loopcounter with 8, 8 times 2 bytes is????}
mov dx,ecpDFifoAddress
@Loop16Bytes: {return}
mov ax,[ebx]
out dx,ax
inc ebx
inc ebx
dec cl
jnz @Loop16Bytes {until 16 bytes are send}
dec [Tel]
cmp [Tel],0
jnz @LoopSendData {until Tel=0}

@end:
end;

IF Error=1 THEN
Begin
Label12.Caption:='03 ECP timeout, data transfer aborted';
ResetPort;
end;

ReceiveCheckSumCheck; {receives the checksum copmparing result}

IF Error=1 THEN
Begin
Label12.Caption:='04 ECP timeout, data transfer is aborted';
ResetPort;
end;

IF CSCOk=0 THEN
Begin
Label12.Caption:='Checksum error on block'+IntToStr(BlockCount)
;
Label12.Show;
end;
UNTIL CSCOk<>0;
ProgressBar1.StepIt;
IF BlockCount=1 THEN BlockTime2:=Now;
End;
End;
End;
ProgressBar1.Position:=0;
CloseFile(f);

Time2:=Now;
TransferRate:=Size/((Time2-Time1)*24*3600*1024);
IF BlockTime1<>BlockTime2 THEN BlockTransferRate:=BlockSize/((BlockTime2-BlockT
ime1)*24*3600*1024)
ELSE BlockTransferRate:=0;
Label10.Caption:=FloatToStrF(TransferRate,FFfixed,5,2);
Label12.Caption:='Data transmitted';
Label20.Caption:=FloatToStrF(BlockTransferRate,FFfixed,6,2);
end;

procedure TForm1.Receive1Click(Sender: TObject); {procedure to receive a file}
Var
Tel, BlockCount: Integer;

begin
Label6.Caption:='';
Label8.Caption:='';
Label10.Caption:='';
Label12.Caption:='';
Label18.Caption:='';
Label19.Caption:='';
Label20.Caption:='';
Label6.Update;
Label8.Update;
Label10.Update;
Label12.Update;
Label18.Update;
Label19.Update;
Label20.Update;
IF NOT ImplementTest THEN
Begin
Label12.Caption:='No valid port selected!';
ResetPort;
End;

NameString:='';
Error:=0;

ReceiveSynchronisation; {waits for sender to be ready}

IF Error=1 THEN
Begin
Label12.Caption:='01 ECP timeout, data transfer aborted';
ResetPort;
end;

ASM {virtualy the same as in SendClick, but 'in' instead of 'out'}
mov ecx,$00FFFFFF
mov dx,ECRAddress
@fifoNotFULL_ReceiveBlockSize: {wait for FIFO to be empty and report stall}
in al,dx
test al,$02
jnz @fifoFULL_ReceiveBlockSize
dec ecx
jnz @fifoNotFULL_ReceiveBlockSize
mov [Error],1
jmp @end

@fifoFULL_ReceiveBlockSize: {receive the size of the file}
xor ebx,ebx
mov dx,ecpDFifoAddress
in al,dx
mov bl,al {receive first 2 bytes}
in al,dx
mov bh,al
shl ebx,16
in al,dx {receive next 2 bytes}
mov bl,al
in al,dx
mov bh,al
rol ebx,16
mov [Size],ebx {store ebx into Size}

xor eax,eax
in al,dx
mov [Tel],eax {get legnth of the filename}

lea ebx,NameString {get address of string containing length of filename}

@LoopReceiveName:
mov ecx,$00FFFFFF
mov dx,ECRAddress
@fifoEMPTY_ReceiveName: {wait for FIFO to be not empty and report stall}
in al,dx
test al,$01
jz @fifoNotEMPTY_ReceiveName
dec ecx
jnz @fifoEMPTY_ReceiveName
mov [Error],1
jmp @end

@fifoNotEMPTY_ReceiveName: {receive a byte of the filename}
mov dx,ecpDFifoAddress
in al,dx
mov [ebx],al
inc ebx

dec [Tel]
cmp [Tel],0
jnz @LoopReceiveName {until Tel=0}

test ah,1
jz @end
in al,dx {receive extra byte to support 16bit ECP ports}

@end:
end;

IF Error=1 THEN
Begin
Label12.Caption:='02 ECP timeout, data transfer aborted';
ResetPort;
end;

ReceiveSynchronisation; {clears the FIFO}

AssignFile(f,NameString);
Rewrite(f,1);

NumberOfBlocks:=Size DIV (BlockSize-2);
RealBlockSize:=Size-NumberOfblocks*(BlockSize-2); {computes size last block}
IF RealBlockSize<>0 THEN NumberOfBlocks:=NumberOfBlocks+1;

Label6.Caption:=IntToStr(NumberOfBlocks);
Label8.Caption:=IntToStr(Size);
Label18.Caption:=NameString;
Label19.Caption:=IntToStr(BlockSize);
Label6.Update;
Label8.Update;
Label18.Update;
Label19.Update;

ProgressBar1.Max:=NumberOfBlocks;
ProgressBar1.Step:=1;

Case Implement OF {different implementation for 8 bit and 16 bit ECP ports}
EightBit:
Begin
FOR BlockCount:=1 TO NumberOfBlocks DO
Begin
IF BLockCount=NumberOfBlocks THEN ThisBlockSize:=RealBlockSize+2
ELSE ThisBlockSize:=BlockSize; {sounds s
tupid but it's an old variable}
REPEAT
CSCOk:=1;
ASM
mov edx,ThisBlockSize {load edx with ThisBlockSize}
mov eax,edx
shr edx,4 {get ThisBlockSize div 16}
and eax,$0F {is block divideble by 16?}
cmp eax,0
jz @BlockDivideble16
inc edx {if not: increse number of 16 byte blocks by 1}
@BlockDivideble16:
mov [Tel],edx {load the loopcounter 'Tel'}

lea ebx,FileData {get Address of FileData}
dec ebx {explanation further}

@LoopReceiveData: {return}
mov ecx,$00FFFFFF
mov dx,ECRAddress
@fifoNotFULL_ReceiveData: {wait for full FIFO and report stall}
in al,dx
test al,$02
jnz @fifoFULL_ReceiveData
dec ecx
jnz @fifoNotFULL_ReceiveData
mov [Error],1
jmp @end

@fifoFULL_ReceiveData: {receive data in a burst of 16 bytes}
mov cl,$10 {loads loopcounter with 16}
mov dx,ecpDFifoAddress
@Loop16Bytes: {return}
inc ebx {due to pipeline hazzards, the inc is put befo
re the in instruction}
in al,dx
mov [ebx],al
dec cl
jnz @Loop16Bytes {until 16 bytes are send}
dec [Tel]
cmp [Tel],0
jnz @LoopReceiveData {until Tel=0}

lea ebx,FileData {computes checksum, the same as in sending a fil
e}
xor ax,ax
mov ecx,ThisBlockSize
dec ecx
dec ecx
@ChecksumLoop:
xor al,[ebx]
rol ax,1
inc ebx
dec ecx
jnz @CheckSumLoop
mov cx,[ebx] {load cx with cheacksum}
cmp ax,cx {is the computed checksum the same?}
je @end
mov [CSCOk],0 {no it is not}

@end:
end;

IF Error=1 THEN
Begin
Label12.Caption:='03 ECP timeout, data transfer aborted';
ResetPort;
end;

SendCheckSumCheck; {sends the checksum comparing result}

IF Error=1 THEN
Begin
Label12.Caption:='04 ECP timeout, data transfer aborted';
ResetPort;
end;

IF CSCOk=0 THEN
begin
Label12.Caption:='Checksum error on block '+IntToStr(BlockCount
);
Label12.Update;
end;
UNTIL CSCOk<>0;
ProgressBar1.StepIt;
BlockWrite(f,FileData,ThisBlockSize-2);
end;
End;

SixteenBit: {again it is almost the same as 8 bit receive}
Begin
FOR BlockCount:=1 TO NumberOfBlocks DO
Begin
IF BLockCount=NumberOfBlocks THEN ThisBlockSize:=RealBlockSize+2
ELSE ThisBlockSize:=BlockSize; {sounds s
tupid but it's an old variable}
REPEAT
CSCOk:=1;
ASM
mov edx,ThisBlockSize {determine number of 16 byte blocks}
mov eax,edx
shr edx,4
and eax,$0F
cmp eax,0
jz @BlockDivideble16
inc edx
@BlockDivideble16:
mov [Tel],edx

lea ebx,FileData {get Address of FileData}
dec ebx {minus 2, 16 bit}
dec ebx

@LoopSendData: {return}
mov ecx,$00FFFFFF
mov dx,ECRAddress
@fifoNotFULL_ReceiveData: {wait for full FIFO and report stall}
in al,dx
test al,$02
jnz @fifoFULL_ReceiveData
dec ecx
jnz @fifoNotFULL_ReceiveData
mov [Error],1
jmp @end

@fifoFULL_ReceiveData: {receive data in a burst of 16 bytes}
mov cl,$08
mov dx,ecpDFifoAddress
@Loop16Bytes:
inc ebx
inc ebx
in ax,dx
mov [ebx],ax
dec cl
jnz @Loop16Bytes
dec [Tel]
cmp [Tel],0
jnz @LoopSendData {until Tel=0}

lea ebx,FileData {computes checksum}
xor ax,ax
mov ecx,ThisBlockSize
dec ecx
dec ecx
@ChecksumLoop:
xor al,[ebx]
rol ax,1
inc ebx
dec ecx
jnz @CheckSumLoop
mov cx,[ebx] {load cx with cheacksum}
cmp ax,cx {is the computed checksum the same?}
je @end
mov [CSCOk],0 {it is not}

@end:
end;

IF Error=1 THEN
Begin
Label12.Caption:='03 ECP timeout, data transfer aborted';
ResetPort;
end;

SendCheckSumCheck; {send the checksum compare result}

IF Error=1 THEN
Begin
Label12.Caption:='04 ECP timeout, data transfer aborted';
ResetPort;
end;

IF CSCOk=0 THEN
begin
Label12.Caption:='Checksum error on block '+IntToStr(BlockCount
);
Label12.Update;
end;

UNTIL CSCOk<>0;
ProgressBar1.StepIt;
BlockWrite(f,FileData,ThisBlockSize-2);
End;
End;
End;
ProgressBar1.Position:=0;
CloseFile(f);
Label12.Caption:='Data received';
End;

procedure TForm1.ComboBox2Change(Sender: TObject);
begin
IF ComboBox2.ItemIndex=0 THEN
begin
LPTnAddress:=$278;
InitialisePort;
end;

IF ComboBox2.ItemIndex=1 THEN
begin
LPTnAddress:=$378;
InitialisePort;
end;

IF ComboBox2.ItemIndex=2 THEN
begin
LPTnAddress:=$3BC;
InitialisePort;
end;
IF ComboBox2.ItemIndex=-1 THEN ImplementTest:=FALSE;
end;


End.

串口通讯控件源代码，推荐您使用。
unit ComDrv32;

interface

uses
Windows, Messages, SysUtils, Classes, Forms;

type
// COM Port Baud Rates
TComPortBaudRate = ( br110, br300, br600, br1200, br2400, br4800,
br9600, br14400, br19200, br38400, br56000,
br57600, br115200{v1.02: removed ->, br128000, br256000} );
// COM Port Numbers
TComPortNumber = ( pnCOM1, pnCOM2, pnCOM3, pnCOM4, pnCOM5, pnCOM6, pnCOM7,
pnCOM8, pnCOM9, pnCOM10, pnCOM11, pnCOM12, pnCOM13,
pnCOM14, pnCOM15, pnCOM16 );
// COM Port Data bits
TComPortDataBits = ( db5BITS, db6BITS, db7BITS, db8BITS );
// COM Port Stop bits
TComPortStopBits = ( sb1BITS, sb1HALFBITS, sb2BITS );
// COM Port Parity
TComPortParity = ( ptNONE, ptODD, ptEVEN, ptMARK, ptSPACE );
// COM Port Hardware Handshaking
TComPortHwHandshaking = ( hhNONE, hhRTSCTS );
// COM Port Software Handshaing
TComPortSwHandshaking = ( shNONE, shXONXOFF );
// What to do with incomplete (incoming) packets
TPacketMode = ( pmDiscard, pmPass );

TComPortReceiveDataEvent = procedure( Sender: TObject; DataPtr: pointer; DataSize: integer ) of object;
TComPortReceivePacketEvent = procedure( Sender: TObject; Packet: pointer; DataSize, ElapsedTime: integer ) of object;

TCommPortDriver = class(TComponent)
protected
FComPortHandle : THANDLE; // COM Port Device Handle

FComPort : TComPortNumber; // COM Port to use (1..4)
FComPortBaudRate : TComPortBaudRate; // COM Port speed (brXXXX)
FComPortDataBits : TComPortDataBits; // Data bits size (5..8)
FComPortStopBits : TComPortStopBits; // How many stop bits to use (1,1.5,2)
FComPortParity : TComPortParity; // Type of parity to use (none,odd,even,mark,space)
FComPortHwHandshaking : TComPortHwHandshaking; // Type of hw handshaking to use
FComPortSwHandshaking : TComPortSwHandshaking; // Type of sw handshaking to use
FComPortInBufSize : word; // Size of the input buffer
FComPortOutBufSize : word; // Size of the output buffer
FPacketSize : smallint; // Size of a data packet
FPacketTimeout : integer; // ms to wait for a complete packet (<=0 = disabled)
FPacketMode : TPacketMode; // what to do with incomplete packets
FComPortReceiveData : TComPortReceiveDataEvent; // Event to raise on data reception
FComPortReceivePacket : TComPortReceivePacketEvent; // Event to raise on packet reception
FComPortPollingDelay : word; // ms of delay between COM port pollings
FEnableDTROnOpen : boolean; { enable/disable DTR line on connect }
FOutputTimeout : word; { output timeout - milliseconds }
FNotifyWnd : HWND; // This is used for the timer
FTempInBuffer : pointer;
FFirstByteOfPacketTime : DWORD;

procedure SetComHandle( Value: THANDLE );
procedure SetComPort( Value: TComPortNumber );
procedure SetComPortBaudRate( Value: TComPortBaudRate );
procedure SetComPortDataBits( Value: TComPortDataBits );
procedure SetComPortStopBits( Value: TComPortStopBits );
procedure SetComPortParity( Value: TComPortParity );
procedure SetComPortHwHandshaking( Value: TComPortHwHandshaking );
procedure SetComPortSwHandshaking( Value: TComPortSwHandshaking );
procedure SetComPortInBufSize( Value: word );
procedure SetComPortOutBufSize( Value: word );
procedure SetPacketSize( Value: smallint );
procedure SetPacketTimeout( Value: integer );
procedure SetComPortPollingDelay( Value: word );

procedure ApplyCOMSettings;

procedure TimerWndProc( var msg: TMessage );
public
constructor Create( AOwner: TComponent ); override;
destructor Destroy; override;

function Connect: boolean;
procedure Disconnect;
function Connected: boolean;
{ v1.02: flushes the rx/tx buffers }
procedure FlushBuffers( inBuf, outBuf: boolean );
{ v1.02: returns the output buffer free space or 65535 if
not connected }
function OutFreeSpace: word;

{ Send data }
{ v1.02: changed result time from 'boolean' to 'integer'. See the docs
for more info }
function SendData( DataPtr: pointer; DataSize: integer ): integer;
// Send a pascal string (NULL terminated if $H+ (default))
function SendString( s: string ): boolean;
// v1.02: send a C-style strings (NULL terminated)
function SendZString( s: pchar ): boolean;
// v1.02: set DTR line high (onOff=TRUE) or low (onOff=FALSE).
// You must not use HW handshaking.
procedure ToggleDTR( onOff: boolean );
// v1.02: set RTS line high (onOff=TRUE) or low (onOff=FALSE).
// You must not use HW handshaking.
procedure ToggleRTS( onOff: boolean );

// v1.02: make the Handle to the com port public (for TAPI...)
property ComHandle: THANDLE read FComPortHandle write SetComHandle;
published
// Which COM Port to use
property ComPort: TComPortNumber read FComPort write SetComPort default pnCOM2;
// COM Port speed (bauds)
property ComPortSpeed: TComPortBaudRate read FComPortBaudRate write SetComPortBaudRate default br9600;
// Data bits to used (5..8, for the 8250 the use of 5 data bits with 2 stop bits is an invalid combination,
// as is 6, 7, or 8 data bits with 1.5 stop bits)
property ComPortDataBits: TComPortDataBits read FComPortDataBits write SetComPortDataBits default db8BITS;
// Stop bits to use (1, 1.5, 2)
property ComPortStopBits: TComPortStopBits read FComPortStopBits write SetComPortStopBits default sb1BITS;
// Parity Type to use (none,odd,even,mark,space)
property ComPortParity: TComPortParity read FComPortParity write SetComPortParity default ptNONE;
// Hardware Handshaking Type to use:
// cdNONE no handshaking
// cdCTSRTS both cdCTS and cdRTS apply (** this is the more common method**)
property ComPortHwHandshaking: TComPortHwHandshaking
read FComPortHwHandshaking write SetComPortHwHandshaking default hhNONE;
// Software Handshaking Type to use:
// cdNONE no handshaking
// cdXONXOFF XON/XOFF handshaking
property ComPortSwHandshaking: TComPortSwHandshaking
read FComPortSwHandshaking write SetComPortSwHandshaking default shNONE;
// Input Buffer size
property ComPortInBufSize: word read FComPortInBufSize write SetComPortInBufSize default 2048;
// Output Buffer size
property ComPortOutBufSize: word read FComPortOutBufSize write SetComPortOutBufSize default 2048;
// v1.03: RX packet size (this value must be less than ComPortInBufSize)
property PacketSize: smallint read FPacketSize write SetPacketSize default -1;
// v1.03: timeout (ms) for a complete packet (in RX)
property PacketTimeout: integer read FPacketTimeout write SetPacketTimeout default -1;
// v1.03: what to do with incomplete packets (in RX)
property PacketMode: TPacketMode read FPacketMode write FPacketMode default pmDiscard;
// ms of delay between COM port pollings
property ComPortPollingDelay: word read FComPortPollingDelay write SetComPortPollingDelay default 50;
// v1.02: Set to TRUE to enable DTR line on connect and to leave it on until disconnect.
// Set to FALSE to disable DTR line on connect.
property EnableDTROnOpen: boolean read FEnableDTROnOpen write FEnableDTROnOpen default true;
// v1.02: Output timeout (milliseconds)
property OutputTimeout: word read FOutputTimeOut write FOutputTimeout default 4000;
// Event to raise when there is data available (input buffer has data) (called only if PacketSize = 0)
property OnReceiveData: TComPortReceiveDataEvent read FComPortReceiveData write FComPortReceiveData;
// Event to raise when there is data packet available (called only if PacketSize <> 0)
property OnReceivePacket: TComPortReceivePacketEvent read FComPortReceivePacket write FComPortReceivePacket;
end;

function BaudRateOf( bRate: TComPortBaudRate ): integer;
function DelayForRX( bRate: TComPortBaudRate; DataSize: integer ): integer;

procedure Register;

implementation

function BaudRateOf( bRate: TComPortBaudRate ): integer;
begin
case bRate of
br110 : Result := 110;
br300 : Result := 300;
br600 : Result := 600;
br1200 : Result := 1200;
br2400 : Result := 2400;
br4800 : Result := 4800;
br9600 : Result := 9600;
br14400 : Result := 14400;
br19200 : Result := 19200;
br38400 : Result := 38400;
br56000 : Result := 56000;
br57600 : Result := 57600;
br115200 : Result := 115200;
end;
end;

function DelayForRX( bRate: TComPortBaudRate; DataSize: integer ): integer;
begin
Result := round( DataSize / (BaudRateOf(bRate) / 10) * 1000 );
end;

constructor TCommPortDriver.Create( AOwner: TComponent );
begin
inherited Create( AOwner );
// Initialize to default values
FComPortHandle := 0; // Not connected
FComPort := pnCOM2; // COM 2
FComPortBaudRate := br9600; // 9600 bauds
FComPortDataBits := db8BITS; // 8 data bits
FComPortStopBits := sb1BITS; // 1 stop bit
FComPortParity := ptNONE; // no parity
FComPortHwHandshaking := hhNONE; // no hardware handshaking
FComPortSwHandshaking := shNONE; // no software handshaking
FComPortInBufSize := 2048; // input buffer of 2048 bytes
FComPortOutBufSize := 2048; // output buffer of 2048 bytes
FPacketSize := -1; // don't pack data
FPacketTimeout := -1; // packet timeout disabled
FPacketMode := pmDiscard; // discard incomplete packets
FComPortReceiveData := nil; // no data handler
FComPortReceivePacket := nil; // no data packet handler
FComPortPollingDelay := 50; // poll COM port every 50ms
FOutputTimeout := 4000; // output timeout - 4000ms
FEnableDTROnOpen := true; // DTR high on connect
FFirstByteOfPacketTime := DWORD(-1); // time not valid
// Temporary buffer for received data
GetMem( FTempInBuffer, FComPortInBufSize );
// Allocate a window handle to catch timer's notification messages
if not (csDesigning in ComponentState) then
FNotifyWnd := AllocateHWnd( TimerWndProc );
end;

destructor TCommPortDriver.Destroy;
begin
// Be sure to release the COM device
Disconnect;
// Free the temporary buffer
FreeMem( FTempInBuffer, FComPortInBufSize );
// Destroy the timer's window
DeallocateHWnd( FNotifyWnd );
inherited Destroy;
end;

// v1.02: The COM port handle made public and writeable.
// This lets you connect to external opened com port.
// Setting ComPortHandle to 0 acts as Disconnect.
procedure TCommPortDriver.SetComHandle( Value: THANDLE );
begin
// If same COM port then do nothing
if FComPortHandle = Value then
exit;
{ If value is $FFFFFFFF then stop controlling the COM port
without closing in }
if Value = $FFFFFFFF then
begin
if Connected then
{ Stop the timer }
if Connected then
KillTimer( FNotifyWnd, 1 );
{ No more connected }
FComPortHandle := 0;
end
else
begin
{ Disconnect }
Disconnect;
{ If Value is = 0 then exit now }
{ (ComPortHandle := 0 acts as Disconnect) }
if Value = 0 then
exit;

{ Set COM port handle }
FComPortHandle := Value;

{ Start the timer (used for polling) }
SetTimer( FNotifyWnd, 1, FComPortPollingDelay, nil );
end;
end;

procedure TCommPortDriver.SetComPort( Value: TComPortNumber );
begin
// Be sure we are not using any COM port
if Connected then
exit;
// Change COM port
FComPort := Value;
end;

procedure TCommPortDriver.SetComPortBaudRate( Value: TComPortBaudRate );
begin
// Set new COM speed
FComPortBaudRate := Value;
// Apply changes
if Connected then
ApplyCOMSettings;
end;

procedure TCommPortDriver.SetComPortDataBits( Value: TComPortDataBits );
begin
// Set new data bits
FComPortDataBits := Value;
// Apply changes
if Connected then
ApplyCOMSettings;
end;

procedure TCommPortDriver.SetComPortStopBits( Value: TComPortStopBits );
begin
// Set new stop bits
FComPortStopBits := Value;
// Apply changes
if Connected then
ApplyCOMSettings;
end;

procedure TCommPortDriver.SetComPortParity( Value: TComPortParity );
begin
// Set new parity
FComPortParity := Value;
// Apply changes
if Connected then
ApplyCOMSettings;
end;

procedure TCommPortDriver.SetComPortHwHandshaking( Value: TComPortHwHandshaking );
begin
// Set new hardware handshaking
FComPortHwHandshaking := Value;
// Apply changes
if Connected then
ApplyCOMSettings;
end;

procedure TCommPortDriver.SetComPortSwHandshaking( Value: TComPortSwHandshaking );
begin
// Set new software handshaking
FComPortSwHandshaking := Value;
// Apply changes
if Connected then
ApplyCOMSettings;
end;

procedure TCommPortDriver.SetComPortInBufSize( Value: word );
begin
{ Do nothing if connected }
if Connected then
exit;
// Free the temporary input buffer
FreeMem( FTempInBuffer, FComPortInBufSize );
// Set new input buffer size
FComPortInBufSize := Value;
// Allocate the temporary input buffer
GetMem( FTempInBuffer, FComPortInBufSize );
// Adjust the RX packet size
SetPacketSize( FPacketSize );
end;

procedure TCommPortDriver.SetComPortOutBufSize( Value: word );
begin
{ Do nothing if connected }
if Connected then
exit;
// Set new output buffer size
FComPortOutBufSize := Value;
end;

procedure TCommPortDriver.SetPacketSize( Value: smallint );
begin
// PackeSize = -1 if data isn't to be 'packetized'
if Value < 1 then
Value := -1
// If the PacketSize if greater than then RX buffer size then
// increase the RX buffer size
else if Value > FComPortInBufSize then
FComPortInBufSize := Value * 2;
FPacketSize := Value;
end;

procedure TCommPortDriver.SetPacketTimeout( Value: integer );
begin
// PacketTimeout = -1 if packet timeout is to be disabled
if Value < 1 then
Value := -1
// PacketTimeout cannot be less than polling delay + some extra ms
else if Value < FComPortPollingDelay then
Value := FComPortPollingDelay + 250;
FPacketTimeout := Value;
end;

procedure TCommPortDriver.SetComPortPollingDelay( Value: word );
begin
// If new delay is not equal to previous value...
if Value <> FComPortPollingDelay then
begin
// Stop the timer
if Connected then
KillTimer( FNotifyWnd, 1 );
// Store new delay value
FComPortPollingDelay := Value;
// Restart the timer
if Connected then
SetTimer( FNotifyWnd, 1, FComPortPollingDelay, nil );
// Adjust the packet timeout
SetPacketTimeout( FPacketTimeout );
end;
end;

const
Win32BaudRates: array[br110..br115200] of DWORD =
( CBR_110, CBR_300, CBR_600, CBR_1200, CBR_2400, CBR_4800, CBR_9600,
CBR_14400, CBR_19200, CBR_38400, CBR_56000, CBR_57600, CBR_115200{v1.02 removed: CRB_128000, CBR_256000} );

const
dcb_Binary = $00000001;
dcb_ParityCheck = $00000002;
dcb_OutxCtsFlow = $00000004;
dcb_OutxDsrFlow = $00000008;
dcb_DtrControlMask = $00000030;
dcb_DtrControlDisable = $00000000;
dcb_DtrControlEnable = $00000010;
dcb_DtrControlHandshake = $00000020;
dcb_DsrSensivity = $00000040;
dcb_TXContinueOnXoff = $00000080;
dcb_OutX = $00000100;
dcb_InX = $00000200;
dcb_ErrorChar = $00000400;
dcb_NullStrip = $00000800;
dcb_RtsControlMask = $00003000;
dcb_RtsControlDisable = $00000000;
dcb_RtsControlEnable = $00001000;
dcb_RtsControlHandshake = $00002000;
dcb_RtsControlToggle = $00003000;
dcb_AbortOnError = $00004000;
dcb_Reserveds = $FFFF8000;

// Apply COM settings.
procedure TCommPortDriver.ApplyCOMSettings;
var dcb: TDCB;
begin
// Do nothing if not connected
if not Connected then
exit;

// Clear all
fillchar( dcb, sizeof(dcb), 0 );
// Setup dcb (Device Control Block) fields
dcb.DCBLength := sizeof(dcb); // dcb structure size
dcb.BaudRate := Win32BaudRates[ FComPortBaudRate ]; // baud rate to use
// Set fBinary: Win32 does not support non binary mode transfers
// (also disable EOF check)
dcb.Flags := dcb_Binary;
if EnableDTROnOpen then
{ Enabled the DTR line when the device is opened and leaves it on }
dcb.Flags := dcb.Flags or dcb_DtrControlEnable;

case FComPortHwHandshaking of // Type of hw handshaking to use
hhNONE:; // No hardware handshaking
hhRTSCTS: // RTS/CTS (request-to-send/clear-to-send) hardware handshaking
dcb.Flags := dcb.Flags or dcb_OutxCtsFlow or dcb_RtsControlHandshake;
end;
case FComPortSwHandshaking of // Type of sw handshaking to use
shNONE:; // No software handshaking
shXONXOFF: // XON/XOFF handshaking
dcb.Flags := dcb.Flags or dcb_OutX or dcb_InX;
end;
dcb.XONLim := FComPortInBufSize div 4; // Specifies the minimum number of bytes allowed
// in the input buffer before the XON character is sent
// (or CTS is set)
dcb.XOFFLim := 1; // Specifies the maximum number of bytes allowed in the input buffer
// before the XOFF character is sent. The maximum number of bytes
// allowed is calculated by subtracting this value from the size,
// in bytes, of the input buffer
dcb.ByteSize := 5 + ord(FComPortDataBits); // how many data bits to use
dcb.Parity := ord(FComPortParity); // type of parity to use
dcb.StopBits := ord(FComPortStopbits); // how many stop bits to use
dcb.XONChar := #17; // XON ASCII char
dcb.XOFFChar := #19; // XOFF ASCII char
SetCommState( FComPortHandle, dcb );
{ Flush buffers }
FlushBuffers( true, true );
// Setup buffers size
SetupComm( FComPortHandle, FComPortInBufSize, FComPortOutBufSize );
end;

function TCommPortDriver.Connect: boolean;
var comName: string;
tms: TCOMMTIMEOUTS;
begin
// Do nothing if already connected
Result := Connected;
if Result then
exit;
// Open the COM port
SysUtils.FmtStr( comName, 'COM%-d', [1+ord(FComPort)] );
FComPortHandle := CreateFile(
pchar(comName),
GENERIC_READ or GENERIC_WRITE,
0, // Not shared
nil, // No security attributes
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0 // No template
) ;
Result := Connected;
if not Result then
exit;
// Apply settings
ApplyCOMSettings;
// Setup timeouts: we disable timeouts because we are polling the com port!
tms.ReadIntervalTimeout := 1; // Specifies the maximum time, in milliseconds,
// allowed to elapse between the arrival of two
// characters on the communications line
tms.ReadTotalTimeoutMultiplier := 0; // Specifies the multiplier, in milliseconds,
// used to calculate the total time-out period
// for read operations.
tms.ReadTotalTimeoutConstant := 1; // Specifies the constant, in milliseconds,
// used to calculate the total time-out period
// for read operations.
tms.WriteTotalTimeoutMultiplier := 0; // Specifies the multiplier, in milliseconds,
// used to calculate the total time-out period
// for write operations.
tms.WriteTotalTimeoutConstant := 0; // Specifies the constant, in milliseconds,
// used to calculate the total time-out period
// for write operations.
SetCommTimeOuts( FComPortHandle, tms );
// Start the timer (used for polling)
SetTimer( FNotifyWnd, 1, FComPortPollingDelay, nil );
end;

procedure TCommPortDriver.Disconnect;
begin
if Connected then
begin
// Stop the timer (used for polling)
KillTimer( FNotifyWnd, 1 );
// Release the COM port
CloseHandle( FComPortHandle );
// No more connected
FComPortHandle := 0;
end;
end;

function TCommPortDriver.Connected: boolean;
begin
Result := FComPortHandle > 0;
end;

// v1.02: flish rx/tx buffers
procedure TCommPortDriver.FlushBuffers( inBuf, outBuf: boolean );
var dwAction: DWORD;
begin
if not Connected then
exit;
// Flush the RX data buffer
dwAction := 0;
if outBuf then
dwAction := dwAction or PURGE_TXABORT or PURGE_TXCLEAR;
// Flush the TX data buffer
if inBuf then
dwAction := dwAction or PURGE_RXABORT or PURGE_RXCLEAR;
PurgeComm( FComPortHandle, dwAction );
// Used by the RX packet mechanism
FFirstByteOfPacketTime := DWORD(-1); // time not valid
end;

// v1.02: returns the output buffer free space or 65535 if
// not connected }
function TCommPortDriver.OutFreeSpace: word;
var stat: TCOMSTAT;
errs: DWORD;
begin
if not Connected then
Result := 65535
else
begin
ClearCommError( FComPortHandle, errs, @stat );
Result := FComPortOutBufSize - stat.cbOutQue;
end;
end;

// Send data
{function TCommPortDriver.SendData( DataPtr: pointer; DataSize: integer ): boolean;
var nsent: DWORD;
begin
Result := WriteFile( FComPortHandle, DataPtr^, DataSize, nsent, nil );
Result := Result and (nsent=DataSize);
end;}

{ Send data (breaks the data in small packets if it doesn't fit in the output
buffer) }
function TCommPortDriver.SendData( DataPtr: pointer; DataSize: integer ): integer;
var nToSend, nSent: integer;
t1: longint;
begin
{ 0 bytes sent }
Result := 0;
{ Do nothing if not connected }
if not Connected then
exit;
{ Current time }
t1 := GetTickCount;
{ Loop until all data sent or timeout occurred }
while DataSize > 0 do
begin
{ Get output buffer free space }
nToSend := OutFreeSpace;
{ If output buffer has some free space... }
if nToSend > 0 then
begin
{ Don't send more bytes than we actually have to send }
if nToSend > DataSize then
nToSend := DataSize;
{ Send }
WriteFile( FComPortHandle, DataPtr^, DataSize, nSent, nil );
nSent := abs( nSent );
{ Update number of bytes sent }
Result := Result + nSent;
{ v1.06 : Inc. data pointer!!! }
DataPtr := pchar(DataPtr) + nSent;
{ Decrease the count of bytes to send }
DataSize := DataSize - nSent;
{ Get current time }
t1 := GetTickCount;
{ Continue. This skips the time check below (don't stop
trasmitting if the FOutputTimeout is set too low) }
continue;
end;
{ Buffer is full. If we are waiting too long then
invert the number of bytes sent and exit }
if (GetTickCount-t1) > FOutputTimeout then
begin
Result := -Result;
exit;
end;
end;
end;

// Send a pascal string (NULL terminated if $H+ (default))
function TCommPortDriver.SendString( s: string ): boolean;
var len: integer;
begin
len := length( s );
{$IFOPT H+}
// New syle pascal string (NULL terminated)
Result := SendData( pchar(s), len ) = len;
{$ELSE}
// Old style pascal string (s[0] = length)
Result := SendData( pchar(@s[1]), len ) = len;
{$ENDIF}
end;

// v1.02: send a C-style strings (NULL terminated)
function TCommPortDriver.SendZString( s: pchar ): boolean;
var len: integer;
begin
len := strlen( s );
Result := SendData( s, len ) = len;
end;

// v1.02: set DTR line high (onOff=TRUE) or low (onOff=FALSE).
// You must not use HW handshaking.
procedure TCommPortDriver.ToggleDTR( onOff: boolean );
const funcs: array[boolean] of integer = (CLRDTR,SETDTR);
begin
if Connected then
EscapeCommFunction( FComPortHandle, funcs[onOff] );
end;

// v1.02: set RTS line high (onOff=TRUE) or low (onOff=FALSE).
// You must not use HW handshaking.
procedure TCommPortDriver.ToggleRTS( onOff: boolean );
const funcs: array[boolean] of integer = (CLRRTS,SETRTS);
begin
if Connected then
EscapeCommFunction( FComPortHandle, funcs[onOff] );
end;

// COM port polling proc
// v1.03: added support for PacketSize
// v1.04: fixed some bugs
// v1.05: fixed some bugs
procedure TCommPortDriver.TimerWndProc( var msg: TMessage );
var nRead, dummy: dword;
comStat: TCOMSTAT;
t: dword;
begin
if (msg.Msg = WM_TIMER) and Connected then
begin
// If PacketSize is > 0 then raise the OnReceiveData event only if the RX buffer
// has at least PacketSize bytes in it.
ClearCommError( FComPortHandle, dummy, @comStat );
if (FPacketSize > 0) then
begin
// Complete packet received ?
if comStat.cbInQue >= FPacketSize then
begin
t := GetTickCount;
repeat
// Read the packet and pass it to the app
nRead := 0;
if ReadFile( FComPortHandle, FTempInBuffer^, FPacketSize, nRead, nil ) then
if (nRead <> 0) and Assigned(FComPortReceivePacket) then
FComPortReceivePacket( Self, FTempInBuffer, nRead, t-FFirstByteOfPacketTime );
// Adjust time
if comStat.cbInQue > FPacketSize then
begin
t := t + DelayForRX( FComPortBaudRate, FPacketSize );
FFirstByteOfPacketTime := FFirstByteOfPacketTime + DelayForRX( FComPortBaudRate, FPacketSize )
end;
comStat.cbInQue := comStat.cbInQue - FPacketSize;
if comStat.cbInQue = 0 then
FFirstByteOfPacketTime := DWORD(-1);
until comStat.cbInQue < FPacketSize;
// Done
exit;
end;
// Handle packet timeouts
if (FPacketTimeout > 0) and (FFirstByteOfPacketTime <> DWORD(-1)) and
(GetTickCount - FFirstByteOfPacketTime > FPacketTimeout) then
begin
nRead := 0;
// Read the "incomplete" packet
if ReadFile( FComPortHandle, FTempInBuffer^, comStat.cbInQue, nRead, nil ) then
// If PacketMode is not pmDiscard then pass the packet to the app
if (FPacketMode <> pmDiscard) and (nRead <> 0) and Assigned(FComPortReceivePacket) then
FComPortReceivePacket( Self, FTempInBuffer, nRead, GetTickCount-FFirstByteOfPacketTime );
// Restart waiting for a packet
FFirstByteOfPacketTime := DWORD(-1);
// Done
exit;
end;
// Start time
if (comStat.cbInQue > 0) and (FFirstByteOfPacketTime = DWORD(-1)) then
FFirstByteOfPacketTime := GetTickCount;
// Done
exit;
end;

// Standard data handling
nRead := 0;
if ReadFile( FComPortHandle, FTempInBuffer^, FComPortInBufSize, nRead, nil ) then
if (nRead <> 0) and Assigned(FComPortReceiveData) then
FComPortReceiveData( Self, FTempInBuffer, nRead );
end;
end;

procedure Register;
begin
{ Register this component and show it in the 'System' tab
of the component palette }
RegisterComponents('System', [TCommPortDriver]);
end;

end.

接受答案了.