frmthing.frm

用户MODBUS规约通信编程,起参考作用.

     If Chr(KeyAscii) = Chr(13) Then
      Horizontal Me, RGB(131, 166, 244), RGB(33, 120, 224)
        tmpnh = Trim(Text1.Text)
        '======================================================
        '检查人员
    i = 0
    txtsql = "select * from 人员设置表"

    Set rs4 = conn4.Execute(txtsql)
    
    If rs4.EOF = True And rs4.BOF = True Then
    Else
        rs4.MoveFirst
        While Not rs4.EOF = True
                     If Trim(rs4.Fields("钮号")) = UCase(tmpnh) Then
                        frmmsg.msg.MsgChar = "输入与人员中的设置中有重复，重复号为" & tmpnh & ""
                        frmmsg.Show
                        
                         Exit Sub
                     End If
                     i = i + 1
                     rs4.MoveNext
         Wend
    End If
  
    '检查地点
    i = 0
    txtsql = "select * from 地点设置表"
    Set rs4 = conn4.Execute(txtsql)
    If rs4.EOF = True And rs4.BOF = True Then
    Else
        rs4.MoveFirst
        While Not rs4.EOF = True
                     If Trim(rs4.Fields("钮号")) = UCase(tmpnh) Then
                           frmmsg.msg.MsgChar = "输入与地点设置中的设置中有重复，重复号为" & tmpnh & ""
                        frmmsg.Show
                        
                         Exit Sub
                     End If
                     i = i + 1
                     rs4.MoveNext
         Wend
    End If
   
   '======================================================
   tmpnh = UCase(tmpnh)
   txtsql = "select * from 事件设置表 where 事件号='" & tmpnh & "'"
   Set rs4 = conn4.Execute(txtsql)
   If rs4.EOF <> True And rs4.BOF <> True Then
   MsgBox "与以前的有重复"
   Exit Sub
   End If
   DataGrid1.Columns(0).Text = UCase(tmpnh)
                     
End If
DataGrid1.AllowAddNew = False
Set conn4 = Nothing

   
        
End Sub

Public Sub GetDisplayText()

    Dim n As Integer
    Dim intValue As Integer
    Dim intHighHex As Integer
    Dim intLowHex As Integer
    Dim strSingleChr As String * 1
    
    Dim intAddress As Integer
    Dim intAddressArray(8) As Integer
    Dim intHighAddress As Integer
    
    Dim strhex, strAscii  As String
    Dim result(16) As String
    Dim i As Integer
    Dim time1 As String
    i = 0
    
    
     '设置初值
    strhex = ""
    
    
    
    
    
    
    For n = 1 To 8
 
        intValue = receive(n - 1)
        
       
        
        intHighHex = intValue \ 16
        intLowHex = intValue - intHighHex * 16
        
        If intHighHex < 10 Then
            intHighHex = intHighHex + 48
        Else
            intHighHex = intHighHex + 55
        End If
        If intLowHex < 10 Then
            intLowHex = intLowHex + 48
        Else
            intLowHex = intLowHex + 55
        End If
        
        strhex = strhex + Chr$(intHighHex) + Chr$(intLowHex)
        If i < 16 Then
       result(i) = Chr$(intHighHex)
       
       i = i + 1
       result(i) = Chr$(intLowHex)
       i = i + 1
       End If
              
    Next n
   
    
    
    
   
    bang_num = result(0) & result(1) & result(2) & result(3)
    i = ((Asc(result(4)) - 48) * 16 ^ 3 + (Asc(result(5)) - 48) * 16 ^ 2 + (Asc(result(6)) - 48) * 16 ^ 1 + (Asc(result(7)) - 48) * 1) / 8
    Count_Total = i
    If i = 0 Then
    k_flag = True
    
    frmmsg.msg.MsgChar = " 数据已录入"
    frmmsg.Show
    Exit Sub
    End If
    
    'MsgBox bang_num
    'MsgBox i
    ReDim Time_Date(i) As String
    ReDim Niu(i) As String
    
    time1 = result(14) & result(15) & "月" & result(12) & result(13) & "号" & result(10) & result(11) & ":" & result(8) & result(9)
    mon_time = time1
    
   
     
    
    
 
    
    
    
End Sub

'**********************************
'字符表示的十六进制数转化为相应的整数
'错误则返回  -1
'**********************************

Function ConvertHexChr(str As String) As Integer
    
    Dim test As Integer
    
    test = Asc(str)
    If test >= Asc("0") And test <= Asc("9") Then
        test = test - Asc("0")
    ElseIf test >= Asc("a") And test <= Asc("f") Then
        test = test - Asc("a") + 10
    ElseIf test >= Asc("A") And test <= Asc("F") Then
        test = test - Asc("A") + 10
    Else
        test = -1                                       '出错信息
    End If
    ConvertHexChr = test
    
End Function

'**********************************
'字符串表示的十六进制数据转化为相应的字节串
'返回转化后的字节数
'**********************************

Function strHexToByteArray(strText As String, bytByte() As Byte) As Integer
    
    Dim HexData As Integer          '十六进制(二进制)数据字节对应值
    Dim hstr As String * 1          '高位字符
    Dim lstr As String * 1          '低位字符
    Dim HighHexData As Integer      '高位数值
    Dim LowHexData As Integer       '低位数值
    Dim HexDataLen As Integer       '字节数
    Dim StringLen As Integer        '字符串长度
    Dim Account As Integer          '计数
     Dim n As Integer
    'strTestn = ""                   '设初值
    HexDataLen = 0
    strHexToByteArray = 0
    
    StringLen = Len(strText)
    Account = StringLen \ 2
    ReDim bytByte(Account)
    
    For n = 1 To StringLen
    
        Do                                              '清除空格
            hstr = Mid(strText, n, 1)
            n = n + 1
            If (n - 1) > StringLen Then
                HexDataLen = HexDataLen - 1
                
                Exit For
            End If
        Loop While hstr = " "
        
        Do
            lstr = Mid(strText, n, 1)
            n = n + 1
            If (n - 1) > StringLen Then
                HexDataLen = HexDataLen - 1
                
                Exit For
            End If
        Loop While lstr = " "
        n = n - 1
        If n > StringLen Then
            HexDataLen = HexDataLen - 1
            Exit For
        End If
        
        HighHexData = ConvertHexChr(hstr)
        LowHexData = ConvertHexChr(lstr)
        
        If HighHexData = -1 Or LowHexData = -1 Then     '遇到非法字符中断转化
            HexDataLen = HexDataLen - 1
            
            Exit For
        Else
            
            HexData = HighHexData * 16 + LowHexData
            bytByte(HexDataLen) = HexData
            HexDataLen = HexDataLen + 1
            
            
        End If
                        
    Next n
    
    If HexDataLen > 0 Then                              '修正最后一次循环改变的数值
        HexDataLen = HexDataLen - 1
        ReDim Preserve bytByte(HexDataLen)
    Else
        ReDim Preserve bytByte(0)
    End If
    
    
    If StringLen = 0 Then                               '如果是空串,则不会进入循环体
        strHexToByteArray = 0
    Else
        strHexToByteArray = HexDataLen + 1
    End If
    
    
End Function
Public Sub liqin(strtxt As String)
Dim length As Integer
Dim strsendtext As String
Dim bytsendbyte() As Byte


strsendtext = strtxt

 length = strHexToByteArray(strsendtext, bytsendbyte())
        
        If length > 0 Then
           MSComm1.Output = bytsendbyte
        End If
End Sub

Public Sub Display()
    Dim n As Integer
    Dim intValue As Integer
    Dim intHighHex As Integer
    Dim intLowHex As Integer
    Dim strSingleChr As String * 1
    
    Dim intAddress As Integer
    Dim intAddressArray(8) As Integer
    Dim intHighAddress As Integer
    
    Dim strhex, strAscii  As String
    Dim result(16) As String
    Dim i As Integer
    Dim time1 As String
    Dim number_str As String
    i = 0
    
    
     '设置初值
    strhex = ""
    
    
    '*****************************************
    '获得16进制码
    '*****************************************
    
    
    
    For n = 1 To 8
 
        intValue = receive(n - 1)
        
      
        
        intHighHex = intValue \ 16
        intLowHex = intValue - intHighHex * 16
        
        If intHighHex < 10 Then
            intHighHex = intHighHex + 48
        Else
            intHighHex = intHighHex + 55
        End If
        If intLowHex < 10 Then
            intLowHex = intLowHex + 48
        Else
            intLowHex = intLowHex + 55
        End If
        
        strhex = strhex + " " + Chr$(intHighHex) + Chr$(intLowHex) + " "
        If i < 16 Then
       result(i) = Chr$(intHighHex)
       
       
       i = i + 1
       result(i) = Chr$(intLowHex)
       i = i + 1
       End If
              
    Next n
    If result(0) = "F" And result(1) = "F" Then
    OutDate
    flag_end = True
    
    Exit Sub
    
    End If
    
    
    time1 = result(6) & result(7) & "月" & result(4) & result(5) & "日" & result(2) & result(3) & "时" & result(0) & result(1) & "分"
    number_str = result(14) & result(15) & result(12) & result(13) & result(10) & result(11) & result(8) & result(9)
   ' MsgBox time1
   ' MsgBox number_str
    
    Time_Date(Xia_Biao) = time1
    Niu(Xia_Biao) = number_str
    Xia_Biao = Xia_Biao + 1
    
    
   
  
   
    
End Sub

Public Sub OutDate()
Dim YM As String
Dim hm As String
Dim strtxt As String
Dim str1 As String
Dim i As Integer
Dim rs1 As New ADODB.Recordset
Dim txtsql As String

YM = Date
hm = Time



If Mid(hm, 3, 1) = ":" Then
strtxt = Mid(hm, 4, 2)
strtxt = strtxt + Mid(hm, 1, 2)
Else
strtxt = Mid(hm, 3, 2)
strtxt = strtxt + "0" + Mid(hm, 1, 1)
End If

 Dim newdate As Date
    Dim strtime As String
    Dim daytime, montime As String
    
    newdate = Now
     
     daytime = Day(newdate)
     montime = Month(newdate)
  
     
     If Len(daytime) = 1 Then
     strtxt = strtxt & "0" & daytime
    
     
      Else
     strtxt = strtxt & daytime
     End If
     If Len(montime) = 1 Then
    
     strtxt = strtxt & "0" & montime
     Else
     strtxt = strtxt & montime
     End If
     

liqin (strtxt)

 DataGrid1.AllowAddNew = True
Dim Flag1, Flag2, Flag3, Flag4 As Boolean
 Flag1 = False
 Flag2 = False
 Flag3 = False
 Flag4 = False
 
For i = 0 To Xia_Biao - 1

txtsql = "select * from 事件设置表 where 事件号='" & Niu(i) & "'"
Set rs1 = conn1.Execute(txtsql)
If rs1.EOF = True And rs1.BOF = True Then
Flag1 = True
Else
frmmsg.msg.MsgChar = "录入重复号 在事件设置表" & Niu(i)
frmmsg.Show
TimeDelay 50
End If
rs1.Close

DoEvents
txtsql = "select * from 人员设置表 where 钮号='" & Niu(i) & "'"
Set rs1 = conn1.Execute(txtsql)
If rs1.EOF = True And rs1.BOF = True Then
Flag2 = True
Else
frmmsg.msg.MsgChar = "录入重复号在人员设置表" & Niu(i)
frmmsg.Show
TimeDelay 50
End If
rs1.Close

txtsql = "select * from 地点设置表 where 钮号='" & Niu(i) & "'"
Set rs1 = conn1.Execute(txtsql)
If rs1.EOF = True And rs1.BOF = True Then
Flag3 = True
Else
frmmsg.msg.MsgChar = "录入重复号地点设置表" & Niu(i)
frmmsg.Show
TimeDelay 50
End If
rs1.Close

If Flag1 = True And Flag2 = True And Flag3 = True Then
DataGrid1.Col = 0
rs.AddNew
rs.Fields(0) = Niu(i)
rs.Fields(1) = ""
rs.Update
End If
Flag1 = False
Flag2 = False
Flag3 = False
Flag4 = False



Next
DataGrid1.AllowAddNew = False





End Sub

Public Sub Niu_Hao()



Dim i As Integer
Dim byTinput1() As Byte

 
MSComm1.InBufferCount = 0
MSComm1.Output = "0"
TimeDelay 30

MSComm1.InputMode = comInputModeBinary


 MSComm1.InputLen = 9
 inTinputlen = 9
 ReDim byTinput1(9) As Byte
  byTinput1 = MSComm1.Input
 For i = 2 To 9
 receive(i - 2) = byTinput1(i - 1)
 Next
 DoEvents
  
End Sub