串口调试助手V1.0 DELPHI SPCOMM V1.1

{***************************************************************** *串口调试助手V1.0 DELPHI SPCOMM V1.1 *作 者：sky

*Email : mastersky@ *QQ : 11116580 *版 本：V1.0 *编写时间：2005/12/19

BitBtn1: TBitBtn; GroupBox1: TGroupBox; Label3: TLabel; Label4: TLabel; Label5: TLabel; Label6: TLabel; Label7: TLabel;

*说 明：本程序完全参照龚建伟VC版《串口调试助手V2.2》编写而成。仅供学习测试之 btnSwitch: TButton; 用。由于改用COMPORT控件为SPCOMM控件，整个代码已经经过大规模的改动，去除了E Panel5: TPanel; mail等与程序应用不太相关的部分，改进了绝大部分算法，添加原未完成的功能 ，程序依然 Button6: TButton; 是参照龚建伟VC版《串口调试助手V2.2》来编写的************************************ cbRecHex: TCheckBox; ******************************}

unit main; interface uses

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

TFrmMain = class(TForm) Panel1: TPanel; Panel2: TPanel; Panel3: TPanel; Memo1: TMemo; cbsendHex: TCheckBox; cbAutoSend: TCheckBox; Label1: TLabel; SpinEdit1: TSpinEdit; Label2: TLabel; Button1: TButton; Panel4: TPanel; btnSend: TButton; Button3: TButton; Button4: TButton; edSendFile: TEdit;

SpeedButton1: TSpeedButton; Memo2: TMemo; edStatus: TEdit; edRx: TEdit; edTx: TEdit; Button5: TButton; ImageList1: TImageList;

cbAutoClean: TCheckBox; btnStopShow: TButton; Button8: TButton; Button9: TButton; edPath: TEdit; Timer1: TTimer;

OpenDialog1: TOpenDialog; SaveDialog1: TSaveDialog; ComboBox1: TComboBox; ComboBox2: TComboBox; ComboBox3: TComboBox; ComboBox4: TComboBox; ComboBox5: TComboBox; Comm1: TComm; ImageOff: TImage; ImageOn: TImage;

procedure SpeedButton1Click(Sender: TObject); 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 btnStopShowClick(Sender: TObject); procedure Button9Click(Sender: TObject); procedure Button8Click(Sender: TObject); procedure Button3Click(Sender: TObject); procedure Button4Click(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);

procedure ComboBox2KeyPress(Sender: TObject; var Key: Char); procedure Memo2KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); private

{ Private declarations } OnTop : Boolean; FShowText:Boolean; FRXNum:Integer; FTXNum:Integer; procedure ShowRX; procedure ShowTX; procedure ShowStatus;

procedure SendFile(const filename:string); procedure SendString(const str:string);

lpbi.hwndOwner := Handle; lpbi.lpfn := nil;

lpbi.lpszTitle := PChar(Caption);

lpbi.ulFlags := BIF_RETURNONLYFSDIRS + BIF_EDITBOX; SHGetDesktopFolder(ID); initdir := PWChar(Root);

ID.ParseDisplayName(0, nil, InitDir, Eaten, rt, Att); lpbi.pidlRoot := rt;

GetMem(lpbi.pszDisplayName, MAX_PATH); try

Result := SHGetPathFromIDList(SHBrowseForFolder(lpbi), buf); except

FreeMem(lpbi.pszDisplayName); end;

if result then begin Directory := buf;

if Length(Directory) <> 3 then Directory := Directory + '\';

procedure WMSysCommand(VAR Message: TWMSysCommand); message WM_SYSCOM end; MAND; public

{ Public declarations } end; var

FrmMain: TFrmMain;

implementation const

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

{$R *.dfm}

function SelectDirectory(Handle: hwnd; const Caption: string; const Root: WideString; out Directory: string): Boolean; var lpBI: _BrowseInfo;

Buf: array[0..MAX_PATH] of char; ID: IShellFolder; Eaten, Att: Cardinal; rt: pItemIDList; initdir: PWideChar; begin

Result := False;

end;

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; // raise EComPort.Create(CError_RegError, ErrCode);

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; //raise EComPort.Create(CError_RegError, ErrCode);

until (ErrCode <> ERROR_SUCCESS) ;

TmpPorts.Sort; Ports.Assign(TmpPorts); finally

RegCloseKey(KeyHandle); TmpPorts.Free; end; end;

procedure TFrmMain.SpeedButton1Click(Sender: TObject); var

B:TBitmap; begin

B:=TBitmap.Create; if not OnTop then begin

SetWindowPos(FrmMain.handle, HWND_TOPMOST, FrmMain.Left, FrmMain.Top, FrmMain.Width, FrmMain.Height,0); if ImageList1.GetBitmap(1,B) then begin

串口调试助手V1.0 DELPHI SPCOMM V1.1

SpeedButton1.Glyph.Assign(B); end; end else begin

SetWindowPos(FrmMain.handle, HWND_NOTOPMOST, FrmMain.Left, FrmMain.Top, FrmMain.Width, FrmMain.Height,0); if ImageList1.GetBitmap(0,B) then begin

SpeedButton1.Glyph.Assign(B); end; end;

OnTop := not OnTop; SpeedButton1.Down := false; B.Free; end;

procedure TFrmMain.btnSwitchClick(Sender: TObject); var BaudRate :integer; begin

if btnSwitch.Caption = '打开串口' then begin

if not TryStrToInt(ComboBox2.Text,BaudRate) then begin

Application.MessageBox('波特率设定有误'+#13+ ' 请重新输入','警告',MB_ICONWARNING or MB_OK);

ComboBox2.SetFocus; exit; end;

Comm1.StartComm;

btnSwitch.Caption := '关闭串口'; ComboBox1.Enabled := false; ComboBox2.Enabled := false; ComboBox3.Enabled := false; ComboBox4.Enabled := false; ComboBox5.Enabled := false; btnSend.Enabled := true; ImageOff.Visible := false; ImageOn.Visible :=true; end

else //if Button1.Caption = '关闭串口' then begin

Comm1.StopComm;

btnSwitch.Caption := '打开串口'; ComboBox1.Enabled := true; ComboBox2.Enabled := true;

ComboBox3.Enabled := true; ComboBox4.Enabled := true; ComboBox5.Enabled := true; btnSend.Enabled := false; ImageOn.Visible := false; ImageOff.Visible :=true; 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); var myMenu : HMENU; begin

FrmMain.Constraints.MinHeight := minHeight; FrmMain.Constraints.MinWidth := minWidth;

FShowText:=True; FRXNum:=0; FTXNum:=0;

EnumComPorts(ComboBox1.Items); //得到串口列表 ComboBox1.ItemIndex := 0;

mName := 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;

myMenu := GetSystemMenu(Handle, False); AppendMenu(myMenu, MF_SEPARATOR, 0, ''); AppendMenu(myMenu, MF_STRING, idAbout, '关于'); end;

串口调试助手V1.0 DELPHI SPCOMM V1.1

procedure TFrmMain.ShowRX; begin

edRX.Text:='Rx:'+IntTostr(FRXNum); end;

procedure TFrmMain.ShowStatus; begin

if btnSwitch.Caption = '关闭串口' then begin

edStatus.Text:=Format(' STATUS: %s Opened %s %s %s %s',[ComboBox1.Text,

{ComboBox2.Text,}IntToStr(Comm1.BaudRate),ComboBox3.Text,ComboBox4.Text,ComboBox5.Text]); end

else edStatus.Text:=' STATUS: COM Port Closed'; 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;

串口调试助手V1.0 DELPHI SPCOMM V1.1

procedure TFrmMain.Timer1Timer(Sender: TObject); begin

if Memo2.Text<>'' then btnSend.Click; end;

procedure TFrmMain.btnStopShowClick(Sender: TObject); begin

FShowText:=not FShowText; if FShowText then

btnStopShow.Caption:='停止显示' else btnStopShow.Caption:='继续显示'; end;

procedure TFrmMain.Button9Click(Sender: TObject); var

Dir: string; begin

if SelectDirectory(FrmMain.Handle,'请选择要保存接收数据的目录',' ',Dir) then edPath.Text := Dir; end;

procedure TFrmMain.Button8Click(Sender: TObject); var S:string; begin

S := edPath.Text;

if not DirectoryExists(S) then CreateDir(S);

S:=S+'Rec'+FormatDateTime('yymmddhhssnn',Now)+'.txt'; Memo1.Lines.SaveToFile(S);

procedure TFrmMain.SendFile(const filename: string); var

S:TStringList; begin

S:=TStringList.Create; try

S.LoadFromFile(filename); SendString(S.Text); finally S.Free; end; end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// function HexStrToStr(const S:string):string; //16进制字符串转换成字符串 var t:Integer; ts:string; M,Code:Integer; begin t:=1; Result:='';

while t<=Length(S) do begin //xlh 2006.10.21

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];

Application.MessageBox(pchar(s+#13#13#9+'已保存'),'信息',MB_ICONWARNING or MB_O Val(ts,M,Code); K); end;

procedure TFrmMain.Button3Click(Sender: TObject); begin

if OpenDialog1.Execute then

edSendFile.Text:=OpenDialog1.FileName; end;

procedure TFrmMain.Button4Click(Sender: TObject); begin

if FileExists(edSendFile.Text) then SendFile(edSendFile.Text); end;

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; //字符串转换成16进制字符串 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 m1ReceiveData(Sender: TObject; Buffer: Pointer; BufferLength: Word); var str :string; begin

//Memo自动清空

if cbAutoClean.Checked and (Memo1.Lines.Count > 50) 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;

串口调试助手V1.0 DELPHI SPCOMM V1.1

procedure boBox1Change(Sender: TObject); begin

mName:=ComboBox1.Text; end;

procedure boBox2Change(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 boBox3Change(Sender: TObject); begin

//TParity = ( None, Odd, Even, Mark, Space ); Comm1.Parity := TParity(ComboBox3.ItemIndex); end;

procedure boBox4Change(Sender: TObject); begin

//TByteSize = ( _5, _6, _7, _8 );

Comm1.ByteSize := TByteSize(ComboBox4.ItemIndex); end;

procedure boBox5Change(Sender: TObject); begin

//TStopBits = ( _1, _1_5, _2 );

Comm1.StopBits := TStopBits(ComboBox5.ItemIndex); end;

procedure boBox2KeyPress(Sender: TObject; var Key: Char); begin

if not (Key in ['0'..'9',#8]) then Key := #0; end;

procedure TFrmMain.Memo2KeyDown(Sender: TObject; var Key: Word;

串口调试助手V1.0 DELPHI SPCOMM V1.1

Shift: TShiftState); begin

if (Shift=[ssAlt]) and (key=Ord('S')) and (btnSend.Enabled) then //快捷键 ALT + S btnSend.Click; end;

procedure TFrmMain.WMSysCommand(var Message: TWMSysCommand); begin Inherited;

if Message.CmdType = idAbout then

Application.MessageBox('== 串口调试助手Delphi SPCOMM版 1.1 == '+#13#13+ ' 相对于Sky的1.0版：'+#13+ '改用SPCOMM控件，程序更小巧、更好用'+#13+ '同时改进了部分算法，添加原未完成的功能'+#13#13+ ' 本程序完全参照龚建伟VC版'+#13+ ' 《串口调试助手V2.2》编写而成。'+#13+ ' 仅供学习测试之用'+#13#13+

'原作者：Sky Email:mastersky@'+#13+ '现作者：谢利洪 Email:xiliho221@' ,'关于') end; end.

本文来源：https://www.bwwdw.com/article/rhhq.html