main.~pas

SPCOMM通讯测试

{*****************************************************************
*串口调试

******************************************************************}

unit main;

interface

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

type
    TFrmMain = class(TForm)
    Timer1: TTimer;
    Comm1: TComm;
    Memo1: TMemo;
    BitBtn1: TBitBtn;
    Label1: TLabel;
    Label2: TLabel;
    Memo2: TMemo;
    Memo3: TMemo;
    Label8: TLabel;
    GroupBox1: TGroupBox;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    Label7: TLabel;
    ComboBox2: TComboBox;
    ComboBox3: TComboBox;
    ComboBox4: TComboBox;
    ComboBox5: TComboBox;
    ComboBox1: TComboBox;
    btnSwitch: TButton;

    procedure btnSwitchClick(Sender: TObject);
    procedure BitBtn1Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(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 FormClose(Sender: TObject; var Action: TCloseAction);
 
  private
    { Private declarations }

    FShowText:Boolean;
    FRXNum:Integer;
    FTXNum:Integer;
    procedure SendString(const str:string);
    procedure WMSysCommand(VAR Message: TWMSysCommand); message WM_SYSCOMMAND;
  public
    { Public declarations }
  end;

var
  FrmMain: TFrmMain;

implementation

const
  minWidth=320;//窗体宽
  minHeight=213;//窗体高
  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;
  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 + '\';
  end;
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.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;


  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;

  end;
  Timer1.Interval:=100;//定时时间，ms单位
  Timer1.Enabled := true;

end;

procedure TFrmMain.BitBtn1Click(Sender: TObject);
begin
    Timer1.Destroy;//必须加上
    Comm1.StopComm;//必须加上
    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 := 1;//隐藏硬件COM3,实际扩展口从COM4开始
  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;

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

end;

procedure TFrmMain.Timer1Timer(Sender: TObject);
begin
  SendString('z');//定时启动，发送字符

//SendString(HexStrToStr(Memo2.Text));//发送十六进制
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];
    Val(ts,M,Code);
    if Code=0 then
      Result:=Result+Chr(M);
    inc(t,2);
  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 TFrmMain.SendString(const str: string);

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

    end;
end;
//接收数据
procedure TFrmMain.Comm1ReceiveData(Sender: TObject; Buffer: Pointer;
  BufferLength: Word);
var str :string;
begin

  SetLength(Str,BufferLength);
  move(buffer^,pchar(@Str[1])^,bufferlength);
  if FShowText then
  begin
  Memo1.Text :=Str;
  Memo1.SelStart := Length(Memo1.Text);
  Memo1.SelLength:= 0;
  Memo1.Perform(EM_SCROLLCARET,0,0);
  end;
  FRXNum:=FRXNum+bufferlength;

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
  //TParity = ( None, Odd, Even, Mark, Space );
  Comm1.Parity := TParity(ComboBox3.ItemIndex);
end;

procedure TFrmMain.ComboBox4Change(Sender: TObject);
begin
   //TByteSize = ( _5, _6, _7, _8 );
   Comm1.ByteSize :=  TByteSize(ComboBox4.ItemIndex);
end;

procedure TFrmMain.ComboBox5Change(Sender: TObject);
begin
  //TStopBits = ( _1, _1_5, _2 );
  Comm1.StopBits := TStopBits(ComboBox5.ItemIndex);
end;

procedure TFrmMain.ComboBox2KeyPress(Sender: TObject; var Key: Char);
begin
 if not (Key in ['0'..'9',#8]) then Key := #0;
end;


procedure TFrmMain.WMSysCommand(var Message: TWMSysCommand);
begin
  Inherited;
  if Message.CmdType = idAbout then
    Application.MessageBox('==  串口调试助手Delphi SPCOMM版 1.1  == '+#13#13+
                           '改用SPCOMM控件，程序更小巧、更好用'+#13+
                           '同时改进了部分算法，添加原未完成的功能'+#13#13
                           ,'关于')
end;


procedure TFrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Comm1.StopComm;//必须加上
  Action := caFree;//释放所有资源
  //caMinimize://Form被最小化而不是被关闭
  //caNone://禁止Form被关闭
  //caHide;//Form不被关闭，但是被隐藏
end;


end.