mainform.pas

串口通信相关的源码

unit MainForm;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls,port,ExtCtrls, Mask, ComCtrls, Buttons,ShellApi;

type
  TfrmMain = class(TForm)
    Panel2: TPanel;
    memReceive: TMemo;
    Panel3: TPanel;
    edtSendData: TEdit;
    btnOpen: TButton;
    btnClose: TButton;
    btnSend: TButton;
    ckbHexSend: TCheckBox;
    ckbHexShow: TCheckBox;
    btnSetParam: TButton;
    shpComState: TShape;
    chkRepeat: TCheckBox;
    edtSleep: TEdit;
    Label1: TLabel;
    btnStopView: TButton;
    btnClear: TButton;
    chbViewFlag: TCheckBox;
    Bevel1: TBevel;
    Bevel2: TBevel;
    Bevel3: TBevel;
    Bevel4: TBevel;
    Bevel5: TBevel;
    Bevel6: TBevel;
    chbAutoClear: TCheckBox;
    chbSaveToFile: TCheckBox;
    Label2: TLabel;
    spbtnEmail: TSpeedButton;
    Bevel7: TBevel;
    Bevel8: TBevel;
    OpenDialog1: TOpenDialog;
    Label3: TLabel;
    FileEdit: TEdit;
    btnOpenFile: TBitBtn;
    Label4: TLabel;
    Timer1: TTimer;
    chbBinSave: TCheckBox;
    Port1: TPort;
    procedure btnOpenClick(Sender: TObject);
    procedure btnCloseClick(Sender: TObject);
    procedure btnSendClick(Sender: TObject);
    procedure Port1ReceiveData(Sender: TObject; InQue: Integer);
    procedure btnSetParamClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure btnClearClick(Sender: TObject);
    procedure btnStopViewClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ckbHexShowClick(Sender: TObject);
    procedure chbSaveToFileClick(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure spbtnEmailClick(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure chkRepeatClick(Sender: TObject);
    procedure btnOpenFileClick(Sender: TObject);
  private
    ReceiveIndex:integer;
    UserClear:Boolean;
    SaveFileMem:TFileStream;
    procedure SetComState;
    function GetLimitLines:integer;
    procedure AutoClear;
    procedure AppendText(s:string);
    function IsHexData(Text:PChar):Boolean;
    procedure Stop;
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation

uses Config,TypInfo, Types;

{$R *.dfm}
procedure Delay(count:Longint);
var
  OldTick:Cardinal;
begin
  OldTick:=GetTickCount;
  while abs(GetTickCount-OldTick)<count do
    Application.ProcessMessages;
end;

function HexToArray(Text: PChar; var A:array of Byte;Len: Integer): Integer; assembler;
//将以空格分开的十六进制字符串 Text 转换成 Byte 类型数组 A，Len
//指定了数组的大小，函数返回转换后数组的实际大小。
const
  Convert: array['0'..'f'] of SmallInt =
    ( 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,-1,-1,-1,-1,-1,-1,
     -1,10,11,12,13,14,15,-1,-1,-1,-1,-1,-1,-1,-1,-1,
     -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
     -1,10,11,12,13,14,15);
var
  I,Index: Integer;
begin
  I := Len;
  FillChar(A,Len,0);
  Index:=0;
  while I > 0 do
  begin
    if Text[0]=' ' then
    begin
      Inc(Text);
      Continue;
    end;
    if not (Text[0] in ['0'..'f']) or not (Text[1] in ['0'..'f']) then Break;
    A[Index] := (Convert[Text[0]] shl 4) + Convert[Text[1]];
    Inc(Index);
    Inc(Text, 2);
    Dec(I);
  end;
  Result := Len - I;
end;
function ArrayToHex(A:array of Char;Len:integer):string;assembler;
//将字节数组转换成以空格分开的十六进制字符串
const
  Convert: array[0..15] of Char = '0123456789ABCDEF';
var
  I,Index,HexLen: Integer;
begin
  HexLen:=3*(Len)-1;
  SetLength(Result,HexLen);
  Index:=1;
  for I:=0 to Len-1 do
  begin
    Result[Index]:=Convert[Ord(A[i]) shr 4];
    Result[Index+1]:=Convert[Ord(A[i]) and $F];
    if Index+2<=HexLen then
      Result[Index+2]:=' ';
    Inc(Index,3);
  end;
end;

procedure TfrmMain.btnOpenClick(Sender: TObject);
begin
  if Port1.Connected then Exit;
  if not Port1.Open then
    ShowMessage('端口不存在或者被占用！');
  SetComState;  
end;

procedure TfrmMain.btnCloseClick(Sender: TObject);
begin
  if Port1.Connected then
  begin
    Port1.Close;
    Stop;
  end;        
  SetComState;
  if SaveFileMem<>nil then
  begin
    SaveFileMem.Free;
    SaveFileMem:=nil;
  end;  
end;

procedure TfrmMain.btnSendClick(Sender: TObject);
var
  Len:integer;
  byteArray:array[0..1023] of byte;
  SaveFile:string;
begin
  if not Port1.Connected then
  begin
    if (Sender<>chkRepeat) or (edtSendData.Text<>'') then
      Application.MessageBox('端口未打开。','提示',MB_ICONINFORMATION+MB_OK);
    Exit;
  end;
  if edtSendData.Text='' then
  begin
    if (Sender<>chkRepeat) then
    begin
      Application.MessageBox('请输入发送数据。','提示',MB_ICONINFORMATION+MB_OK);
      edtSendData.SetFocus;
    end;
    Exit;
  end;
  if ckbHexSend.Checked and not IsHexData(PChar(edtSendData.Text)) then
  begin
    if (Sender<>chkRepeat) or (edtSendData.Text<>'') then
    begin
      Application.MessageBox('无效的十六进制数。','提示',MB_ICONINFORMATION+MB_OK);
      edtSendData.SetFocus;
    end;
    Exit;
  end;
  if chbSaveToFile.Checked then
  begin
    SaveFile:=Trim(FileEdit.Text);
    if not DirectoryExists(SaveFile) and
      (SaveFile<>'') then
    begin
      if SaveFileMem=nil then
        if FileExists(SaveFile) then
          SaveFileMem:=TFileStream.Create(SaveFile,fmOpenWrite)
        else
          SaveFileMem:=TFileStream.Create(SaveFile,fmCreate);
      SaveFileMem.Seek(0,soFromEnd);    
    end;
  end;
  if not chkRepeat.Checked  then
  begin
    if (edtSendData.Text<>'') then
    begin
      if ckbHexSend.Checked then
      begin
        Len:=HexToArray(PChar(edtSendData.Text),byteArray,High(byteArray)+1);
        if Len>0 then
          if Port1.Connected then
            Port1.Write(byteArray,Len);
      end
      else
      begin
        if Port1.Connected then
          Port1.WriteString(edtSendData.Text);
      end;
    end;
  end
  else if edtSendData.Text<>'' then
  begin
    btnSend.Enabled:=False;
    Timer1.Enabled:=False;
    edtSendData.Enabled:=False;
    edtSleep.Enabled:=False;
    Timer1.Interval:=StrToIntDef(edtSleep.Text,Timer1.Interval);
    edtSleep.Text:=IntToStr(Timer1.Interval);
    FileEdit.Enabled:=False;
    btnOpenFile.Enabled:=False;
    Timer1.Enabled:=True;
  end;
end;

procedure TfrmMain.Port1ReceiveData(Sender: TObject; InQue: Integer);
var
  CharArray:array[0..1023] of Char;
  str:string;
  Len,ReadInQue:integer;
  SaveFile:string;
  SaveStr:string;
begin
  if InQue>High(CharArray)+1 then
    ReadInQue:=High(CharArray)+1
  else
    ReadInQue:=InQue;
  try
    if UserClear or (btnStopView.Caption='继续显示') then
    begin
       Port1.Flush(FBInput);
       Exit;
    end;
    FillChar(CharArray,High(CharArray)+1,0);
    Len:=Port1.Read(CharArray,ReadInQue);
    if chbSaveToFile.Checked then
    begin
      SaveFile:=Trim(FileEdit.Text);
      if not DirectoryExists(SaveFile) then
      begin
        if (SaveFile<>'') and (SaveFileMem<>nil) then
        begin
          if chbBinSave.Checked then
            SaveFileMem.Write(CharArray,Len)
          else if not ckbHexShow.Checked then
            SaveFileMem.Write(CharArray,Len)
          else
          begin
            SaveStr:=ArrayToHex(CharArray,Len)+' ';
            SaveFileMem.Write(SaveStr[1],Length(SaveStr));
          end;
        end;
      end;
    end;
    if ckbHexShow.Checked then
    begin
      if chbViewFlag.Checked then
      begin
        AutoClear;
        memReceive.Lines.Add(Format('%.5dRX:  %s',[ReceiveIndex,ArrayToHex(CharArray,Len)]));
        Inc(ReceiveIndex);
      end
      else
      begin
        if Trim(memReceive.Text)='' then
          memReceive.Text:=(ArrayToHex(CharArray,Len)+' ')
        else
        begin
          AutoClear;
          AppendText(ArrayToHex(CharArray,Len)+' ');
        end;
        if CharArray[Len-1]=#13 then
          AppendText(#13#10);
      end;
    end
    else
    begin
      str:=CharArray;
      if chbViewFlag.Checked then
      begin
        AutoClear;
        memReceive.Lines.Add(Format('%.5dRX:  %s',[ReceiveIndex,str]));
        Inc(ReceiveIndex);
      end
      else
      begin
        AutoClear;
        AppendText(str);
        if Length(memReceive.Text)>0 then
          if memReceive.Text[Length(memReceive.Text)]=#13 then
            AppendText(#10);
      end;
    end;
  except
  end;
end;

procedure TfrmMain.btnSetParamClick(Sender: TObject);
var
  PType: PTypeInfo;
  bt: string;
  index:integer;
  OldCom:string;
begin
  with CfgForm do
  begin
    cbPort.Text:=Port1.Port;
    PType := System.TypeInfo(TBaudRate);
    bt:=GetEnumName(PType,Ord(Port1.BaudRate));
    Delete(bt,1,2);
    index := cbBaudRate.Items.IndexOf(bt);
    cbBaudRate.ItemIndex:=index;
    cbParity.ItemIndex:=Ord(Port1.Parity);
    cbByteSize.ItemIndex:=Ord(Port1.DataBits);
    cbStopBits.ItemIndex:=Ord(Port1.StopBits);
    chDtr.Checked:=Port1.DTR;
    chRts.Checked:=Port1.RTS;
    chHw.Checked:=Port1.CTSFlowControl;
    chSw.Checked:=Port1.OnOffOutFlowControl;
    OldCom:=Port1.Port;
    
    if ShowModal=mrOK then
    begin
      if Port1.Port<>cbPort.Text then
        if Port1.Connected then
          Port1.Close;
      Port1.Port:=cbPort.Text;
      bt:=cbBaudRate.Text;
      PType := System.TypeInfo(TBaudRate);
      index := GetEnumValue(PType, 'br' + bt);
      Port1.BaudRate:=TBaudRate(Index);
      Port1.Parity:=TParityBits(cbParity.ItemIndex);
      Port1.DataBits:=TDataBits(cbByteSize.ItemIndex);
      Port1.StopBits:=TStopBits(cbStopBits.ItemIndex);
      Port1.RTS:=chRts.Checked;
      Port1.DTR:=chDtr.Checked;
      Port1.CTSFlowControl:=chHw.Checked;
      Port1.DSRFlowControl:=chHw.Checked;
      Port1.OnOffOutFlowControl:=chSw.Checked;
      Port1.OnOffInFlowControl:=chSw.Checked;
      if (Port1.Port<>OldCom) or not Port1.Connected then btnOpenClick(nil);
    end;
  end;
end;

procedure TfrmMain.SetComState;
begin
  if Port1.Connected then
  begin
    shpComState.Pen.Color:=clRed;
    shpComState.Brush.Color:=clRed;
    shpComState.Hint:='端口处于打开状态。';
  end
  else
  begin
    shpComState.Pen.Color:=clBlue;
    shpComState.Brush.Color:=clBlue;
    shpComState.Hint:='端口处于关闭状态。';
  end;
end;

procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  chkRepeat.Checked:=False;
  Timer1.Enabled:=False;
end;

procedure TfrmMain.btnClearClick(Sender: TObject);
begin
  UserClear:=True;
  try
    memReceive.Lines.BeginUpdate;
    memReceive.Clear;
    memReceive.Lines.EndUpdate;
    ReceiveIndex:=0;
  finally
    UserClear:=False;
  end;
end;

procedure TfrmMain.btnStopViewClick(Sender: TObject);
begin
  if btnStopView.Caption='继续显示' then
    btnStopView.Caption:='停止显示'
  else
    btnStopView.Caption:='继续显示'
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  ReceiveIndex:=0;
  Constraints.MinHeight:=Height;
  Constraints.MinWidth:=Width;
  Application.HintHidePause:=60000;
  spbtnEmail.Caption:='作'#13#10'者';
end;

procedure TfrmMain.ckbHexShowClick(Sender: TObject);
begin
  //chbChineseView.Enabled:=not ckbHexShow.Checked ;
end;

function GetMemoShowingLines(Memo: TMemo): integer;
var
  OldFont: HFont;
  DC: THandle;
  Tm: TTextMetric;
  TheRect: TRect;
begin 
  DC := GetDC(Memo.Handle);
  try
    OldFont := SelectObject(DC, Memo.Font.Handle);
    try
      GetTextMetrics(DC, Tm);
      Memo.Perform(EM_GETRECT, 0, longint(@TheRect));
      Result := (TheRect.Bottom - TheRect.Top) div
        (Tm.tmHeight {+ Tm.tmExternalLeading})-1;
    finally
      SelectObject(DC, Oldfont);
    end;
  finally
    ReleaseDC(Memo.Handle, DC);
  end;
end;

function TfrmMain.GetLimitLines: integer;
{var
  Rect:TRect;
  TextHight:integer; }
begin
  {Rect:=Classes.Rect(0,0,0,0);
  SendMessage(memReceive.Handle,EM_GETRECT,0,LongInt(@Rect));
  TextHight:=Canvas.TextHeight('Wg');
  Result:=(Rect.Bottom-Rect.Top) div TextHight; }
  Result:=GetMemoShowingLines(memReceive);
end;

procedure TfrmMain.AutoClear;
begin
  if chbAutoClear.Checked then
    if memReceive.Lines.Count>=GetLimitLines then
      memReceive.Clear;
end;

procedure TfrmMain.chbSaveToFileClick(Sender: TObject);
begin
  if chbSaveToFile.Checked then
  begin
    if Trim(FileEdit.Text)='' then
    begin
      //Application.MessageBox('请输入或者选择保存的目标文件！','提示',MB_ICONINFORMATION+MB_OK);
      //FileEdit.SetFocus;
      Exit;
    end;
  end
  else if SaveFileMem<>nil then
  begin
    SaveFileMem.Free;
    SaveFileMem:=nil;
  end;
end;

procedure TfrmMain.FormDestroy(Sender: TObject);
begin
  if SaveFileMem<>nil then
    SaveFileMem.Free;
end;                                 

procedure TfrmMain.spbtnEmailClick(Sender: TObject);
begin
  ShellExecute(Handle,'Open','Mailto:[e-mail]',nil,nil,SW_SHOWNORMAL);
end;

procedure TfrmMain.AppendText(s: string);
var
  SelStart:integer;
begin
  SelStart:=Length(memReceive.Text);
  SendMessage(memReceive.Handle, EM_SETSEL, SelStart, SelStart);
  SendMessage(memReceive.Handle, EM_REPLACESEL, 0, Longint(PChar(S)));
end;

procedure TfrmMain.Timer1Timer(Sender: TObject);
var
  Len:integer;
  byteArray:array[0..1023] of byte;
begin
  if chkRepeat.Checked and (edtSendData.Text<>'') then
  begin
    if ckbHexSend.Checked then
    begin
      Len:=HexToArray(PChar(edtSendData.Text),byteArray,High(byteArray)+1);
      if Len>0 then
        if Port1.Connected then
          Port1.Write(byteArray,Len);
    end
    else
    begin
      if Port1.Connected then
        Port1.WriteString(edtSendData.Text);
    end;
    Application.ProcessMessages;
  end;
end;

procedure TfrmMain.chkRepeatClick(Sender: TObject);
begin
  if not chkRepeat.Checked and Timer1.Enabled then
  begin
    Stop;  
  end
  else if chkRepeat.Checked then
    btnSendClick(chkRepeat);  
end;

function TfrmMain.IsHexData(Text: PChar): Boolean;
var
  I: Integer;
begin
  Result:=False;
  I := StrLen(Text);
  while I > 0 do
  begin
    if not (Text[0] in ['0'..'f']) or not (Text[1] in ['0'..'f'])
      or ((Text[2]<>#0) and (Text[2]<>' ')) then Exit;;
    Inc(Text, 3);
    Dec(I,3);
  end;
  Result := True;
end;

procedure TfrmMain.Stop;
begin
  Timer1.Enabled:=False;
  btnSend.Enabled:=True;
  edtSleep.Enabled:=True;
  edtSendData.Enabled:=True;
  FileEdit.Enabled:=True;
  btnOpenFile.Enabled:=True;
  SaveFileMem.Free;
  SaveFileMem:=nil;
end;

procedure TfrmMain.btnOpenFileClick(Sender: TObject);
begin
  if not OpenDialog1.Execute then Exit;
  FileEdit.Text:=OpenDialog1.FileName;
end;

end.