Add native Delphi 1.0 TKPComm serial communications component
VBX registration is non-functional in VB4 16-bit (VBRegisterModel is a no-op, VBGetModelInfo never called). Native Delphi component avoids all DLL/export/registration issues — compiles directly into the IDE. TKPComm is a TComponent descendant calling the Windows 3.1 comm API directly. Uses RegisterClass/CreateWindow for WM_COMMNOTIFY dispatch with the component instance pointer stored in cbWndExtra. Includes a test application (KPTEST) with send/receive UI built entirely in code. Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
This commit is contained in:
parent
bf5268ade8
commit
dd8326d16a
3 changed files with 1012 additions and 0 deletions
734
delphi/KPCOMM.PAS
Normal file
734
delphi/KPCOMM.PAS
Normal file
|
|
@ -0,0 +1,734 @@
|
||||||
|
unit KPComm;
|
||||||
|
|
||||||
|
{ KPComm - Native Delphi 1.0 serial communications component. }
|
||||||
|
{ }
|
||||||
|
{ TKPComm is a non-visual TComponent descendant providing RS-232 serial }
|
||||||
|
{ I/O via the Windows 3.1 comm API. Installs to the "KP" palette tab. }
|
||||||
|
{ }
|
||||||
|
{ Port lifecycle: OpenComm -> BuildCommDCB + SetCommState -> }
|
||||||
|
{ EnableCommNotification -> CloseComm. }
|
||||||
|
{ }
|
||||||
|
{ WM_COMMNOTIFY messages are received through a hidden utility window }
|
||||||
|
{ with a registered class and dispatched to ProcessReceiveNotify, }
|
||||||
|
{ ProcessTransmitNotify, and ProcessEventNotify. }
|
||||||
|
{ }
|
||||||
|
{ Modem line status (CTS/DSR/CD) is tracked via shadow booleans toggled }
|
||||||
|
{ on transition events from GetCommEventMask, since the 16-bit comm API }
|
||||||
|
{ only provides transition events, not absolute line levels. }
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
SysUtils, Classes, WinTypes, WinProcs, Messages;
|
||||||
|
|
||||||
|
const
|
||||||
|
{ Communication events }
|
||||||
|
comEvReceive = 1;
|
||||||
|
comEvSend = 2;
|
||||||
|
comEvCTS = 3;
|
||||||
|
comEvDSR = 4;
|
||||||
|
comEvCD = 5;
|
||||||
|
comEvRing = 6;
|
||||||
|
comEvEOF = 7;
|
||||||
|
|
||||||
|
{ Error events }
|
||||||
|
comEvtBreak = 1001;
|
||||||
|
comEvtFrame = 1004;
|
||||||
|
comEvtOverrun = 1006;
|
||||||
|
comEvtRxOver = 1008;
|
||||||
|
comEvtParity = 1009;
|
||||||
|
comEvtTxFull = 1010;
|
||||||
|
|
||||||
|
type
|
||||||
|
THandshaking = (hsNone, hsXonXoff, hsRtsCts, hsBoth);
|
||||||
|
TInputMode = (imText, imBinary);
|
||||||
|
|
||||||
|
TKPComm = class(TComponent)
|
||||||
|
private
|
||||||
|
FCommId: Integer;
|
||||||
|
FHWndNotify: HWnd;
|
||||||
|
FCommPort: Integer;
|
||||||
|
FSettings: string;
|
||||||
|
FPortOpen: Boolean;
|
||||||
|
FInBufferSize: Integer;
|
||||||
|
FOutBufferSize: Integer;
|
||||||
|
FRThreshold: Integer;
|
||||||
|
FSThreshold: Integer;
|
||||||
|
FHandshaking: THandshaking;
|
||||||
|
FInputLen: Integer;
|
||||||
|
FInputMode: TInputMode;
|
||||||
|
FDTREnable: Boolean;
|
||||||
|
FRTSEnable: Boolean;
|
||||||
|
FNullDiscard: Boolean;
|
||||||
|
FEOFEnable: Boolean;
|
||||||
|
FParityReplace: string;
|
||||||
|
FBreakState: Boolean;
|
||||||
|
FCommEvent: Integer;
|
||||||
|
FCTSState: Boolean;
|
||||||
|
FDSRState: Boolean;
|
||||||
|
FCDState: Boolean;
|
||||||
|
FOnComm: TNotifyEvent;
|
||||||
|
procedure ApplyHandshaking;
|
||||||
|
procedure ApplyOptions;
|
||||||
|
procedure ClosePort;
|
||||||
|
procedure DoCommEvent(EventCode: Integer);
|
||||||
|
function GetInBufferCount: Integer;
|
||||||
|
function GetInput: string;
|
||||||
|
function GetOutBufferCount: Integer;
|
||||||
|
procedure OpenPort;
|
||||||
|
procedure ProcessEventNotify;
|
||||||
|
procedure ProcessReceiveNotify;
|
||||||
|
procedure ProcessTransmitNotify;
|
||||||
|
procedure SetBreak(Value: Boolean);
|
||||||
|
procedure SetCommPort(Value: Integer);
|
||||||
|
procedure SetDTREnable(Value: Boolean);
|
||||||
|
procedure SetHandshaking(Value: THandshaking);
|
||||||
|
procedure SetInBufferSize(Value: Integer);
|
||||||
|
procedure SetNullDiscard(Value: Boolean);
|
||||||
|
procedure SetOutBufferSize(Value: Integer);
|
||||||
|
procedure SetOutput(const Value: string);
|
||||||
|
procedure SetParityReplace(const Value: string);
|
||||||
|
procedure SetPortOpen(Value: Boolean);
|
||||||
|
procedure SetRTSEnable(Value: Boolean);
|
||||||
|
procedure SetSettings(const Value: string);
|
||||||
|
public
|
||||||
|
constructor Create(AOwner: TComponent); override;
|
||||||
|
destructor Destroy; override;
|
||||||
|
property Input: string read GetInput;
|
||||||
|
property Output: string write SetOutput;
|
||||||
|
property InBufferCount: Integer read GetInBufferCount;
|
||||||
|
property OutBufferCount: Integer read GetOutBufferCount;
|
||||||
|
property CDHolding: Boolean read FCDState;
|
||||||
|
property CTSHolding: Boolean read FCTSState;
|
||||||
|
property DSRHolding: Boolean read FDSRState;
|
||||||
|
property Break: Boolean read FBreakState write SetBreak;
|
||||||
|
property CommEvent: Integer read FCommEvent;
|
||||||
|
published
|
||||||
|
property CommPort: Integer read FCommPort write SetCommPort default 1;
|
||||||
|
property Settings: string read FSettings write SetSettings;
|
||||||
|
property PortOpen: Boolean read FPortOpen write SetPortOpen default False;
|
||||||
|
property InBufferSize: Integer read FInBufferSize write SetInBufferSize default 4096;
|
||||||
|
property OutBufferSize: Integer read FOutBufferSize write SetOutBufferSize default 4096;
|
||||||
|
property RThreshold: Integer read FRThreshold write FRThreshold default 0;
|
||||||
|
property SThreshold: Integer read FSThreshold write FSThreshold default 0;
|
||||||
|
property Handshaking: THandshaking read FHandshaking write SetHandshaking default hsNone;
|
||||||
|
property InputLen: Integer read FInputLen write FInputLen default 0;
|
||||||
|
property InputMode: TInputMode read FInputMode write FInputMode default imText;
|
||||||
|
property DTREnable: Boolean read FDTREnable write SetDTREnable default True;
|
||||||
|
property RTSEnable: Boolean read FRTSEnable write SetRTSEnable default True;
|
||||||
|
property NullDiscard: Boolean read FNullDiscard write SetNullDiscard default False;
|
||||||
|
property EOFEnable: Boolean read FEOFEnable write FEOFEnable default False;
|
||||||
|
property ParityReplace: string read FParityReplace write SetParityReplace;
|
||||||
|
property OnComm: TNotifyEvent read FOnComm write FOnComm;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure Register;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
const
|
||||||
|
{ WM_COMMNOTIFY notification codes }
|
||||||
|
CN_RECEIVE = $0001;
|
||||||
|
CN_TRANSMIT = $0002;
|
||||||
|
CN_EVENT = $0004;
|
||||||
|
|
||||||
|
{ DCB Flags field bit masks. The Windows 3.1 DCB packs thirteen 1-bit }
|
||||||
|
{ fields into a single UINT (Word) at offset 12 of the structure. }
|
||||||
|
{ Delphi 1.0 maps this UINT to TDCB.Flags. }
|
||||||
|
dcbBinary = $0001;
|
||||||
|
dcbRtsDisable = $0002;
|
||||||
|
dcbParity = $0004;
|
||||||
|
dcbOutxCtsFlow = $0008;
|
||||||
|
dcbOutxDsrFlow = $0010;
|
||||||
|
dcbDtrDisable = $0020;
|
||||||
|
dcbOutX = $0040;
|
||||||
|
dcbInX = $0080;
|
||||||
|
dcbPeChar = $0100;
|
||||||
|
dcbNull = $0200;
|
||||||
|
dcbChEvt = $0400;
|
||||||
|
dcbDtrflow = $0800;
|
||||||
|
dcbRtsflow = $1000;
|
||||||
|
|
||||||
|
{ Hidden notification window class name }
|
||||||
|
NotifyClassName = 'KPCommNotify';
|
||||||
|
|
||||||
|
var
|
||||||
|
NotifyClassRegistered: Boolean;
|
||||||
|
|
||||||
|
|
||||||
|
{ ----------------------------------------------------------------------- }
|
||||||
|
{ Hidden notification window procedure }
|
||||||
|
{ }
|
||||||
|
{ Receives WM_COMMNOTIFY from the comm driver. Retrieves the TKPComm }
|
||||||
|
{ instance pointer stored in the window's extra bytes (offset 0) and }
|
||||||
|
{ dispatches to the appropriate Process* method. }
|
||||||
|
{ ----------------------------------------------------------------------- }
|
||||||
|
|
||||||
|
function NotifyWndProc(Wnd: HWnd; Msg: Word;
|
||||||
|
WParam: Word; LParam: Longint): Longint; export;
|
||||||
|
var
|
||||||
|
Comm: TKPComm;
|
||||||
|
NotifyCode: Word;
|
||||||
|
begin
|
||||||
|
if Msg = wm_CommNotify then
|
||||||
|
begin
|
||||||
|
Comm := TKPComm(GetWindowLong(Wnd, 0));
|
||||||
|
if (Comm <> nil) and Comm.FPortOpen and (Comm.FCommId >= 0) then
|
||||||
|
begin
|
||||||
|
NotifyCode := Word(LParam);
|
||||||
|
if (NotifyCode and CN_RECEIVE) <> 0 then
|
||||||
|
Comm.ProcessReceiveNotify;
|
||||||
|
if (NotifyCode and CN_TRANSMIT) <> 0 then
|
||||||
|
Comm.ProcessTransmitNotify;
|
||||||
|
if (NotifyCode and CN_EVENT) <> 0 then
|
||||||
|
Comm.ProcessEventNotify;
|
||||||
|
end;
|
||||||
|
Result := 0;
|
||||||
|
end
|
||||||
|
else
|
||||||
|
Result := DefWindowProc(Wnd, Msg, WParam, LParam);
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
{ ----------------------------------------------------------------------- }
|
||||||
|
{ TKPComm }
|
||||||
|
{ ----------------------------------------------------------------------- }
|
||||||
|
|
||||||
|
procedure TKPComm.ApplyHandshaking;
|
||||||
|
var
|
||||||
|
DCB: TDCB;
|
||||||
|
begin
|
||||||
|
if GetCommState(FCommId, DCB) <> 0 then
|
||||||
|
Exit;
|
||||||
|
|
||||||
|
{ Clear all flow control flags }
|
||||||
|
DCB.Flags := DCB.Flags and
|
||||||
|
not (dcbOutxCtsFlow or dcbOutxDsrFlow or dcbOutX or dcbInX or
|
||||||
|
dcbRtsDisable or dcbRtsflow);
|
||||||
|
|
||||||
|
case FHandshaking of
|
||||||
|
hsXonXoff:
|
||||||
|
begin
|
||||||
|
DCB.Flags := DCB.Flags or dcbOutX or dcbInX;
|
||||||
|
DCB.XonChar := #$11;
|
||||||
|
DCB.XoffChar := #$13;
|
||||||
|
DCB.XonLim := 256;
|
||||||
|
DCB.XoffLim := 256;
|
||||||
|
end;
|
||||||
|
hsRtsCts:
|
||||||
|
begin
|
||||||
|
DCB.Flags := DCB.Flags or dcbOutxCtsFlow or dcbRtsflow;
|
||||||
|
end;
|
||||||
|
hsBoth:
|
||||||
|
begin
|
||||||
|
DCB.Flags := DCB.Flags or dcbOutxCtsFlow or dcbRtsflow or
|
||||||
|
dcbOutX or dcbInX;
|
||||||
|
DCB.XonChar := #$11;
|
||||||
|
DCB.XoffChar := #$13;
|
||||||
|
DCB.XonLim := 256;
|
||||||
|
DCB.XoffLim := 256;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
DCB.Id := FCommId;
|
||||||
|
SetCommState(DCB);
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
procedure TKPComm.ApplyOptions;
|
||||||
|
var
|
||||||
|
DCB: TDCB;
|
||||||
|
begin
|
||||||
|
if GetCommState(FCommId, DCB) <> 0 then
|
||||||
|
Exit;
|
||||||
|
|
||||||
|
if FNullDiscard then
|
||||||
|
DCB.Flags := DCB.Flags or dcbNull
|
||||||
|
else
|
||||||
|
DCB.Flags := DCB.Flags and not dcbNull;
|
||||||
|
|
||||||
|
if Length(FParityReplace) > 0 then
|
||||||
|
begin
|
||||||
|
DCB.Flags := DCB.Flags or dcbParity;
|
||||||
|
DCB.PeChar := FParityReplace[1];
|
||||||
|
end
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
DCB.Flags := DCB.Flags and not dcbParity;
|
||||||
|
DCB.PeChar := #0;
|
||||||
|
end;
|
||||||
|
|
||||||
|
DCB.Id := FCommId;
|
||||||
|
SetCommState(DCB);
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
procedure TKPComm.ClosePort;
|
||||||
|
begin
|
||||||
|
{ Set FPortOpen first to prevent stale WM_COMMNOTIFY processing }
|
||||||
|
FPortOpen := False;
|
||||||
|
|
||||||
|
if FCommId >= 0 then
|
||||||
|
begin
|
||||||
|
if FBreakState then
|
||||||
|
begin
|
||||||
|
ClearCommBreak(FCommId);
|
||||||
|
FBreakState := False;
|
||||||
|
end;
|
||||||
|
EscapeCommFunction(FCommId, CLRDTR);
|
||||||
|
EscapeCommFunction(FCommId, CLRRTS);
|
||||||
|
CloseComm(FCommId);
|
||||||
|
FCommId := -1;
|
||||||
|
end;
|
||||||
|
|
||||||
|
if FHWndNotify <> 0 then
|
||||||
|
begin
|
||||||
|
DestroyWindow(FHWndNotify);
|
||||||
|
FHWndNotify := 0;
|
||||||
|
end;
|
||||||
|
|
||||||
|
FCTSState := False;
|
||||||
|
FDSRState := False;
|
||||||
|
FCDState := False;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
constructor TKPComm.Create(AOwner: TComponent);
|
||||||
|
begin
|
||||||
|
inherited Create(AOwner);
|
||||||
|
FCommId := -1;
|
||||||
|
FHWndNotify := 0;
|
||||||
|
FCommPort := 1;
|
||||||
|
FSettings := '9600,N,8,1';
|
||||||
|
FPortOpen := False;
|
||||||
|
FInBufferSize := 4096;
|
||||||
|
FOutBufferSize := 4096;
|
||||||
|
FRThreshold := 0;
|
||||||
|
FSThreshold := 0;
|
||||||
|
FHandshaking := hsNone;
|
||||||
|
FInputLen := 0;
|
||||||
|
FInputMode := imText;
|
||||||
|
FDTREnable := True;
|
||||||
|
FRTSEnable := True;
|
||||||
|
FNullDiscard := False;
|
||||||
|
FEOFEnable := False;
|
||||||
|
FParityReplace := '?';
|
||||||
|
FBreakState := False;
|
||||||
|
FCommEvent := 0;
|
||||||
|
FCTSState := False;
|
||||||
|
FDSRState := False;
|
||||||
|
FCDState := False;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
destructor TKPComm.Destroy;
|
||||||
|
begin
|
||||||
|
if FPortOpen then
|
||||||
|
ClosePort;
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
procedure TKPComm.DoCommEvent(EventCode: Integer);
|
||||||
|
begin
|
||||||
|
FCommEvent := EventCode;
|
||||||
|
if Assigned(FOnComm) then
|
||||||
|
FOnComm(Self);
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
function TKPComm.GetInBufferCount: Integer;
|
||||||
|
var
|
||||||
|
Stat: TComStat;
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
if not FPortOpen or (FCommId < 0) then
|
||||||
|
Exit;
|
||||||
|
GetCommError(FCommId, Stat);
|
||||||
|
Result := Stat.cbInQue;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
function TKPComm.GetInput: string;
|
||||||
|
var
|
||||||
|
Stat: TComStat;
|
||||||
|
BytesToRead: Integer;
|
||||||
|
BytesRead: Integer;
|
||||||
|
Buf: array[0..255] of Char;
|
||||||
|
begin
|
||||||
|
Result := '';
|
||||||
|
if not FPortOpen or (FCommId < 0) then
|
||||||
|
Exit;
|
||||||
|
|
||||||
|
GetCommError(FCommId, Stat);
|
||||||
|
BytesToRead := Stat.cbInQue;
|
||||||
|
|
||||||
|
if (FInputLen > 0) and (BytesToRead > FInputLen) then
|
||||||
|
BytesToRead := FInputLen;
|
||||||
|
if BytesToRead > 255 then
|
||||||
|
BytesToRead := 255;
|
||||||
|
if BytesToRead <= 0 then
|
||||||
|
Exit;
|
||||||
|
|
||||||
|
BytesRead := ReadComm(FCommId, @Buf, BytesToRead);
|
||||||
|
if BytesRead <= 0 then
|
||||||
|
Exit;
|
||||||
|
|
||||||
|
{ Set string length and copy data directly -- preserves embedded nulls }
|
||||||
|
{ for binary mode, and works correctly for text mode as well. }
|
||||||
|
Result[0] := Chr(BytesRead);
|
||||||
|
Move(Buf, Result[1], BytesRead);
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
function TKPComm.GetOutBufferCount: Integer;
|
||||||
|
var
|
||||||
|
Stat: TComStat;
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
if not FPortOpen or (FCommId < 0) then
|
||||||
|
Exit;
|
||||||
|
GetCommError(FCommId, Stat);
|
||||||
|
Result := Stat.cbOutQue;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
procedure TKPComm.OpenPort;
|
||||||
|
var
|
||||||
|
WC: TWndClass;
|
||||||
|
DCB: TDCB;
|
||||||
|
Buf: array[0..255] of Char;
|
||||||
|
Setting: string;
|
||||||
|
RxTh: Integer;
|
||||||
|
TxTh: Integer;
|
||||||
|
begin
|
||||||
|
{ Open the comm port }
|
||||||
|
StrPCopy(Buf, 'COM' + IntToStr(FCommPort));
|
||||||
|
FCommId := OpenComm(Buf, FInBufferSize, FOutBufferSize);
|
||||||
|
if FCommId < 0 then
|
||||||
|
raise Exception.Create('Cannot open COM' + IntToStr(FCommPort) +
|
||||||
|
' (error ' + IntToStr(FCommId) + ')');
|
||||||
|
|
||||||
|
{ Configure baud/parity/data/stop from Settings string }
|
||||||
|
if GetCommState(FCommId, DCB) <> 0 then
|
||||||
|
begin
|
||||||
|
CloseComm(FCommId);
|
||||||
|
FCommId := -1;
|
||||||
|
raise Exception.Create('GetCommState failed');
|
||||||
|
end;
|
||||||
|
|
||||||
|
Setting := 'COM' + IntToStr(FCommPort) + ':' + FSettings;
|
||||||
|
StrPCopy(Buf, Setting);
|
||||||
|
if BuildCommDCB(Buf, DCB) <> 0 then
|
||||||
|
begin
|
||||||
|
CloseComm(FCommId);
|
||||||
|
FCommId := -1;
|
||||||
|
raise Exception.Create('Invalid Settings: ' + FSettings);
|
||||||
|
end;
|
||||||
|
|
||||||
|
DCB.Flags := DCB.Flags or dcbBinary;
|
||||||
|
DCB.Id := FCommId;
|
||||||
|
if SetCommState(DCB) <> 0 then
|
||||||
|
begin
|
||||||
|
CloseComm(FCommId);
|
||||||
|
FCommId := -1;
|
||||||
|
raise Exception.Create('SetCommState failed');
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ Apply handshaking }
|
||||||
|
ApplyHandshaking;
|
||||||
|
|
||||||
|
{ Apply null-discard and parity-replace }
|
||||||
|
ApplyOptions;
|
||||||
|
|
||||||
|
{ Set DTR and RTS lines }
|
||||||
|
if FDTREnable then
|
||||||
|
EscapeCommFunction(FCommId, SETDTR)
|
||||||
|
else
|
||||||
|
EscapeCommFunction(FCommId, CLRDTR);
|
||||||
|
if FRTSEnable then
|
||||||
|
EscapeCommFunction(FCommId, SETRTS)
|
||||||
|
else
|
||||||
|
EscapeCommFunction(FCommId, CLRRTS);
|
||||||
|
|
||||||
|
{ Register notification window class (once per process) }
|
||||||
|
if not NotifyClassRegistered then
|
||||||
|
begin
|
||||||
|
FillChar(WC, SizeOf(WC), 0);
|
||||||
|
WC.lpfnWndProc := @NotifyWndProc;
|
||||||
|
WC.cbWndExtra := SizeOf(Longint);
|
||||||
|
WC.hInstance := HInstance;
|
||||||
|
WC.lpszClassName := NotifyClassName;
|
||||||
|
if not RegisterClass(WC) then
|
||||||
|
begin
|
||||||
|
CloseComm(FCommId);
|
||||||
|
FCommId := -1;
|
||||||
|
raise Exception.Create('RegisterClass failed');
|
||||||
|
end;
|
||||||
|
NotifyClassRegistered := True;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ Create hidden notification window and store Self for dispatch }
|
||||||
|
FHWndNotify := CreateWindow(NotifyClassName, '', ws_Popup,
|
||||||
|
0, 0, 0, 0, 0, 0, HInstance, nil);
|
||||||
|
if FHWndNotify = 0 then
|
||||||
|
begin
|
||||||
|
CloseComm(FCommId);
|
||||||
|
FCommId := -1;
|
||||||
|
raise Exception.Create('CreateWindow failed');
|
||||||
|
end;
|
||||||
|
SetWindowLong(FHWndNotify, 0, Longint(Self));
|
||||||
|
|
||||||
|
{ Enable event mask for modem status, errors, and breaks }
|
||||||
|
SetCommEventMask(FCommId,
|
||||||
|
ev_CTS or ev_DSR or ev_RLSD or ev_Ring or
|
||||||
|
ev_Err or ev_Break or ev_RxChar);
|
||||||
|
|
||||||
|
{ Enable comm notifications -- -1 disables the notification }
|
||||||
|
if FRThreshold > 0 then
|
||||||
|
RxTh := FRThreshold
|
||||||
|
else
|
||||||
|
RxTh := -1;
|
||||||
|
if FSThreshold > 0 then
|
||||||
|
TxTh := FSThreshold
|
||||||
|
else
|
||||||
|
TxTh := -1;
|
||||||
|
EnableCommNotification(FCommId, FHWndNotify, RxTh, TxTh);
|
||||||
|
|
||||||
|
{ Reset modem line shadow state }
|
||||||
|
FCTSState := False;
|
||||||
|
FDSRState := False;
|
||||||
|
FCDState := False;
|
||||||
|
|
||||||
|
FPortOpen := True;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
procedure TKPComm.ProcessEventNotify;
|
||||||
|
var
|
||||||
|
EvtMask: Word;
|
||||||
|
Stat: TComStat;
|
||||||
|
ErrFlags: Integer;
|
||||||
|
begin
|
||||||
|
EvtMask := GetCommEventMask(FCommId,
|
||||||
|
ev_CTS or ev_DSR or ev_RLSD or ev_Ring or ev_Err or ev_Break);
|
||||||
|
|
||||||
|
if (EvtMask and ev_Break) <> 0 then
|
||||||
|
DoCommEvent(comEvtBreak);
|
||||||
|
|
||||||
|
{ Modem line shadow state: toggle on each transition event. }
|
||||||
|
{ The 16-bit comm API only provides transition events, not }
|
||||||
|
{ absolute line levels. }
|
||||||
|
if (EvtMask and ev_CTS) <> 0 then
|
||||||
|
begin
|
||||||
|
FCTSState := not FCTSState;
|
||||||
|
DoCommEvent(comEvCTS);
|
||||||
|
end;
|
||||||
|
|
||||||
|
if (EvtMask and ev_DSR) <> 0 then
|
||||||
|
begin
|
||||||
|
FDSRState := not FDSRState;
|
||||||
|
DoCommEvent(comEvDSR);
|
||||||
|
end;
|
||||||
|
|
||||||
|
if (EvtMask and ev_RLSD) <> 0 then
|
||||||
|
begin
|
||||||
|
FCDState := not FCDState;
|
||||||
|
DoCommEvent(comEvCD);
|
||||||
|
end;
|
||||||
|
|
||||||
|
if (EvtMask and ev_Ring) <> 0 then
|
||||||
|
DoCommEvent(comEvRing);
|
||||||
|
|
||||||
|
if (EvtMask and ev_Err) <> 0 then
|
||||||
|
begin
|
||||||
|
ErrFlags := GetCommError(FCommId, Stat);
|
||||||
|
if (ErrFlags and ce_Frame) <> 0 then
|
||||||
|
DoCommEvent(comEvtFrame);
|
||||||
|
if (ErrFlags and ce_Overrun) <> 0 then
|
||||||
|
DoCommEvent(comEvtOverrun);
|
||||||
|
if (ErrFlags and ce_RxOver) <> 0 then
|
||||||
|
DoCommEvent(comEvtRxOver);
|
||||||
|
if (ErrFlags and ce_RxParity) <> 0 then
|
||||||
|
DoCommEvent(comEvtParity);
|
||||||
|
if (ErrFlags and ce_TxFull) <> 0 then
|
||||||
|
DoCommEvent(comEvtTxFull);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
procedure TKPComm.ProcessReceiveNotify;
|
||||||
|
var
|
||||||
|
Stat: TComStat;
|
||||||
|
begin
|
||||||
|
if FRThreshold <= 0 then
|
||||||
|
Exit;
|
||||||
|
GetCommError(FCommId, Stat);
|
||||||
|
if Integer(Stat.cbInQue) >= FRThreshold then
|
||||||
|
DoCommEvent(comEvReceive);
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
procedure TKPComm.ProcessTransmitNotify;
|
||||||
|
var
|
||||||
|
Stat: TComStat;
|
||||||
|
begin
|
||||||
|
if FSThreshold <= 0 then
|
||||||
|
Exit;
|
||||||
|
GetCommError(FCommId, Stat);
|
||||||
|
if Integer(Stat.cbOutQue) <= FSThreshold then
|
||||||
|
DoCommEvent(comEvSend);
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
procedure TKPComm.SetBreak(Value: Boolean);
|
||||||
|
begin
|
||||||
|
FBreakState := Value;
|
||||||
|
if FPortOpen and (FCommId >= 0) then
|
||||||
|
begin
|
||||||
|
if FBreakState then
|
||||||
|
SetCommBreak(FCommId)
|
||||||
|
else
|
||||||
|
ClearCommBreak(FCommId);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
procedure TKPComm.SetCommPort(Value: Integer);
|
||||||
|
begin
|
||||||
|
if FPortOpen then
|
||||||
|
raise Exception.Create('Cannot change CommPort while port is open');
|
||||||
|
if (Value < 1) or (Value > 16) then
|
||||||
|
raise Exception.Create('CommPort must be 1..16');
|
||||||
|
FCommPort := Value;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
procedure TKPComm.SetDTREnable(Value: Boolean);
|
||||||
|
begin
|
||||||
|
FDTREnable := Value;
|
||||||
|
if FPortOpen and (FCommId >= 0) then
|
||||||
|
begin
|
||||||
|
if FDTREnable then
|
||||||
|
EscapeCommFunction(FCommId, SETDTR)
|
||||||
|
else
|
||||||
|
EscapeCommFunction(FCommId, CLRDTR);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
procedure TKPComm.SetHandshaking(Value: THandshaking);
|
||||||
|
begin
|
||||||
|
FHandshaking := Value;
|
||||||
|
if FPortOpen and (FCommId >= 0) then
|
||||||
|
ApplyHandshaking;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
procedure TKPComm.SetInBufferSize(Value: Integer);
|
||||||
|
begin
|
||||||
|
if FPortOpen then
|
||||||
|
raise Exception.Create('Cannot change InBufferSize while port is open');
|
||||||
|
if Value < 64 then
|
||||||
|
raise Exception.Create('InBufferSize must be >= 64');
|
||||||
|
FInBufferSize := Value;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
procedure TKPComm.SetNullDiscard(Value: Boolean);
|
||||||
|
begin
|
||||||
|
FNullDiscard := Value;
|
||||||
|
if FPortOpen and (FCommId >= 0) then
|
||||||
|
ApplyOptions;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
procedure TKPComm.SetOutBufferSize(Value: Integer);
|
||||||
|
begin
|
||||||
|
if FPortOpen then
|
||||||
|
raise Exception.Create('Cannot change OutBufferSize while port is open');
|
||||||
|
if Value < 64 then
|
||||||
|
raise Exception.Create('OutBufferSize must be >= 64');
|
||||||
|
FOutBufferSize := Value;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
procedure TKPComm.SetOutput(const Value: string);
|
||||||
|
var
|
||||||
|
Written: Integer;
|
||||||
|
begin
|
||||||
|
if not FPortOpen or (FCommId < 0) then
|
||||||
|
raise Exception.Create('Port is not open');
|
||||||
|
if Length(Value) > 0 then
|
||||||
|
begin
|
||||||
|
Written := WriteComm(FCommId, @Value[1], Length(Value));
|
||||||
|
if Written < 0 then
|
||||||
|
DoCommEvent(comEvtTxFull);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
procedure TKPComm.SetParityReplace(const Value: string);
|
||||||
|
begin
|
||||||
|
FParityReplace := Value;
|
||||||
|
if FPortOpen and (FCommId >= 0) then
|
||||||
|
ApplyOptions;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
procedure TKPComm.SetPortOpen(Value: Boolean);
|
||||||
|
begin
|
||||||
|
if Value = FPortOpen then
|
||||||
|
Exit;
|
||||||
|
if Value then
|
||||||
|
OpenPort
|
||||||
|
else
|
||||||
|
ClosePort;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
procedure TKPComm.SetRTSEnable(Value: Boolean);
|
||||||
|
begin
|
||||||
|
FRTSEnable := Value;
|
||||||
|
if FPortOpen and (FCommId >= 0) then
|
||||||
|
begin
|
||||||
|
if FRTSEnable then
|
||||||
|
EscapeCommFunction(FCommId, SETRTS)
|
||||||
|
else
|
||||||
|
EscapeCommFunction(FCommId, CLRRTS);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
procedure TKPComm.SetSettings(const Value: string);
|
||||||
|
var
|
||||||
|
DCB: TDCB;
|
||||||
|
Buf: array[0..255] of Char;
|
||||||
|
Setting: string;
|
||||||
|
begin
|
||||||
|
FSettings := Value;
|
||||||
|
if FPortOpen and (FCommId >= 0) then
|
||||||
|
begin
|
||||||
|
if GetCommState(FCommId, DCB) <> 0 then
|
||||||
|
Exit;
|
||||||
|
Setting := 'COM' + IntToStr(FCommPort) + ':' + FSettings;
|
||||||
|
StrPCopy(Buf, Setting);
|
||||||
|
if BuildCommDCB(Buf, DCB) <> 0 then
|
||||||
|
Exit;
|
||||||
|
DCB.Flags := DCB.Flags or dcbBinary;
|
||||||
|
DCB.Id := FCommId;
|
||||||
|
SetCommState(DCB);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
{ ----------------------------------------------------------------------- }
|
||||||
|
{ Component registration }
|
||||||
|
{ ----------------------------------------------------------------------- }
|
||||||
|
|
||||||
|
procedure Register;
|
||||||
|
begin
|
||||||
|
RegisterComponents('KP', [TKPComm]);
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
||||||
11
delphi/KPTEST.DPR
Normal file
11
delphi/KPTEST.DPR
Normal file
|
|
@ -0,0 +1,11 @@
|
||||||
|
program KPTest;
|
||||||
|
|
||||||
|
uses
|
||||||
|
Forms,
|
||||||
|
TestMain in 'TESTMAIN.PAS',
|
||||||
|
KPComm in 'KPCOMM.PAS';
|
||||||
|
|
||||||
|
begin
|
||||||
|
Application.CreateForm(TMainForm, MainForm);
|
||||||
|
Application.Run;
|
||||||
|
end.
|
||||||
267
delphi/TESTMAIN.PAS
Normal file
267
delphi/TESTMAIN.PAS
Normal file
|
|
@ -0,0 +1,267 @@
|
||||||
|
unit TestMain;
|
||||||
|
|
||||||
|
{ Test application for the TKPComm serial communications component. }
|
||||||
|
{ Form and all controls are created in code (no DFM required). }
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
SysUtils, Classes, WinTypes, WinProcs, Messages,
|
||||||
|
Forms, Controls, StdCtrls, KPComm;
|
||||||
|
|
||||||
|
type
|
||||||
|
TMainForm = class(TForm)
|
||||||
|
private
|
||||||
|
FComm: TKPComm;
|
||||||
|
FLabelPort: TLabel;
|
||||||
|
FEditPort: TEdit;
|
||||||
|
FLabelSettings: TLabel;
|
||||||
|
FEditSettings: TEdit;
|
||||||
|
FBtnOpen: TButton;
|
||||||
|
FBtnClose: TButton;
|
||||||
|
FLabelStatus: TLabel;
|
||||||
|
FLabelRecv: TLabel;
|
||||||
|
FMemoRecv: TMemo;
|
||||||
|
FEditSend: TEdit;
|
||||||
|
FBtnSend: TButton;
|
||||||
|
FLabelInfo: TLabel;
|
||||||
|
procedure BtnCloseClick(Sender: TObject);
|
||||||
|
procedure BtnOpenClick(Sender: TObject);
|
||||||
|
procedure BtnSendClick(Sender: TObject);
|
||||||
|
procedure CommEvent(Sender: TObject);
|
||||||
|
procedure UpdateStatus;
|
||||||
|
public
|
||||||
|
constructor Create(AOwner: TComponent); override;
|
||||||
|
end;
|
||||||
|
|
||||||
|
var
|
||||||
|
MainForm: TMainForm;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
|
||||||
|
procedure TMainForm.BtnCloseClick(Sender: TObject);
|
||||||
|
begin
|
||||||
|
FComm.PortOpen := False;
|
||||||
|
FMemoRecv.Lines.Add('--- Port closed ---');
|
||||||
|
UpdateStatus;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
procedure TMainForm.BtnOpenClick(Sender: TObject);
|
||||||
|
begin
|
||||||
|
try
|
||||||
|
FComm.CommPort := StrToInt(FEditPort.Text);
|
||||||
|
FComm.Settings := FEditSettings.Text;
|
||||||
|
FComm.RThreshold := 1;
|
||||||
|
FComm.PortOpen := True;
|
||||||
|
FMemoRecv.Lines.Add('--- Port opened on COM' +
|
||||||
|
FEditPort.Text + ' at ' + FEditSettings.Text + ' ---');
|
||||||
|
except
|
||||||
|
on E: Exception do
|
||||||
|
FMemoRecv.Lines.Add('Open failed: ' + E.Message);
|
||||||
|
end;
|
||||||
|
UpdateStatus;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
procedure TMainForm.BtnSendClick(Sender: TObject);
|
||||||
|
begin
|
||||||
|
if Length(FEditSend.Text) = 0 then
|
||||||
|
Exit;
|
||||||
|
try
|
||||||
|
FComm.Output := FEditSend.Text + #13;
|
||||||
|
FMemoRecv.Lines.Add('TX: ' + FEditSend.Text);
|
||||||
|
FEditSend.Text := '';
|
||||||
|
except
|
||||||
|
on E: Exception do
|
||||||
|
FMemoRecv.Lines.Add('Send failed: ' + E.Message);
|
||||||
|
end;
|
||||||
|
UpdateStatus;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
procedure TMainForm.CommEvent(Sender: TObject);
|
||||||
|
var
|
||||||
|
S: string;
|
||||||
|
begin
|
||||||
|
case FComm.CommEvent of
|
||||||
|
comEvReceive:
|
||||||
|
begin
|
||||||
|
S := FComm.Input;
|
||||||
|
if Length(S) > 0 then
|
||||||
|
FMemoRecv.Lines.Add('RX: ' + S);
|
||||||
|
end;
|
||||||
|
comEvCTS:
|
||||||
|
FMemoRecv.Lines.Add('CTS changed');
|
||||||
|
comEvDSR:
|
||||||
|
FMemoRecv.Lines.Add('DSR changed');
|
||||||
|
comEvCD:
|
||||||
|
FMemoRecv.Lines.Add('CD changed');
|
||||||
|
comEvRing:
|
||||||
|
FMemoRecv.Lines.Add('Ring');
|
||||||
|
comEvEOF:
|
||||||
|
FMemoRecv.Lines.Add('EOF received');
|
||||||
|
comEvtBreak:
|
||||||
|
FMemoRecv.Lines.Add('Break received');
|
||||||
|
comEvtFrame:
|
||||||
|
FMemoRecv.Lines.Add('Framing error');
|
||||||
|
comEvtOverrun:
|
||||||
|
FMemoRecv.Lines.Add('Overrun error');
|
||||||
|
comEvtRxOver:
|
||||||
|
FMemoRecv.Lines.Add('RX buffer overflow');
|
||||||
|
comEvtParity:
|
||||||
|
FMemoRecv.Lines.Add('Parity error');
|
||||||
|
comEvtTxFull:
|
||||||
|
FMemoRecv.Lines.Add('TX buffer full');
|
||||||
|
end;
|
||||||
|
UpdateStatus;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
constructor TMainForm.Create(AOwner: TComponent);
|
||||||
|
begin
|
||||||
|
inherited CreateNew(AOwner);
|
||||||
|
|
||||||
|
Caption := 'KPComm Test';
|
||||||
|
Width := 500;
|
||||||
|
Height := 380;
|
||||||
|
BorderStyle := bsSingle;
|
||||||
|
|
||||||
|
{ Serial component }
|
||||||
|
FComm := TKPComm.Create(Self);
|
||||||
|
FComm.OnComm := CommEvent;
|
||||||
|
|
||||||
|
{ Row 1: Port and Settings }
|
||||||
|
FLabelPort := TLabel.Create(Self);
|
||||||
|
FLabelPort.Parent := Self;
|
||||||
|
FLabelPort.Left := 8;
|
||||||
|
FLabelPort.Top := 12;
|
||||||
|
FLabelPort.Caption := 'Port:';
|
||||||
|
|
||||||
|
FEditPort := TEdit.Create(Self);
|
||||||
|
FEditPort.Parent := Self;
|
||||||
|
FEditPort.Left := 44;
|
||||||
|
FEditPort.Top := 8;
|
||||||
|
FEditPort.Width := 32;
|
||||||
|
FEditPort.Text := '1';
|
||||||
|
|
||||||
|
FLabelSettings := TLabel.Create(Self);
|
||||||
|
FLabelSettings.Parent := Self;
|
||||||
|
FLabelSettings.Left := 88;
|
||||||
|
FLabelSettings.Top := 12;
|
||||||
|
FLabelSettings.Caption := 'Settings:';
|
||||||
|
|
||||||
|
FEditSettings := TEdit.Create(Self);
|
||||||
|
FEditSettings.Parent := Self;
|
||||||
|
FEditSettings.Left := 148;
|
||||||
|
FEditSettings.Top := 8;
|
||||||
|
FEditSettings.Width := 140;
|
||||||
|
FEditSettings.Text := '9600,N,8,1';
|
||||||
|
|
||||||
|
{ Row 2: Open/Close buttons and status }
|
||||||
|
FBtnOpen := TButton.Create(Self);
|
||||||
|
FBtnOpen.Parent := Self;
|
||||||
|
FBtnOpen.Left := 8;
|
||||||
|
FBtnOpen.Top := 38;
|
||||||
|
FBtnOpen.Width := 65;
|
||||||
|
FBtnOpen.Height := 25;
|
||||||
|
FBtnOpen.Caption := 'Open';
|
||||||
|
FBtnOpen.OnClick := BtnOpenClick;
|
||||||
|
|
||||||
|
FBtnClose := TButton.Create(Self);
|
||||||
|
FBtnClose.Parent := Self;
|
||||||
|
FBtnClose.Left := 80;
|
||||||
|
FBtnClose.Top := 38;
|
||||||
|
FBtnClose.Width := 65;
|
||||||
|
FBtnClose.Height := 25;
|
||||||
|
FBtnClose.Caption := 'Close';
|
||||||
|
FBtnClose.Enabled := False;
|
||||||
|
FBtnClose.OnClick := BtnCloseClick;
|
||||||
|
|
||||||
|
FLabelStatus := TLabel.Create(Self);
|
||||||
|
FLabelStatus.Parent := Self;
|
||||||
|
FLabelStatus.Left := 160;
|
||||||
|
FLabelStatus.Top := 44;
|
||||||
|
FLabelStatus.Caption := 'Closed';
|
||||||
|
|
||||||
|
{ Receive area }
|
||||||
|
FLabelRecv := TLabel.Create(Self);
|
||||||
|
FLabelRecv.Parent := Self;
|
||||||
|
FLabelRecv.Left := 8;
|
||||||
|
FLabelRecv.Top := 70;
|
||||||
|
FLabelRecv.Caption := 'Received:';
|
||||||
|
|
||||||
|
FMemoRecv := TMemo.Create(Self);
|
||||||
|
FMemoRecv.Parent := Self;
|
||||||
|
FMemoRecv.Left := 8;
|
||||||
|
FMemoRecv.Top := 86;
|
||||||
|
FMemoRecv.Width := 476;
|
||||||
|
FMemoRecv.Height := 186;
|
||||||
|
FMemoRecv.ScrollBars := ssVertical;
|
||||||
|
FMemoRecv.ReadOnly := True;
|
||||||
|
|
||||||
|
{ Send row }
|
||||||
|
FEditSend := TEdit.Create(Self);
|
||||||
|
FEditSend.Parent := Self;
|
||||||
|
FEditSend.Left := 8;
|
||||||
|
FEditSend.Top := 280;
|
||||||
|
FEditSend.Width := 400;
|
||||||
|
|
||||||
|
FBtnSend := TButton.Create(Self);
|
||||||
|
FBtnSend.Parent := Self;
|
||||||
|
FBtnSend.Left := 416;
|
||||||
|
FBtnSend.Top := 280;
|
||||||
|
FBtnSend.Width := 65;
|
||||||
|
FBtnSend.Height := 25;
|
||||||
|
FBtnSend.Caption := 'Send';
|
||||||
|
FBtnSend.Enabled := False;
|
||||||
|
FBtnSend.OnClick := BtnSendClick;
|
||||||
|
|
||||||
|
{ Status info line }
|
||||||
|
FLabelInfo := TLabel.Create(Self);
|
||||||
|
FLabelInfo.Parent := Self;
|
||||||
|
FLabelInfo.Left := 8;
|
||||||
|
FLabelInfo.Top := 316;
|
||||||
|
FLabelInfo.Width := 476;
|
||||||
|
FLabelInfo.Caption := 'RX: 0 TX: 0 Event: 0';
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
procedure TMainForm.UpdateStatus;
|
||||||
|
var
|
||||||
|
S: string;
|
||||||
|
begin
|
||||||
|
if FComm.PortOpen then
|
||||||
|
FLabelStatus.Caption := 'Open'
|
||||||
|
else
|
||||||
|
FLabelStatus.Caption := 'Closed';
|
||||||
|
|
||||||
|
FBtnOpen.Enabled := not FComm.PortOpen;
|
||||||
|
FBtnClose.Enabled := FComm.PortOpen;
|
||||||
|
FBtnSend.Enabled := FComm.PortOpen;
|
||||||
|
FEditSend.Enabled := FComm.PortOpen;
|
||||||
|
|
||||||
|
S := 'RX: ' + IntToStr(FComm.InBufferCount) +
|
||||||
|
' TX: ' + IntToStr(FComm.OutBufferCount);
|
||||||
|
if FComm.PortOpen then
|
||||||
|
begin
|
||||||
|
if FComm.CTSHolding then
|
||||||
|
S := S + ' CTS: On'
|
||||||
|
else
|
||||||
|
S := S + ' CTS: Off';
|
||||||
|
if FComm.DSRHolding then
|
||||||
|
S := S + ' DSR: On'
|
||||||
|
else
|
||||||
|
S := S + ' DSR: Off';
|
||||||
|
if FComm.CDHolding then
|
||||||
|
S := S + ' CD: On'
|
||||||
|
else
|
||||||
|
S := S + ' CD: Off';
|
||||||
|
end;
|
||||||
|
S := S + ' Event: ' + IntToStr(FComm.CommEvent);
|
||||||
|
FLabelInfo.Caption := S;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
end.
|
||||||
Loading…
Add table
Reference in a new issue