main.~pas

一个不错的串口调试工具！！ 利用常用的SPCOMM控件

unit main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Buttons, StdCtrls, Spin, ExtCtrls, ImgList, Spcomm, shlobj,
  ComCtrls;

type
  TFrmMain = class(TForm)
    Timer1: TTimer;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    Comm1: TComm;
    Panel3: TPanel;
    Button6: TButton;
    cbAutoClean: TCheckBox;
    cbRecHex: TCheckBox;
    Button8: TButton;
    edRx: TEdit;
    edTx: TEdit;
    Button5: TButton;
    GroupBox1: TGroupBox;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    Label7: TLabel;
    Shape1: TShape;
    btnSwitch: TButton;
    ComboBox1: TComboBox;
    ComboBox2: TComboBox;
    ComboBox3: TComboBox;
    ComboBox4: TComboBox;
    ComboBox5: TComboBox;
    Panel1: TPanel;
    Memo2: TMemo;
    Button1: TButton;
    cbAutoSend: TCheckBox;
    btnSend: TButton;
    cbsendHex: TCheckBox;
    Label1: TLabel;
    SpinEdit1: TSpinEdit;
    Label2: TLabel;
    Panel2: TPanel;
    Memo1: TMemo;
    StatusBar1: TStatusBar;
    Shape2: TShape;
    procedure btnSwitchClick(Sender: TObject);
    procedure BitBtn1Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure SpinEdit1Change(Sender: TObject);
    procedure cbAutoSendClick(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure btnSendClick(Sender: TObject);
    procedure Comm1ReceiveData(Sender: TObject; Buffer: Pointer;
      BufferLength: Word);
    procedure ComboBox1Change(Sender: TObject);
    procedure ComboBox2Change(Sender: TObject);
    procedure ComboBox3Change(Sender: TObject);
    procedure ComboBox4Change(Sender: TObject);
    procedure ComboBox5Change(Sender: TObject);

    private
    { Private declarations }
    FShowText:Boolean;
    FRXNum:Integer;
    FTXNum:Integer;
    procedure ShowRX;
    procedure ShowTX;
    procedure ShowStatus;
    procedure SendString(const str:string);
  public
    { Public declarations }
  end;

var
  FrmMain: TFrmMain;

implementation

const
  minWidth=627;
  minHeight=444;
  idAbout =$F200;

{$R *.dfm}

procedure EnumComPorts(Ports: TStrings);
var
  KeyHandle: HKEY;
  ErrCode, Index: Integer;
  ValueName, Data: string;
  ValueLen, DataLen, ValueType: DWORD;
  TmpPorts: TStringList;
begin
  ErrCode := RegOpenKeyEx(
    HKEY_LOCAL_MACHINE,
    'HARDWARE\DEVICEMAP\SERIALCOMM',
    0,
    KEY_READ,
    KeyHandle);

  if ErrCode <> ERROR_SUCCESS then
    Exit;

  TmpPorts := TStringList.Create;
  try
    Index := 0;
    repeat
      ValueLen := 256;
      DataLen := 256;
      SetLength(ValueName, ValueLen);
      SetLength(Data, DataLen);
      ErrCode := RegEnumValue(
        KeyHandle,
        Index,
        PChar(ValueName),
        Cardinal(ValueLen),
        nil,
        @ValueType,
        PByte(PChar(Data)),
        @DataLen);

      if ErrCode = ERROR_SUCCESS then
      begin
        SetLength(Data, DataLen);
        TmpPorts.Add(Data);
        Inc(Index);
      end
      else
        if ErrCode <> ERROR_NO_MORE_ITEMS then
          exit;

    until (ErrCode <> ERROR_SUCCESS) ;

    TmpPorts.Sort;
    Ports.Assign(TmpPorts);
  finally
    RegCloseKey(KeyHandle);
    TmpPorts.Free;
  end;

end;




procedure TFrmMain.btnSwitchClick(Sender: TObject);
var BaudRate :integer;
begin
if btnSwitch.Caption = '打开串口' then
  begin
  Comm1.StartComm;
  btnSwitch.Caption := '关闭串口';
  ComboBox1.Enabled := false;
  ComboBox2.Enabled := false;
  ComboBox3.Enabled := false;
  ComboBox4.Enabled := false;
  ComboBox5.Enabled := false;
  btnSend.Enabled   := true;
  shape1.Brush.Color:=clred;
  end
else
  begin
  Comm1.StopComm;
  btnSwitch.Caption := '打开串口';
  ComboBox1.Enabled := true;
  ComboBox2.Enabled := true;
  ComboBox3.Enabled := true;
  ComboBox4.Enabled := true;
  ComboBox5.Enabled := true;
  btnSend.Enabled   := false;
  shape1.Brush.Color:=clMedGray;
  end;
Timer1.Enabled := cbAutoSend.Checked;
ShowStatus;
end;

procedure TFrmMain.BitBtn1Click(Sender: TObject);
begin
  Close;
end;

procedure TFrmMain.Button6Click(Sender: TObject);
begin
  Memo1.Clear;
end;

procedure TFrmMain.FormCreate(Sender: TObject);
begin
  FShowText:=True;
  FRXNum:=0;
  FTXNum:=0;
  EnumComPorts(ComboBox1.Items);
  ComboBox1.ItemIndex := 0;
  Comm1.CommName := ComboBox1.Text;
  ComboBox2.ItemIndex := 6;
  Comm1.BaudRate := StrToInt(ComboBox2.Text);
  ComboBox3.ItemIndex := 0;
  Comm1.Parity := None;
  ComboBox4.ItemIndex := 3;
  Comm1.ByteSize := _8;
  ComboBox5.ItemIndex := 0;
  Comm1.StopBits := _1;
end;

procedure TFrmMain.ShowRX;
begin
  edRX.Text:='Rx:'+IntTostr(FRXNum);
end;

procedure TFrmMain.ShowStatus;
begin
  if btnSwitch.Caption = '关闭串口' then
  begin
    frmmain.Caption:='串口调试工具V1.0-仅应用于串口编程教学'+Format('%s Opened %s %s %s %s',[ComboBox1.Text,
      IntToStr(Comm1.BaudRate),ComboBox3.Text,ComboBox4.Text,ComboBox5.Text]);
  end
  else
  frmmain.Caption:='串口调试工具V1.0-仅应用于串口编程教学-串口已关闭！';
end;

procedure TFrmMain.ShowTX;
begin
  edTx.Text:='Tx:'+IntTostr(FTXNum);
end;

procedure TFrmMain.Button5Click(Sender: TObject);
begin
  FRXNum:=0;
  FTXNum:=0;
  ShowRX;
  ShowTX;
end;

procedure TFrmMain.Button1Click(Sender: TObject);
begin
  Memo2.Clear;
end;

procedure TFrmMain.SpinEdit1Change(Sender: TObject);
begin
  Timer1.Interval:=SpinEdit1.Value;
end;

procedure TFrmMain.cbAutoSendClick(Sender: TObject);
begin
  Timer1.Enabled:=cbAutoSend.Checked;
  SpinEdit1.Enabled := not cbAutoSend.Checked;
end;

procedure TFrmMain.Timer1Timer(Sender: TObject);
begin
  if Memo2.Text<>'' then
    btnSend.Click;
end;

function HexStrToStr(const S:string):string;
var
  t:Integer;
  ts:string;
  M,Code:Integer;
begin
  t:=1;
  Result:='';
  while t<=Length(S) do
  begin   
    while (t<=Length(S)) and (not (S[t] in ['0'..'9','A'..'F','a'..'f'])) do
      inc(t);
    if (t+1>Length(S))or(not (S[t+1] in ['0'..'9','A'..'F','a'..'f'])) then
      ts:='$'+S[t]
    else
      ts:='$'+S[t]+S[t+1];
    Val(ts,M,Code);
    if Code=0 then
      Result:=Result+Chr(M);
    inc(t,2);
  end;
end;

procedure TFrmMain.btnSendClick(Sender: TObject);
begin
  if cbsendHex.Checked then
    SendString(HexStrToStr(Memo2.Text))
  else
    SendString(Memo2.Text);
end;

procedure TFrmMain.SendString(const str: string);

begin
  if Comm1.WriteCommData(Pchar(str),Length(str)) then
    begin
    FTXNum:=FTXNum+Length(str);
    ShowTX;
    end;
end;

function StrToHexStr(const S:string):string;
var
  I:Integer;
begin
  for I:=1 to Length(S) do
  begin
    if I=1 then
      Result:=IntToHex(Ord(S[1]),2)
    else Result:=Result+' '+IntToHex(Ord(S[I]),2);
  end;
end;

procedure TFrmMain.Comm1ReceiveData(Sender: TObject; Buffer: Pointer;
  BufferLength: Word);
var str :string;
begin
  if cbAutoClean.Checked and (Memo1.Lines.Count > 100) then
     Memo1.Clear;
  SetLength(Str,BufferLength);
  move(buffer^,pchar(@Str[1])^,bufferlength);
  if FShowText then
  begin
    if cbRecHex.Checked then
      Memo1.Text:=Memo1.Text+StrToHexStr(Str)+' '
    else
      Memo1.Text := Memo1.Text + Str;
  Memo1.SelStart := Length(Memo1.Text);
  Memo1.SelLength:= 0;
  Memo1.Perform(EM_SCROLLCARET,0,0);
  end;
  FRXNum:=FRXNum+bufferlength;
  ShowRX;
end;

procedure TFrmMain.ComboBox1Change(Sender: TObject);
begin
  Comm1.CommName:=ComboBox1.Text;
end;

procedure TFrmMain.ComboBox2Change(Sender: TObject);
var  BaudRate : Integer;
begin
  if ComboBox2.Text = 'Custom' then
    begin
      ComboBox2.Style := csDropDown;
      ComboBox2.SetFocus;
    end
  else begin
    if  ComboBox2.ItemIndex >0 then
      ComboBox2.Style := csDropDownList;
    if TryStrToInt(ComboBox2.Text,BaudRate) then
           Comm1.BaudRate := BaudRate;
  end;
end;

procedure TFrmMain.ComboBox3Change(Sender: TObject);
begin
  Comm1.Parity := TParity(ComboBox3.ItemIndex);
end;

procedure TFrmMain.ComboBox4Change(Sender: TObject);
begin
   Comm1.ByteSize :=  TByteSize(ComboBox4.ItemIndex);
end;

procedure TFrmMain.ComboBox5Change(Sender: TObject);
begin
  Comm1.StopBits := TStopBits(ComboBox5.ItemIndex);
end;

end.