canbusmodule1.bas

一个实际应用中的CanBus调试程序

Attribute VB_Name = "Module1"
'窗口最上
Public Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Public topflag As Boolean
Public Readindex(20), cs_qsjh, cs_lhm As Integer
Public N As Long
Public SS(1024, 2), S() As Byte
Public IsIn As Boolean
Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal aint As Integer) As Integer
Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Integer) As Integer
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long
Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Public Const SW_HIDE = 0
Public Const SW_SHOW = 5
Public tempstr1, tempstr2 As String
Public reading As Boolean
Public WriteflagTemp(2), WriteflagStr(20, 6) As String
Public Sub HideVB(winnamestring)
Dim CurhWnd As Long
Dim i As Integer
CurhWnd = FindWindowPartial(winnamestring)
i = ShowWindow(CurhWnd, SW_HIDE)
End Sub
Public Sub ShowVB(windowsnamestring)
Dim CurhWnd As Long
Dim i As Integer
CurhWnd = FindWindowPartial(windowsnamestring)
i = ShowWindow(CurhWnd, SW_SHOW)
End Sub
Function FindWindowPartial(ByVal TitlePart As String) As Long
Dim hWndTmp As Long
Dim nRet As Integer
Dim TitleTmp As String
Const GW_HWNDNEXT = 2
'We alter the title to compare it case-insensitively.
 TitlePart = UCase$(TitlePart)
'First find all the open windows so we can
'loop through them and find the right one.
 hWndTmp = FindWindow(0&, 0&)
 Do Until hWndTmp = 0
 TitleTmp = VBA.Space$(256)
 nRet = GetWindowText(hWndTmp, TitleTmp, Len(TitleTmp))
 If nRet Then
       'Let's prepare to compare ;)
        TitleTmp = UCase(VBA.Left$(TitleTmp, nRet))
       'Now we see if the window we chased down actually
       'has the caption we want.
        If InStr(TitleTmp, TitlePart) Then
            FindWindowPartial = hWndTmp
            Exit Do
        End If
 End If
 hWndTmp = GetWindow(hWndTmp, GW_HWNDNEXT)
Loop
End Function

'------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
'延时子程序
'------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Public Sub delay(Delay_Value)
    TEMP = Timer
    Do While Timer - TEMP < Delay_Value
        DoEvents
        If Timer - TEMP < 0 Then
            TEMP = TEMP - 86400
        End If
    Loop
End Sub
'------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
'MR13采样值读入
'------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Function p_sjrd(mnzf As String) As Single
Dim loopval, loopval1 As Integer
Dim zf, LB_CMD As String
Dim dt(4) As Integer
On Error GoTo 0
    loopval = 0
    loopval1 = 0
    zf = ""
    For i = 1 To 4
        dt(i) = 0
    Next
    Bcc = 2
    For i = 1 To Len(mnzf)
        zf = Mid$(mnzf, i, 1)
        Bcc = Bcc + Asc(zf)
    Next
    Bcc = Bcc + 3
    Bcc = Bcc Mod 256
    If Len(Hex(Bcc)) < 2 Then
        LB_CMD = Chr$(2) + mnzf + Chr$(3) + "0" + Hex(Bcc) + Chr$(13)
    Else
        LB_CMD = Chr$(2) + mnzf + Chr$(3) + Hex(Bcc) + Chr$(13)
    End If
loop2:
     Com1.MSComm1.InBufferCount = 0
     Com1.MSComm1.Output = LB_CMD
loop1:
        delay (0.05)
        loopval = loopval + 1
        zf = Com1.MSComm1.Input
        If (loopval >= 10) Then
             loopval = 0
             loopval1 = loopval1 + 1
             If loopval1 > 3 Then
                p_sjrd = 0
                Exit Function
             Else
                GoTo loop2
             End If
        End If
        If InStr(1, zf, Chr$(13)) <= 0 Then
              GoTo loop1
        End If
        If InStr(1, zf, Chr$(13)) <> 0 Then
            WZ = InStr(1, zf, ",")
            lb_dt = Mid$(zf, WZ + 1, 4)
            For i = 1 To 4
                dd = Mid$(lb_dt, i, 1)
                If Asc(dd) >= 65 And Asc(dd) <= 70 Then
                    dt(i) = Asc(dd) - 55
                Else
                    dt(i) = Val(dd)
                End If
            Next
            If dt(1) > 8 Then
               dt(1) = dt(1) - 16
            End If
            p_sjrd = dt(1) * 4096 + dt(2) * 256 + dt(3) * 16 + dt(4)
            If p_sjrd > 32767 Then
               p_sjrd = p_sjrd - 65536
            End If
            Com1.Caption = "采样监控程序 " + Str(p_sjrd)
        End If
End Function

 Function s_sjwt(sylh As Integer, sj As Single, wrdz As String) As String   '数据写入
    If sj < 0 Then
        sj = 65536 + sj
    End If
    sjzf = Hex$(Val(sj))
    For k = 1 To 4 - Len(sjzf)
        sjzf = "0" + sjzf
    Next
    If Len(Hex$(sylh)) < 2 Then
        lb_wd = "0" + Trim$(Hex$(sylh)) + wrdz + sjzf
    Else
        lb_wd = Trim$(Hex$(sylh)) + wrdz + sjzf
    End If
     Bcc = 2
    For i = 1 To Len(lb_wd)
        zf = Mid$(lb_wd, i, 1)
        Bcc = Bcc + Asc(zf)
    Next
    Bcc = Bcc + 3
    Bcc = Bcc Mod 256
    If Len(Hex(Bcc)) < 2 Then
        LB_CMD = Chr$(2) + lb_wd + Chr$(3) + "0" + Hex(Bcc) + Chr$(13)
    Else
        LB_CMD = Chr$(2) + lb_wd + Chr$(3) + Hex(Bcc) + Chr$(13)
    End If
    Com1.MSComm1.RThreshold = 0
    Com1.MSComm1.Output = LB_CMD
    delay (0.3)
End Function
'------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
'7011采样值读入
'------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Function adread(lb_mlb As String, delaytime As Single) As Single
On Error GoTo cwzydz  'Resume Next
    adread = 0
    For f = 1 To Len(lb_mlb)
        cyzb = cyzb + Asc(Mid$(lb_mlb, f, 1))
    Next
    cyzb = cyzb And &HFF
    lb_mlbb = lb_mlb + Hex$(cyzb) + Chr$(13)
    lb_zfc = ""
    cyzb = 0
    Com1.MSComm1.InBufferCount = 0
    Com1.MSComm1.Output = lb_mlbb
    delay (delaytime)
    If Left$(lb_mlbb, 1) = "$" Then
        Exit Function
    Else
        lb_zfcr = Com1.MSComm1.Input
        lb_zfc = lb_zfc + lb_zfcr
        If Right(lb_zfc, 1) = Chr$(13) Or Right(lb_zfc, 1) = Chr$(10) Then
            lb_zfc = Trim$(lb_zfc)
            If Left$(lb_mlbb, 1) = "*" Then
                adread = Val(Mid$(lb_zfc, 4, 2))
            Else
                WZ = InStr(1, lb_zfc, ">")
                If WZ > 0 Then
                    zfc = Mid$(lb_zfc, WZ, 8)
                    For v = 1 To 8
                        cyzb = cyzb + Asc(Mid$(zfc, v, 1))
                    Next
                    cyzc = cyzb And &HFF
                    If Hex$(cyzc) = Mid$(lb_zfc, 9, 2) Then
                        adread = Val(Mid$(zfc, 3, 6))
                    Else
                        adread = 0
                    End If
                End If
            End If
        End If
    End If
cwzydz:
End Function

Function sendcomm(interfacenum, equipmentnum, tempstr As String) As String
reading = True
     startpoint = 1
     WZ1 = 1
     loopcount = 0
     tempstr = tempstr + ":"
     Bcc = 0
     For i = 2 To Len(tempstr)
         Bcc = Bcc Xor Asc(Mid$(tempstr, i, 1))
     Next
         'Bcc = Bcc Mod 256
     If Len(Hex(Bcc)) = 2 Then
          tempstr = tempstr + Hex(Bcc) + Chr(13)
     Else
          tempstr = tempstr + "0" + Hex(Bcc) + Chr(13)
     End If
     tempstr = "3" + equipmentnum + "@" + Chr(13) + tempstr
     tempstr = "{" + Format(Len(tempstr), "000") + interfacenum + tempstr + "|"
     Bcc = 0
     For i = 1 To Len(tempstr)
         Bcc = Bcc + Asc(Mid$(tempstr, i, 1))
     Next
         Bcc = Bcc Mod 256
     If Len(Hex(Bcc)) = 2 Then
          Bcc = tempstr + Hex(Bcc) + Chr$(125)
     Else
          Bcc = tempstr + "0" + Hex(Bcc) + Chr$(125)
     End If
     If Form1.MSComm1.PortOpen = False Then
          Form1.Command1.Value = True
          Form1.Command1.Caption = "关闭串口"
     End If
     Form1.MSComm1.OutBufferCount = 0              '清空发送缓冲区
     Form1.MSComm1.InBufferCount = 0               '清空接收缓冲区
     Form1.MSComm1.Output = Bcc
     delay (0.5)
     aaa = Form1.MSComm1.Input
     DoEvents
End Function

Public Function writecomm(jjhh As String, tempstr As String)
Dim interfacenum, equipmentnum, commandopen As String
    Form1.Adodc3.RecordSource = "select * from 配置表 where 对应炉号='" & Trim(jjhh) & "'"
    Form1.Adodc3.Refresh
    If Form1.Adodc3.Recordset.RecordCount > 0 Then
       interfacenum = Form1.Adodc3.Recordset.Fields("接口编号")
       equipmentnum = Form1.Adodc3.Recordset.Fields("设备编号")
    End If
    WriteflagStr(jjhh, 2) = "0"
    'commandopen = "@" + Format(jjhh, "00") + "1W018C0,0001"
    commandopen = Trim("@") + Format(jjhh, "00") + "C1 _COM"
    a = sendcomm(interfacenum, equipmentnum, commandopen)
    delay (2)
    commandopen = tempstr
    a = sendcomm(interfacenum, equipmentnum, commandopen)
     delay (1.5)
    'commandopen = "@" + Format(jjhh, "00") + "1W018C0,0000"
    commandopen = Trim("@") + Format(jjhh, "00") + "C1 _LOC"
    a = sendcomm(interfacenum, equipmentnum, commandopen)
    delay (1.5)
End Function
Public Function writecomm7011(jjhh As String, tempstr As String)
Dim interfacenum, equipmentnum, commandopen As String
    Form1.Adodc3.RecordSource = "select * from 配置表 where 对应炉号='" & Trim(jjhh) & "'"
    Form1.Adodc3.Refresh
    If Form1.Adodc3.Recordset.RecordCount > 0 Then
       interfacenum = Form1.Adodc3.Recordset.Fields("接口编号")
       equipmentnum = Form1.Adodc3.Recordset.Fields("设备编号")
    End If
    WriteflagStr(jjhh, 2) = "0"
    commandopen = tempstr
    a = sendcomm(interfacenum, equipmentnum, commandopen)
End Function
Public Function SendCanBus(tempstring As String)
    If Form1.MSComm1.PortOpen = False Then
       Form1.Command1.Value = True
       Form1.Command1.Caption = "关闭串口"
    End If
    Form1.MSComm1.OutBufferCount = 0              '清空发送缓冲区
    Form1.MSComm1.InBufferCount = 0                '清空接收缓冲区
    delay (1.5)
    Form1.MSComm1.Output = tempstring
    Form1.Text9.Text = "发送字符串为：  " + tempstring + "   包含（" + Str(Len(tempstring)) + " ）个字符."
    delay (1.5)
    ssstr = Form1.MSComm1.Input
End Function