dfh.frm

vb通讯程序

    MSComm1.PortOpen = True
    MSComm1.InputMode = comInputModeBinary
    MSComm1.OutBufferSize = 512
    MSComm1.InBufferSize = 512
    startime
    Unload frmSplash
    Call congji(False)
    Call fangshi(False)
    Combo1.Enabled = False
    On Error GoTo 0
End Sub

Private Sub Form_Resize()
 ' Resize the Term (display) control
 Text1.Move 0, Toolbar1.Height, Form1.ScaleWidth, Form1.ScaleHeight - statusbar.Height - Toolbar1.Height
   ' Position the status indicator light
End Sub

Private Sub help_Click()
openlog.CancelError = True
On Error GoTo errhandler
openlog.HelpCommand = 9
openlog.HelpFile = App.Path & "\A.hlp"
openlog.ShowHelp
errhandler:
  Exit Sub
End Sub

'communacation with congji.
Private Sub mnu1_Click(index As Integer)
On Error Resume Next
Dim a1(1) As Byte
Dim d As String
d = str(index)
randf = False
Select Case speed
Case 300
MSComm1.Settings = "300,M,8,1"
Case 600
MSComm1.Settings = "600,M,8,1"
Case 1200
MSComm1.Settings = "1200,M,8,1"
Case 2400
MSComm1.Settings = "2400,M,8,1"
Case 4800
MSComm1.Settings = "4800,M,8,1"
Case 9600
MSComm1.Settings = "9600,M,8,1"
Case 14400
MSComm1.Settings = "14400,M,8,1"
Case 19200
MSComm1.Settings = "19200,M,8,1"
Case 28800
MSComm1.Settings = "28800,M,8,1"
End Select
statusbar.Panels(1).Text = "status: " & "从机" & index
statusbar.Panels(2).Text = "settings:  " & MSComm1.Settings
Combo1.Text = Combo1.List(index - 1)
randf = True
a1(1) = CByte(index)
MSComm1.Output = a1
MSComm1.InBufferCount = 0
Timer3.Enabled = True
Do
 Do While cjxyf = False
    MsgBox "下位机" & d & "无响应, 你设置的波特率可能与你的下位机不同,请重新设置!", vbInformation
    Timer3.Enabled = False
    cjxyf = True
    asd = False
    MSComm1.InBufferCount = 0
     Exit Sub
 Loop
DoEvents
Loop Until MSComm1.InBufferCount > 0
Timer3.Enabled = False
MSComm1.InputLen = 1
a3 = MSComm1.Input
a2 = a3
If a2(0) = a1(1) Then
MsgBox "从机" & d & "响应，继续下面的操作", 48, "RIGHT"
Else
MsgBox "重新按从机" & d, 48, "error!"
asd = False
Exit Sub
End If
MSComm1.InBufferCount = 0
Call fangshi(True)
On Error GoTo 0
End Sub

Private Sub mnubao_Click()
'show the property form.
Form2.Show vbModal
End Sub
Sub loadsettings()
On Error Resume Next
Select Case speed
Case 300
MSComm1.Settings = "300,s,8,1"
Case 600
MSComm1.Settings = "600,s,8,1"
Case 1200
MSComm1.Settings = "1200,s,8,1"
Case 2400
MSComm1.Settings = "2400,s,8,1"
Case 4800
MSComm1.Settings = "4800,s,8,1"
Case 9600
MSComm1.Settings = "9600,s,8,1"
Case 14400
MSComm1.Settings = "14400,s,8,1"
Case 19200
MSComm1.Settings = "19200,s,8,1"
Case 28800
MSComm1.Settings = "28800,s,8,1"
End Select
mnumathod.Enabled = True
On Error GoTo 0
End Sub

Private Sub mnuclear_Click()
Text1.Text = " "
End Sub

Private Sub mnuexit_Click()
MSComm1.PortOpen = False
stoptime
Unload Me
End Sub

Private Sub mnuf_Click()
'asd?????????
EditCopyProc
End Sub

Private Sub mnuj_Click()
  EditCutProc
End Sub

Private Sub mnun_Click()
'fghjk??????
EditPasteProc
End Sub

Private Sub mnuopen_Click()
Dim nextline As String
Dim hopen
On Error Resume Next
Text1.Text = ""
openlog.DialogTitle = "open text file"
openlog.Filter = "text files(*.txt)|*.txt|all files(*.*)|*.*"
Do
  openlog.CancelError = True
  openlog.FileName = " "
  openlog.ShowOpen
  If Err = cdlCancel Then
  Exit Sub
  End If
 temp = openlog.FileName
''if the  file doesn't exist,go back.
  ret = Len(Dir(temp))
  If Err Then
  MsgBox Error$, 48
  Exit Sub
  End If
  If ret Then
  Exit Do
  Else
  MsgBox temp + "not found!", 48
  End If
Loop
Form1.MousePointer = vbHourglass
hopen = FreeFile
Open temp For Input As hopen
Do Until EOF(hopen)
  Line Input #hopen, nextline
  Text1.Text = Text1.Text + nextline + Chr(13) + Chr(10)
Loop
Close hopen
Form1.MousePointer = vbDefault
On Error GoTo 0
End Sub
'receive data.
Private Sub mnureceive_Click()
On Error Resume Next
Dim sun1() As Byte
Dim s2 As Integer
Dim s3 As Integer
Dim s6 As Integer
Form1.Caption = "上载数据"
Call loadsettings
statusbar.Panels(2).Text = "settings:  " & MSComm1.Settings
temp = InputBox("请输入上载数据的起始地址:地址必须以“&H”开头，地址为16位！", "ADRESS")
adr = Val(temp)
    If Len(temp) = 0 Or Len(temp) <> 6 Then
    MsgBox "无起始地址或地址格式不对！请再次按＇上载数据＇菜单", 48, "错误"
    Form1.Caption = "PC与单片机串行通讯"
    statusbar.Panels(2).Text = "settings:  "
    Exit Sub
    End If
 sun = InputBox("请输入要上载数据的个数", "DATA")
 If sun = 0 Then
   MsgBox "无上载数据的个数！请再次按‘上载数据’菜单", 48, "错误"
   Form1.Caption = "PC与单片机串行通讯"
    statusbar.Panels(2).Text = "settings:  "
   Exit Sub
 End If
 a1(5) = &HFF
 a1(1) = CByte(Val("&H" & Mid(temp, 3, 2)))
 a1(2) = CByte(Val("&H" & Mid(temp, 5, 2)))
  If Val("&H" & Mid(temp, 5, 2)) + sun Mod 256 > 256 Then
      a1(4) = CByte((Val("&H" & Mid(temp, 5, 2)) + sun Mod 256 - 256))
      a1(3) = CByte((Val("&H" & Mid(temp, 3, 2)) + sun \ 256 + 1))
  Else
   a1(4) = CByte((Val("&H" & Mid(temp, 5, 2)) + sun Mod 256))
   a1(3) = CByte((Val("&H" & Mid(temp, 3, 2)) + sun \ 256))
  End If
 b1(1) = CByte(sun \ 256)
 b1(2) = CByte(sun Mod 256)
 s6 = b1(2) + 1
Form1.Caption = "正在接收数据..."
adres2:
j = 0
  For i = 1 To 5
    Do While j >= 256
    j = j - 256
    Loop
    j = j + a1(i)
  Next i
  If j >= 256 Then
  j = j - 256
  End If
  a1(6) = CByte(j)
  ReDim a2(1) As Byte
  For i = 1 To 5
    a2(1) = a1(i)
    MSComm1.Output = a2
  Next i
 Do
  DoEvents
Loop Until Form1.MSComm1.InBufferCount > 0
  MSComm1.InputLen = 1
  a3 = MSComm1.Input
  a2 = a3
  MSComm1.Output = a2
  If a2(0) = a1(6) Then
   GoTo adres1
  Else
   GoTo adres2
  End If
  
adres1:
ReDim sun1(sun) As Byte
  s3 = sun \ 256
  s2 = 0
If b1(1) >= 1 Then
adres4:
  j = 0
  MSComm1.InBufferCount = 0
   Do
    DoEvents
   Loop Until MSComm1.InBufferCount >= 257
   MSComm1.InputLen = 257
   a3 = MSComm1.Input
   arry = a3
   For i = 1 To 256
    Do While j >= 256
     j = j - 256
    Loop
    j = j + arry(i - 1)
   Next i
   If j >= 256 Then
    j = j - 256
   End If
   f1(1) = arry(256)
   MSComm1.Output = f1
   ReDim a2(1) As Byte
   a2(1) = CByte(j)
 If a2(1) = arry(256) Then
      s3 = s3 - 1
     If s3 = 0 Then
      For i = 1 To 256
        sun1(s2 * 256 + i) = arry(i - 1)
      Next i
       If b1(2) = 0 Then
         GoTo adres5
       End If
       GoTo adres3
     Else
      For i = 1 To 256
       sun1(s2 * 256 + i) = arry(i - 1)
      Next i
      s2 = s2 + 1
      GoTo adres4
     End If
 ElseIf a2(1) <> arry(256) Then
     GoTo adres4
 End If
 
adres3:
   j = 0
   Do
   DoEvents
   Loop Until MSComm1.InBufferCount >= s6
   MSComm1.InputLen = s6
   a3 = MSComm1.Input
   arry = a3
   For i = 1 To b1(2)
    Do While j >= 256
     j = j - 256
    Loop
    j = j + arry(i - 1)
   Next i
   If j >= 256 Then
    j = j - 256
   End If
   f1(1) = arry(b1(2))
   MSComm1.Output = f1
   ReDim a2(1) As Byte
   a2(1) = CByte(j)
   If a2(1) = arry(b1(2)) Then
     s2 = s2 + 1
     For i = 1 To b1(2)
       sun1(s2 * 256 + i) = arry(i - 1)
     Next i
     GoTo adres5
   ElseIf a2(1) <> arry(b1(2)) Then
     GoTo adres3
   End If
Else
adres6:
  j = 0
  Do
   DoEvents
  Loop Until MSComm1.InBufferCount >= s6
  MSComm1.InputLen = s6
  a3 = MSComm1.Input
  arry = a3
  For i = 1 To b1(2)
    Do While j >= 256
     j = j - 256
    Loop
    j = j + arry(i - 1)
   Next i
   If j >= 256 Then
    j = j - 256
   End If
   f1(1) = arry(b1(2))
   MSComm1.Output = f1
   ReDim a2(1) As Byte
   a2(1) = CByte(j)
   If a2(1) = arry(b1(2)) Then
     For i = 1 To b1(2)
      sun1(i) = arry(i - 1)
     Next i
     GoTo adres5
   ElseIf a2(1) <> arry(b1(2)) Then
     GoTo adres6
   End If
End If
adres5:
MsgBox "接收完毕且正确", vbOKOnly + vbInformation, "congratuation!"
fangshi (False)
Form1.Caption = "PC与单片机串行通讯 "
 ReDim MReal(sun) As Double
 For i = 1 To sun
   MReal(i) = sun1(i)
 Next i
  Set MatLab = CreateObject("Matlab.Application")
 Call MatLab.PutFullMatrix("BMat", "base", MReal, MImag)
 MatLab.Execute ("plot(BMat)")
 'atLab.Execute ("h=1:.1:length(BMat)")
 'atLab.Execute ("s=1:length(BMat)")

'MatLab.Execute ("a=interp1([1:length(BMat)],BMat,h,'spline')")
'MatLab.Execute ("plot(s,BMat,'*',h,a)")




On Error GoTo 0
End Sub



Private Sub mnusave_Click()
On Error Resume Next
Dim str As String
savelog.DialogTitle = "save file as"
savelog.Filter = "text files(*.txt)|*.txt|all files (*.*)|*.*"
 savelog.Action = 2
Open savelog.FileName For Output As #2
str = Text1.Text
Print #2, str
Close #2
On Error GoTo 0
End Sub

Private Sub mnusave1_Click()
On Error Resume Next
Dim arry() As String
Dim arry1() As Byte
Dim a1 As String
Dim i As Integer
Dim j As Integer
Dim a2 As String
Dim a3 As String
Dim s1 As Integer
Dim s2 As Integer
Dim s3 As Integer
Form1.Caption = "正在保存数据"
savelog.DialogTitle = "save file as"
savelog.Filter = "text files(*.bin)|*.bin|all files (*.*)|*.*"
 savelog.Action = 2
 If Len(savelog.FileName) = 0 Then
  Form1.Caption = "PC与单片机串行通讯 "
  Exit Sub
 End If
Form1.MousePointer = vbHourglass
Open savelog.FileName For Binary As #2
a1 = Text1.Text
If Len(a1) = 0 Then
  Exit Sub
End If
ReDim arry(1)
j = Len(a1)
For i = 1 To j
 If Mid(a1, i, 1) <> " " Then
 ReDim Preserve arry(UBound(arry) + 1)
   a2 = Mid(a1, i, 2)
   arry(UBound(arry)) = a2
   i = i + 2
 End If
Next i
j = UBound(arry) - 1
ReDim arry1(1 To j)
For i = 1 To j
 a1 = arry(i + 1)
 a2 = Mid(a1, 1, 1)
 a3 = Mid(a1, 2, 1)
 Select Case a2
 Case "0"
   s1 = 0
 Case "1"
   s1 = 16
 Case "2"
   s1 = 32
 Case "3"
   s1 = 48
 Case "4"
   s1 = 64
 Case "5"
   s1 = 80
 Case "6"
   s1 = 96
 Case "7"
   s1 = 112
 Case "8"
   s1 = 128
 Case "9"
   s1 = 144
 Case "A"
   s1 = 160
 Case "B"
   s1 = 176
 Case "C"
   s1 = 192
 Case "D"
   s1 = 208
 Case "E"
   s1 = 224
 Case "F"
   s1 = 240
End Select
Select Case a3
 Case "0"
   s2 = 0
 Case "1"
   s2 = 1
 Case "2"
   s2 = 2
 Case "3"
   s2 = 3
 Case "4"
   s2 = 4
 Case "5"
   s2 = 5
 Case "6"
   s2 = 6
 Case "7"
   s2 = 7
 Case "8"
   s2 = 8
 Case "9"
   s2 = 9
 Case "A"
   s2 = 10
 Case "B"
   s2 = 11
 Case "C"
   s2 = 12
 Case "D"
   s2 = 13
 Case "E"
   s2 = 14
 Case "F"
   s2 = 15
End Select
s3 = s1 + s2
arry1(i) = CByte(s3)