dataoperate.cls

VB编写的基于645规约的电表行业485通讯抄表程序

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "DataOperate"
Attribute VB_GlobalNameSpace = True
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'Download by http://www.codefans.net
' 本模块针对 645 规约开发
' 作者：沈礼礼

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private varSend  As Variant
Private varRecive As Variant
Public Flag_Comm485 As Boolean   'True:端口占用

Public Function DataSend(Com485 As Object, StrAddress As String, CortrolAndLength As String, StrSendData As String, Delay_ByteMedulla As Long, Delay_FrameMedulla As Double, Responsion_Length As Long) As String

    '本过程向电表发送规约来接收数据
    
    'StrAddress                 :  表通讯地址
    'CortrolAndLength           :  控制码和数据长度
    'StrSendData                :  发送的数据部分    （ 数据标识 + 密码 + 数据 ）
    'Delay_ByteMedulla          :  字节间延时（毫秒）
    'Delay_FrameMedulla         :  帧发送完后延时（秒）
    'Responsion_Length          :  应答帧长度

If Flag_Comm485 = True Then  '数据通讯中

On Error Resume Next
    
    Dim tmpi As Long
    Dim ByteBuf(1 To 1) As Byte
    Dim ArrByte() As Byte                             '要发送的字节数组
    Dim LngDataLength As Long                         '帧长度
    Dim StrCortrol As String, StrLength As String     '控制码   '数据长度
    StrCortrol = Mid(CortrolAndLength, 1, 2)
    StrLength = Right(CortrolAndLength, 2)
    LngDataLength = 14 + Val("&H" & StrLength)
    ReDim ArrByte(1 To LngDataLength) As Byte
    Dim StrbufModu As String
    Dim SumMod As Long
    Dim Ch As Byte
    Dim I As Long
    Dim MsgB As String
    Dim MsgT As Long
    Dim LngCount As Long                              '接受到的字节数
    Dim MiaoTmp1 As Double, MiaoTmp2 As Double        '等待开始时间和等待时间
    Dim Gobz As Boolean
    MsgT = 0
    Gobz = False
    LngCount = 0
    MsgB = ""
    Responsion_Length = 0

    ArrByte(1) = &HFE
    ArrByte(2) = &HFE
    
    ArrByte(3) = &H68
    
    If Len(StrAddress) = 12 Then                     ' 发送的地址
        ArrByte(4) = "&H" & Mid(StrAddress, 11, 2)
        ArrByte(5) = "&H" & Mid(StrAddress, 9, 2)
        ArrByte(6) = "&H" & Mid(StrAddress, 7, 2)
        ArrByte(7) = "&H" & Mid(StrAddress, 5, 2)
        ArrByte(8) = "&H" & Mid(StrAddress, 3, 2)
        ArrByte(9) = "&H" & Mid(StrAddress, 1, 2)
    End If
    
    ArrByte(10) = &H68
    
    ArrByte(11) = "&H" & StrCortrol                 ' 如 读：01 / 写：04
    ArrByte(12) = "&H" & StrLength                  ' 长度 = 02H + M(数据项长度) + 4字节密码   （如：读(0102)->2位(DI0|DI1)+无后续，(0A06)写设备地址->6位地址）
    
    For tmpi = 1 To Val("&H" & StrLength)
        ArrByte(12 + tmpi) = "&H" & Mid(StrSendData, 2 * tmpi - 1, 2)  '发送的数据项 （未加 33H ！ ---> 针对写电量等操作）
    Next tmpi
    
    SumMod = 0
    For tmpi = 3 To (LngDataLength - 2)
        SumMod = SumMod + ArrByte(tmpi)
    Next tmpi
    ArrByte(LngDataLength - 1) = SumMod Mod 256     ' CS 位处理
    
    ArrByte(LngDataLength) = &H16                   ' 结束标志

    Com485.Settings = "1200,E,8,1"
    Com485.InputMode = comInputModeBinary
    If Com485.PortOpen = False Then Com485.PortOpen = True
    Com485.InBufferCount = 0

    For tmpi = 1 To LngDataLength
        ByteBuf(1) = ArrByte(tmpi)
        Com485.Output = ByteBuf
        Delay Delay_ByteMedulla
    Next tmpi
    
    MiaoTmp1 = Timer
    Do
        DoEvents
        If LngCount = 10 Then
            Responsion_Length = 10 + Ch + 2
        End If
        If Responsion_Length <> 0 Then
            If LngCount >= Responsion_Length Then Exit Do
        End If
        MiaoTmp2 = Timer - MiaoTmp1
        If MiaoTmp2 > Delay_FrameMedulla Then Exit Do
        With Com485
        If .InBufferCount > 0 Then
          StrbufModu = .Input
          If LenB(StrbufModu) > 0 Then
            For I = 1 To LenB(StrbufModu)
                Ch = AscB(MidB(StrbufModu, I, 1))
                If Ch = 104 Then Gobz = True
                If Gobz = True Then
                    MsgB = MsgB & Right("000" & Ch, 3)
                    LngCount = LngCount + 1
                    If LngCount <= 10 Or LngCount <= Responsion_Length - 2 Then
                        MsgT = MsgT + CLng(Ch)
                    End If
                End If
            Next I
          End If
       End If
       End With
       DoEvents
    Loop
    
    MsgT = MsgT Mod 256
    If Len(MsgB) < 36 Then
        MsgB = ""
    Else
        If CLng(Mid(MsgB, 22, 3)) <> 104 Then
            MsgB = ""
        End If
    End If
    
    DataSend = MsgB                               '接收到的数据 ---> 待处理
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Debug.Print
    Debug.Print "Send ---> "
    For I = 1 To LngDataLength
     Debug.Print Right("00" & Hex(ArrByte(I)), 2) & " ";
    Next I
    Debug.Print
    Debug.Print "Receive--->  " & CStr(MsgB)

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
End If

End Function

Public Function ReceiveData_Operate(ReceiveData As String, StrFormat As String, DataLength As String) As String
    
    '本过程针对接收到的数据进行处理返回用户需要的数据格式
    
    'ReceiveData                   :  接收到的数据
    'StrFormat                     :  返回的数据格式 如 电量格式为："NNNNNN.NN"
    'DataLength                    :  数据项长度
    
On Error GoTo ErrMsg

   Dim K, P As Integer
   Dim tmp, Sll, SZ As String

   Sll = ""
   If ReceiveData <> "" Then
       If Mid(ReceiveData, 1, 3) = "104" And Val(Right(ReceiveData, 3)) = 22 Then  '验证收到信息是否正确
       
           '对接受到的数据进行处理,返回用户数据
           Dim Data_Msg As String
           Data_Msg = Right(ReceiveData, Val(DataLength) * 3 + 6)                  '收到的数据=最后6位(CS+结束位) + 数据项长度*3
           Data_Msg = Mid(Data_Msg, 1, Len(Data_Msg) - 6)
           
           For K = 1 To Len(Data_Msg) / 3
               tmp = Right("00" & Hex(Mid(Data_Msg, 3 * (K - 1) + 1, 3) - 51), 2)  '接收到的数据按位减33H
               Sll = tmp & Sll                                                     '收到的数据为逆序,应再逆序处理
           Next K
 
           P = 1
           For K = 1 To Len(Trim(StrFormat))                                       '针对相应格式返回用户数据 （如 读总电量9010格式"NNNNNN.NN"  --> 返回 "000098.67"）
               tmp = Mid(Trim(StrFormat), K, 1)
               Select Case UCase(tmp)
                  Case "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "1", "2", "3", "4", "5", "6", "7", "8", "9", "0"
                     SZ = Mid(Sll, P, 1)
                     ReceiveData_Operate = ReceiveData_Operate & SZ
                     P = P + 1
                  Case Else                                                        '处理 中文字符/特殊字符/空格 等,直接将其加上显示出 如 901F:“ 总NNNNNN.NN峰NNNNNN.NN平NNNNNN.NN谷NNNNNN.NN ” 显示为“ 总000043.05峰000000.00平000043.05谷000000.00 ”
                     ReceiveData_Operate = ReceiveData_Operate & tmp
               End Select
           Next K
       Else
           ReceiveData_Operate = ""
       End If
   Else
       ReceiveData_Operate = ""
   End If

Exit Function
    
ErrMsg:
   MsgBox (Err.Description)
  
End Function

Public Function DataPart(Identifier As String, Password As String, MyData As String, StrFormat As String, Optional ByVal IsRead As Boolean = True) As String
  
  '本过程针对发送数据的预处理
  
  '发送数据格式                   :  数据项标识 + 写入的密码 + 待写入的数据
  
  'IsRead                         :  定义为判断读写操作 (写电量标识发送 5213 , 并且数据位不加33H)
  'Identifier                     :  数据项标识
  'Password                       :  写入的密码
  'MyData                         :  待写入的数据
  'StrFormat                      :  数据格式-->发送数据格式化,如地址“ 123 -> 000000000123 ”
  
If Flag_Comm485 = False Then
  Flag_Comm485 = True
   
  Dim K, P As Integer
  Dim tmp, tt, temp, Str As String
  
  'Identifier
  If Identifier <> "" Then
    If IsRead = True Then  '读                       ' 读操作按字节+33H操作
      DataPart = IIf((Val("&H" & Mid(Identifier, 3, 2)) + 51) > 255, Right("00" & Hex(Val("&H" & Mid(Identifier, 3, 2)) + 51 - 256), 2), Right("00" & Hex(Val("&H" & Mid(Identifier, 3, 2)) + 51), 2)) & IIf((Val("&H" & Mid(Identifier, 1, 2)) + 51) > 255, Right("00" & Hex(Val("&H" & Mid(Identifier, 1, 2)) + 51 - 256), 2), Right("00" & Hex(Val("&H" & Mid(Identifier, 1, 2)) + 51), 2))
    Else                   '写                       ' 写操作 [标识码] 需要在数据库中手动加入 33H
      DataPart = Mid(Identifier, 3, 2) & Mid(Identifier, 1, 2)
    End If
  End If
  
  'Password                                          ' 按字节 +33H
  If Password <> "" Then
    tmp = ""
    For K = 1 To Len(Password) Step 2
       tmp = IIf((Val("&H" & Mid(Password, K, 2)) + 51) > 255, Right("00" & Hex(Val("&H" & Mid(Password, K, 2)) + 51 - 256), 2), Right("00" & Hex(Val("&H" & Mid(Password, K, 2)) + 51), 2)) & tmp
    Next K
    DataPart = DataPart & tmp
  End If
  
  '1.数据格式化 2.逆序处理                           ' 按字节 +33H
  Str = ""
  If MyData <> "" And StrFormat <> "" Then
  
    tmp = ""
    temp = ""
    tmp = StringFormat(MyData, StrFormat)            ' 数据格式化
    
    For K = 1 To Len(tmp)                            ' 去除特殊符号
       tt = Mid(Trim(tmp), K, 1)
       If IsNumber(tt) = True Then temp = temp & tt
    Next K

    Select Case UCase(Trim(Identifier))
    
        Case "1352", "1362"                          ' 写电量操作例外,数据位不加 33H！ 如 （写正向有功电量： FE 68 99 99 99 99 99 99 68 16 0B 52 13 33 33 33 33 AA [01 11 11 11]  '[]内为数据  ）
            For K = 1 To Len(temp) Step 2            ' 逆序处理 [数据需逆序发送]
               Str = Mid(temp, K, 2) & Str           ' 写电量数据位不加 33H 处理
            Next K

        Case Else
            For K = 1 To Len(temp) Step 2            ' 逆序处理 [数据需逆序发送]
               Str = IIf((Val("&H" & Mid(temp, K, 2)) + 51) > 255, Right("00" & Hex(Val("&H" & Mid(temp, K, 2)) + 51 - 256), 2), Right("00" & Hex(Val("&H" & Mid(temp, K, 2)) + 51), 2)) & Str
            Next K
            
    End Select
    
  End If
  
  '
  DataPart = DataPart & Str
  
End If

End Function