AI_Slop/WinComm
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add native Delphi 1.0 TKPComm serial communications component

Browse source 
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:
Scott Duensing 2026-02-25 22:04:54 -06:00
parent bf5268ade8
commit dd8326d16a
3 changed files with 1012 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

734
delphi/KPCOMM.PAS Normal file
View 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
View 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
View 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.