form1.frm

用于GPS数据采集

      End
      Begin VB.CommandButton cmdClose 
         Caption         =   "关闭串口"
         Height          =   285
         Left            =   5490
         TabIndex        =   4
         Top             =   480
         Width           =   885
      End
      Begin VB.CommandButton cmdOpen 
         Caption         =   "打开串口"
         Height          =   285
         Left            =   4470
         TabIndex        =   3
         Top             =   480
         Width           =   885
      End
      Begin VB.ComboBox Combo1 
         Height          =   315
         Left            =   750
         Style           =   2  'Dropdown List
         TabIndex        =   2
         Top             =   480
         Width           =   1425
      End
      Begin VB.ComboBox Combo2 
         Height          =   315
         Left            =   2940
         Style           =   2  'Dropdown List
         TabIndex        =   1
         Top             =   480
         Width           =   1425
      End
      Begin MSCommLib.MSComm MSComm1 
         Left            =   6150
         Top             =   780
         _ExtentX        =   1005
         _ExtentY        =   1005
         _Version        =   393216
         DTREnable       =   -1  'True
      End
      Begin VB.TextBox txtStation 
         BeginProperty Font 
            Name            =   "Fixedsys"
            Size            =   12
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   1395
         Left            =   -74970
         MultiLine       =   -1  'True
         ScrollBars      =   3  'Both
         TabIndex        =   25
         Top             =   780
         Width           =   8595
      End
      Begin VB.Label Label9 
         AutoSize        =   -1  'True
         Caption         =   "波特率："
         Height          =   195
         Left            =   -73290
         TabIndex        =   24
         Top             =   510
         Width           =   720
      End
      Begin VB.Label Label8 
         AutoSize        =   -1  'True
         Caption         =   "串口："
         Height          =   195
         Left            =   -74910
         TabIndex        =   23
         Top             =   510
         Width           =   540
      End
      Begin VB.Label Label3 
         AutoSize        =   -1  'True
         Caption         =   "东经："
         Height          =   195
         Left            =   240
         TabIndex        =   18
         Top             =   990
         Width           =   540
      End
      Begin VB.Label Label4 
         AutoSize        =   -1  'True
         Caption         =   "北纬："
         Height          =   195
         Left            =   2520
         TabIndex        =   17
         Top             =   990
         Width           =   540
      End
      Begin VB.Label Label5 
         AutoSize        =   -1  'True
         Caption         =   "GPS状态："
         Height          =   195
         Index           =   0
         Left            =   1890
         TabIndex        =   16
         Top             =   1440
         Width           =   870
      End
      Begin VB.Label Label6 
         AutoSize        =   -1  'True
         Caption         =   "速度："
         Height          =   195
         Left            =   270
         TabIndex        =   15
         Top             =   1440
         Width           =   540
      End
      Begin VB.Label Label7 
         AutoSize        =   -1  'True
         Caption         =   "采集时间："
         Height          =   195
         Left            =   3510
         TabIndex        =   14
         Top             =   1440
         Width           =   900
      End
      Begin VB.Label Label2 
         AutoSize        =   -1  'True
         Caption         =   "波特率："
         Height          =   195
         Left            =   2250
         TabIndex        =   13
         Top             =   540
         Width           =   720
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         Caption         =   "串口："
         Height          =   195
         Left            =   270
         TabIndex        =   12
         Top             =   570
         Width           =   540
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'Private Sub Command1_Click()
'Dim Temp As Long
'Dim Stemp As String
'Dim S0 As String * 8
'S0 = "00000000"
'Temp = Text1.Text * 10000
'
'Stemp = Mid(S0, 1, 8 - Len(Hex(Temp))) & Hex(Temp)
'For i = 0 To Len(Hex(Temp)) / 2
'Text2.Text = Text2.Text & "0x" & Mid(Stemp, i * 2 + 1, 1) & Mid(Stemp, i * 2 + 2, 1) & ","
'Next
'
'Text2.Text = Text2.Text & "//" & Text1.Text & Chr(13) & Chr(10)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Temp = Text3.Text * 10000
'
'Stemp = Mid(S0, 1, 8 - Len(Hex(Temp))) & Hex(Temp)
'For i = 0 To Len(Hex(Temp)) / 2
'Text4.Text = Text4.Text & "0x" & Mid(Stemp, i * 2 + 1, 1) & Mid(Stemp, i * 2 + 2, 1) & ","
'Next
'
'Text4.Text = Text4.Text & "//" & Text3.Text & Chr(13) & Chr(10)
'End Sub
Dim ab() As Byte
Dim s() As String
Dim flag As String
 '字节数据类型数组，用来存储接收到的一组字节数据
Dim av As Variant, Temp1 As Variant '用来从接收缓冲区读取数据
Dim LineId, lineId2 As Integer
Dim AscData As String, AscData1 As String

Private Sub cmdClear_Click()
List1.Clear
List2.Clear
LineId = 0
lineId2 = 0
End Sub

Private Sub cmdClose_Click()
If MSComm1.PortOpen = True Then
MSComm1.InBufferCount = 0
MSComm1.RThreshold = 0
MSComm1.PortOpen = False
End If
cmdOpen.Enabled = True
cmdClose.Enabled = False

End Sub

Private Sub cmdClose1_Click()
If MSComm2.PortOpen = True Then
MSComm2.InBufferCount = 0
MSComm2.RThreshold = 0
MSComm2.PortOpen = False
End If
cmdOpen1.Enabled = True
cmdClose1.Enabled = False

End Sub

Private Sub cmdDevice_Click()
Dim v(2) As Byte
v(0) = &HFE
v(1) = &H3
v(2) = &HFE
On Error GoTo err:
If MSComm2.PortOpen = False Then
  MSComm2.PortOpen = True
 End If
  MSComm2.Output = CVar(v)
Exit Sub
err:

End Sub

Private Sub cmdIP_Click()
Dim i As Integer
For i = 0 To 3
If txtIP(i).Text = "" Or Int(Val(Trim(txtIP(i).Text))) > 255 Then
 txtIP(i).SetFocus
MsgBox "IP地址输入有误！", vbOKOnly + vbExclamation, "写入站点"
 Exit Sub
End If
Next


Dim v(6) As Byte
v(0) = &HFE
v(1) = &H0
v(2) = Int(Val(Trim(txtIP(0).Text)))
v(3) = Int(Val(Trim(txtIP(1).Text)))
v(4) = Int(Val(Trim(txtIP(2).Text)))
v(5) = Int(Val(Trim(txtIP(3).Text)))
v(6) = &HFE
On Error GoTo err:
If MSComm2.PortOpen = False Then
  MSComm2.PortOpen = True
 End If
  MSComm2.Output = CVar(v)
  Exit Sub
err:
MsgBox "写入IP地址失败！", vbOKOnly + vbExclamation, "写入站点"

End Sub

Private Sub cmdMakestation_Click()
If Len(txtLng) > 0 And Len(txtLat) > 0 Then
    strLng = txtLng.Text
    strLat = txtLat.Text
    Dialog.Show , Me
End If
End Sub

Private Sub cmdNo_Click()
If Len(Trim(txtNo.Text)) < 10 Then
MsgBox "设备编号应该为10位！", vbOKOnly + vbExclamation, "写入站点"
txtNo.SetFocus
Exit Sub
End If
Dim a1, b1, c As Integer

 Dim v(8) As Byte
    v(0) = &HFE
    v(1) = &H1
    a1 = Asc(Mid(txtNo.Text, 1, 1))
    If a1 >= 48 And a1 <= 57 Then
    a1 = a1 - 48
    ElseIf a1 >= 65 And a1 <= 70 Then
    a1 = a1 - 55
    End If
    b1 = Asc(Mid(txtNo.Text, 2, 1))
    If b1 >= 48 And b1 <= 57 Then
    b1 = b1 - 48
    ElseIf b1 >= 65 And b1 <= 70 Then
    b1 = b1 - 55
    End If

    v(2) = a1 * 16 + b1
    
    a1 = Asc(Mid(txtNo.Text, 3, 1))
    If a1 >= 48 And a1 <= 57 Then
    a1 = a1 - 48
    ElseIf a1 >= 65 And a1 <= 70 Then
    a1 = a1 - 55
    End If
    b1 = Asc(Mid(txtNo.Text, 4, 1))
    If b1 >= 48 And b1 <= 57 Then
    b1 = b1 - 48
    ElseIf b1 >= 65 And b1 <= 70 Then
    b1 = b1 - 55
    End If

    v(3) = a1 * 16 + b1
    
    a1 = Asc(Mid(txtNo.Text, 5, 1))
    If a1 >= 48 And a1 <= 57 Then
    a1 = a1 - 48
    ElseIf a1 >= 65 And a1 <= 70 Then
    a1 = a1 - 55
    End If
    b1 = Asc(Mid(txtNo.Text, 6, 1))
    If b1 >= 48 And b1 <= 57 Then
    b1 = b1 - 48
    ElseIf b1 >= 65 And b1 <= 70 Then
    b1 = b1 - 55
    End If

    v(4) = a1 * 16 + b1
    
    a1 = Asc(Mid(txtNo.Text, 7, 1))
    If a1 >= 48 And a1 <= 57 Then
    a1 = a1 - 48
    ElseIf a1 >= 65 And a1 <= 70 Then
    a1 = a1 - 55
    End If
    b1 = Asc(Mid(txtNo.Text, 8, 1))
    If b1 >= 48 And b1 <= 57 Then
    b1 = b1 - 48
    ElseIf b1 >= 65 And b1 <= 70 Then
    b1 = b1 - 55
    End If

    v(5) = a1 * 16 + b1
    a1 = Asc(Mid(txtNo.Text, 9, 1))
    If a1 >= 48 And a1 <= 57 Then
    a1 = a1 - 48
    ElseIf a1 >= 65 And a1 <= 70 Then
    a1 = a1 - 55
    End If
    b1 = Asc(Mid(txtNo.Text, 10, 1))
    If b1 >= 48 And b1 <= 57 Then
    b1 = b1 - 48
    ElseIf b1 >= 65 And b1 <= 70 Then
    b1 = b1 - 55
    End If

    v(6) = a1 * 16 + b1
    c = c + v(2) + v(3) + v(4) + v(5) + v(6) + 1
    v(7) = c Mod 256
    v(8) = &HFE
   
 On Error GoTo err:
   If MSComm2.PortOpen = False Then
     MSComm2.PortOpen = True
   End If
  MSComm2.Output = CVar(v)
  If chAuto.value = Checked Then
     txtNo.Text = MakeProductID
  End If
  Timer1.Interval = 100
  Timer1.Enabled = True
  cmdNo.Enabled = False
  Exit Sub
err:

  MsgBox "写入设备号失败！", vbOKOnly + vbExclamation, "写入站点"
End Sub
Function MakeProductID() As String
Dim productID As String
productID = Trim(txtNo.Text)
a = Asc(Mid(productID, 10, 1))
b = Asc(Mid(productID, 9, 1))
c = Asc(Mid(productID, 8, 1))
d = Asc(Mid(productID, 7, 1))
e = Asc(Mid(productID, 6, 1))
f = Asc(Mid(productID, 5, 1))
'个位
If Asc(Mid(productID, 10, 1)) >= 48 And Asc(Mid(productID, 10, 1)) <= 56 Then
a = Asc(Mid(productID, 10, 1)) + 1
ElseIf Asc(Mid(productID, 10, 1)) = 57 Then
a = 65
ElseIf Asc(Mid(productID, 10, 1)) >= 65 And Asc(Mid(productID, 10, 1)) < 70 Then
a = Asc(Mid(productID, 10, 1)) + 1
ElseIf Asc(Mid(productID, 10, 1)) = 70 Then
a = 48
End If
'十位
If a = 48 Then
If Asc(Mid(productID, 9, 1)) >= 48 And Asc(Mid(productID, 9, 1)) <= 56 Then
b = Asc(Mid(productID, 9, 1)) + 1
ElseIf Asc(Mid(productID, 9, 1)) = 57 Then
b = 65
ElseIf Asc(Mid(productID, 9, 1)) >= 65 And Asc(Mid(productID, 9, 1)) < 70 Then
b = Asc(Mid(productID, 9, 1)) + 1
ElseIf Asc(Mid(productID, 9, 1)) = 70 Then
b = 48
End If
End If
'百位
If a = 48 And b = 48 Then
If Asc(Mid(productID, 8, 1)) >= 48 And Asc(Mid(productID, 8, 1)) <= 56 Then
c = Asc(Mid(productID, 8, 1)) + 1
ElseIf Asc(Mid(productID, 8, 1)) = 57 Then
c = 65
ElseIf Asc(Mid(productID, 8, 1)) >= 65 And Asc(Mid(productID, 8, 1)) < 70 Then
c = Asc(Mid(productID, 8, 1)) + 1
ElseIf Asc(Mid(productID, 8, 1)) = 70 Then
c = 48
End If
End If
'千位
If a = 48 And b = 48 And c = 48 Then
If Asc(Mid(productID, 7, 1)) >= 48 And Asc(Mid(productID, 7, 1)) <= 56 Then
d = Asc(Mid(productID, 7, 1)) + 1
ElseIf Asc(Mid(productID, 7, 1)) = 57 Then
d = 65
ElseIf Asc(Mid(productID, 7, 1)) >= 65 And Asc(Mid(productID, 7, 1)) < 70 Then
d = Asc(Mid(productID, 7, 1)) + 1
ElseIf Asc(Mid(productID, 7, 1)) = 70 Then
d = 48
End If
End If
'万位
If a = 48 And b = 48 And c = 48 And d = 48 Then
If Asc(Mid(productID, 6, 1)) >= 48 And Asc(Mid(productID, 6, 1)) <= 56 Then
e = Asc(Mid(productID, 6, 1)) + 1
ElseIf Asc(Mid(productID, 6, 1)) = 57 Then
e = 65
ElseIf Asc(Mid(productID, 6, 1)) >= 65 And Asc(Mid(productID, 6, 1)) < 70 Then
e = Asc(Mid(productID, 6, 1)) + 1
ElseIf Asc(Mid(productID, 6, 1)) = 70 Then
e = 48
End If
End If
'十万位
If a = 48 And b = 48 And c = 48 And d = 48 And e = 48 Then
If Asc(Mid(productID, 5, 1)) >= 48 And Asc(Mid(productID, 5, 1)) <= 56 Then
f = Asc(Mid(productID, 5, 1)) + 1
ElseIf Asc(Mid(productID, 5, 1)) = 57 Then
f = 65
ElseIf Asc(Mid(productID, 5, 1)) >= 65 And Asc(Mid(productID, 5, 1)) < 70 Then
e = Asc(Mid(productID, 5, 1)) + 1
ElseIf Asc(Mid(productID, 5, 1)) = 70 Then
e = 48
End If
End If

MakeProductID = Mid(productID, 1, 4) + Chr(f) + Chr(e) + Chr(d) + Chr(c) + Chr(b) + Chr(a)
End Function
Private Sub cmdOpen_Click()
If MSComm1.PortOpen = True Then
 MSComm1.PortOpen = False
End If

MSComm1.CommPort = Combo1.ListIndex + 1
MSComm1.Settings = Trim(Combo2.Text) & ",N,8,1"

  With MSComm1
     
     .InputMode = comInputModeBinary
     '设置接收数据模式为二进制形式
     .InputLen = 1
     '设置Input 一次从接收缓冲读取字节数为1
     .InBufferCount = 0  '清除接收缓冲区
    .RThreshold = 1
    '设置接收一个字节产生OnComm事件
    On Error GoTo err:
     If .PortOpen = False Then
    '判断通信口是否打开
        .PortOpen = True       '打开通信口
     End If
  End With
cmdOpen.Enabled = False
cmdClose.Enabled = True
Exit Sub
err:
MsgBox err.Description
End Sub

Private Sub cmdOpen1_Click()
If MSComm2.PortOpen = True Then
 MSComm2.PortOpen = False