frmcomm.frm

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

        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
'i = 4100
    i = i * 2
   Count_Total = i
   Text1.Text = bang_num
Text2.Text = i
     If i = 0 Then
     frmmsg.Top = frmread.Top + 600
    frmmsg.Left = frmread.Left + 5320
       frmmsg.msg.MsgChar = "您的数据记录已经成功写入相应数据库！"
        MSComm1.PortOpen = False
               
                frmmsg.Show
                
                flag = True
                Exit Sub
                End If
                
    ProgressBar1.Min = 0
    
    ProgressBar1.Max = i
    ProgressBar1.Value = 0
    
    ProgressBar1.Visible = True
    
    
    length = picpgb2.Width / Count_Total
    
    
   
                
    'MsgBox bang_num
    'MsgBox i
    ReDim Time_Date(i) As String
    ReDim Time_Time(i) As String
    ReDim Niu(i) As String
     
      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
    daytime = "0" & daytime
    End If
     If Len(montime) = 1 Then
    
    montime = "0" & montime
    End If
    newdate = Now
     time1 = Year(newdate) & "/" & montime & "/" & daytime
     
      mon_time = time1
    
    'time1 = result(14) & result(15) & "月" & result(12) & result(13) & "号" & result(10) & result(11) & ":" & result(8) & result(9)
   
    
   
     
    
    
 
    
    
    
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
    
    
    Dim S_time, S_number As String '时间和钮号
    i = 0
    
    
    
    'ProgressBar1.Visible = False
    
    
     '设置初值
    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
     ProgressBar1.Visible = False
  OutDate
  flag_end = True
  
    Exit Sub
    
    End If
    Dim newdate As Date
    Dim strtime As String
    newdate = Now
    
    Dim re_fir, re_two As String
 
    re_fir = Mid(result(6), 1, 1)
    re_two = Mid(result(7), 1, 1)
   If re_two = "A" Then
   re_two = "10"
  End If
  
   If re_two = "B" Then
   re_two = "11"
  End If
  
   If re_two = "C" Then
   re_two = "12"
  
   End If
   
   If Len(re_two) = 1 Then
   re_two = "0" & re_two
   End If
   
   
     strtime = Year(newdate) & "/" & re_two & "/" & result(4) & result(5)
    
    time1 = 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) = strtime
    Time_Time(Xia_Biao) = time1
    Niu(Xia_Biao) = number_str
    'Print #3, time1, number_str
   Xia_Biao = Xia_Biao + 1 ' 写事件信息
   Time_Date(Xia_Biao) = strtime
    Time_Time(Xia_Biao) = time1
    Niu(Xia_Biao) = re_fir
    
    
    
    
    Xia_Biao = Xia_Biao + 1
    Text3.Text = Xia_Biao
    ProgressBar1.Value = ProgressBar1.Value + 1
   
        distance = distance + length
    
    
    
   
   'Call Niu_Hao
   
    
End Sub

Public Sub OutDate()
Dim YM As String
Dim hm As String
Dim strtxt As String
Dim str1 As String



Dim conn1 As New ADODB.Connection
Dim txtsql As String
Dim rs_add As New ADODB.Recordset
Dim i As Integer
Dim mrc As ADODB.Recordset
Dim conn2 As New ADODB.Connection


Dim connectionstring As String

connectionstring = "provider=Microsoft.Jet.oledb.4.0;" & _
                   "data source=" & App.Path & "\jk.mdb"
conn1.Open connectionstring
 conn2.Open connectionstring




Timer1.Enabled = False
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)
   

   Shape3.FillColor = "&H00C0C0C0"
    Shape2.FillColor = "&H00C0C0C0"
    Shape1.FillStyle = 0
    Shape1.FillColor = "&H0000FF00"
Text1.Text = bang_num
Text2.Text = Xia_Biao

txtsql = "delete * from 读入表"
conn2.Execute (txtsql)
Set conn2 = Nothing



txtsql = "select * from 读入表"


rs_add.Open txtsql, conn1, adOpenKeyset, adLockPessimistic



For i = 0 To Xia_Biao - 1



       rs_add.AddNew
       rs_add.Fields(0) = mon_time
       rs_add.Fields(1) = bang_num
       rs_add.Fields(2) = Niu(i)
       rs_add.Fields(3) = Time_Date(i)
       rs_add.Fields(4) = Time_Time(i)
      rs_add.Update
      
Next i
   


rs_add.Close
Set conn1 = Nothing



  frmmsg.Top = frmread.Top + 600
    frmmsg.Left = frmread.Left + 5320
   Shape3.FillColor = "&H00C0C0C0"
    Shape2.FillColor = "&H00C0C0C0"
    Shape1.FillStyle = 0
    Shape1.FillColor = "&H0000FF00"
    frmmsg.msg.MsgChar = "读入数据结束"
    ProgressBar1.Visible = False
    
     asPopup3.Enabled = True
     asPopup3.BackColor = "&HC0FFFF"
    
MsgBox "succeed"


   
    





End Sub

Public Sub Niu_Hao()



Dim i As Integer
Dim byTinput1() As Byte

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

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
 
'Call Display





 
 

 
End Sub




Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next

MSComm1.PortOpen = False


Open App.Path & "\savecom.txt" For Output As #1



strfile = Combo1.Text

Print #1, strfile
Close (1)
Close (3)



End Sub

Private Sub Timer1_Timer()
Horizontal Me, RGB(131, 166, 244), RGB(33, 120, 224)
Horizontal Me, &HB9C4B9, &HFF8080
End Sub