module1.bas

vb串口编程电表读数 vb串口编程电表读数 vb串口编程电表读数 vb串口编程电表读数

Attribute VB_Name = "Module1"

Dim STR() As Byte '拼装每条命令时，临时存放数组
Public send_r() As Variant '所有的抄表命令字，存放在数组send_r(30)中，不抄的命令也占用一个数组元素，只是将该元素的长度设为零。即长度为零的字段为不抄的项目

Sub DISPLAY_BH(TEXT_1 As TextBox, C_B1 As ComboBox, C_B2 As ComboBox, TEXT_2 As TextBox, OP_1 As OptionButton, OP_2 As OptionButton)
Dim ss As String
ss = Trim(mydata.bh)
If InStr(1, ss, "AA", vbTextCompare) <> 0 Then
TEXT_1.Text = Mid(ss, 1, 6)
CHANG_CODE = Mid(ss, 7, 1)
year_code = Mid(ss, 8, 2)
If (Val(year_code) < 2) Or (Val(year_code) > 20) Then year_code = "02"
sign = 0
For k1 = 0 To C_B1.ListCount - 1
    If C_B1.List(k1) = CHANG_CODE Then
    C_B1.ListIndex = k1
    k1 = C_B1.ListCount
    sign = 1
    End If
Next
If sign = 0 Then C_B1.ListIndex = 0

For k1 = 0 To C_B2.ListCount - 1
    If C_B2.List(k1) = year_code Then
    C_B2.ListIndex = k1
    k1 = C_B2.ListCount
    sign = 1
    End If
Next
If sign = 0 Then C_B2.ListIndex = 0

OP_1.Value = True
Else
TEXT_2.Text = ss
OP_2.Value = True
End If
end_s = True
MARK = 0
End Sub
Public Sub GET_jsBH(ss As TextBox, bo1 As ComboBox, bo2 As ComboBox, bh) '拼装表号
    Dim x0, y0 As Byte
    ss.Text = Trim(ss.Text)
    x0 = Val(Mid(ss.Text, 5, 1)): y0 = Val(Mid(ss.Text, 6, 1))
  bh(0) = (x0 * 16 + y0)
    x0 = Val(Mid(ss.Text, 3, 1)): y0 = Val(Mid(ss.Text, 4, 1))
  bh(1) = (x0 * 16 + y0)
    x0 = Val(Mid(ss.Text, 1, 1)): y0 = Val(Mid(ss.Text, 2, 1))
  bh(2) = (x0 * 16 + y0)
  '取厂商代码
   bh(3) = Asc(bo1.List(bo1.ListIndex))
  '取出厂年份
  x0 = Val(Mid(bo2.Text, 1, 1)): y0 = Val(Mid(bo2.Text, 2, 1))
  bh(4) = (x0 * 16 + y0)
  bh(5) = &HAA
End Sub
Public Sub get_tybh(ss As TextBox, bh)
        Dim x0, y0 As Byte
        x0 = Val(Mid(ss.Text, 11, 1)): y0 = Val(Mid(ss.Text, 12, 1))
        bh(0) = (x0 * 16 + y0)
        x0 = Val(Mid(ss.Text, 9, 1)): y0 = Val(Mid(ss.Text, 10, 1))
        bh(1) = (x0 * 16 + y0)
        x0 = Val(Mid(ss.Text, 7, 1)): y0 = Val(Mid(ss.Text, 8, 1))
        bh(2) = (x0 * 16 + y0)
        x0 = Val(Mid(ss.Text, 5, 1)): y0 = Val(Mid(ss.Text, 6, 1))
        bh(3) = (x0 * 16 + y0)
        x0 = Val(Mid(ss.Text, 3, 1)): y0 = Val(Mid(ss.Text, 4, 1))
        bh(4) = (x0 * 16 + y0)
        x0 = Val(Mid(ss.Text, 1, 1)): y0 = Val(Mid(ss.Text, 2, 1))
        bh(5) = (x0 * 16 + y0)
End Sub
'拼装抄表命令字，存放在数组send_r(30)中，长度为零的字段不抄
 Public Sub copy_Com(check, bh, mm, nn)
ReDim STR(15), send_r(31)
'填固定项
   STR(0) = &HFE: STR(1) = &HFE: STR(2) = &H68
   STR(9) = &H68: STR(10) = &H1
   STR(11) = &H2: STR(15) = &H16
   For i = 0 To 5           '填表号
    STR(i + 3) = bh(i)
   Next
      For i = mm To nn
   If check(i).Value = vbChecked Then ' 如果当前项被选中则拼装命令
      Select Case i
    Case 1 '读当前有功电量
         STR(12) = &H52 '1F+33:
        STR(13) = &HC3 '90+33 :
    Case 2 '读反向累计电量
        STR(12) = &H62: STR(13) = &HC3
        
    Case 3 '读上月有功电量
        STR(12) = &H52: STR(13) = &HC7
        
    Case 4 '读上上月有功电量
        STR(12) = &H52: STR(13) = &HCB
        
    Case 5 '读历史记录1=01月电量
         STR(12) = &H53: STR(13) = &H4
        
    Case 6 '读历史记录2=02月电量
         STR(12) = &H54: STR(13) = &H4
       
    Case 7 '读历史记录3=03月电量
         STR(12) = &H55: STR(13) = &H4
       
    Case 8 '读历史记录4=04月电量
         STR(12) = &H56: STR(13) = &H4
        
    Case 9 '读历史记录5=05月电量
         STR(12) = &H57: STR(13) = &H4
        
    Case 10 '读历史记录6=06月电量
         STR(12) = &H58: STR(13) = &H4
        
    Case 11 '读历史记录7=07电量
         STR(12) = &H59: STR(13) = &H4
        
    Case 12 '读历史记录8=08月电量
         STR(12) = &H5A: STR(13) = &H4
        
    Case 13 '读历史记录9=09月电量
         STR(12) = &H5B: STR(13) = &H4
        
    Case 14 '读历史记录10=10月电量
         STR(12) = &H5C: STR(13) = &H4
        
    Case 15 '读历史记录11=11月电量
         STR(12) = &H5D: STR(13) = &H4
        
    Case 16 '读历史记录12=12月电量
         STR(12) = &H5E: STR(13) = &H4
        
    Case 17 '读最近反向起始时间
         STR(12) = &H53: STR(13) = &HE3
        
    Case 18 '读反向累计总时间
         STR(12) = &H54: STR(13) = &HE3
        
    Case 19 '读最近编程时间
         STR(12) = &H43: STR(13) = &HE5
        
    Case 20 '读编程次数
         STR(12) = &H45: STR(13) = &HE5
        
    Case 22 '读日期和星期
         STR(12) = &H43: STR(13) = &HF3
    
    Case 21 '读时间
            STR(12) = &H44: STR(13) = &HF3
    Case 28 '读电表运行状态
        STR(12) = &H53: STR(13) = &HF3
        
    Case 24 '读电表常数
         STR(12) = &H63: STR(13) = &HF3
        
    Case 27 '读表号
         STR(12) = &H65: STR(13) = &HF3
        
    Case 23 '读自动读表日
         STR(12) = &H4A: STR(13) = &HF4
        
    Case 25 '读表号
        STR(12) = &H65: STR(13) = &HF3
        
        'Case 25 '读时段数
        'STR(12) = &H45: STR(13) = &HF6
        
    Case 26 '读时段表
         STR(12) = &H72: STR(13) = &HF6
        
    Case 29 '读脉冲计数
         STR(12) = &H4E: STR(13) = &HF4
        
    Case 30 '读出厂编号
         STR(12) = &H67: STR(13) = &HF3
        
    Case 31 '读局编号
         STR(12) = &H66: STR(13) = &HF3

    End Select
         SUM1 = 0    '求和
        For n = 2 To 13
        SUM1 = SUM1 + STR(n)
        Next
        STR(14) = SUM1 Mod 256
            If i = 25 Then
                send_r(26) = STR()
            Else
                send_r(i - 1) = STR()
            End If
    End If
  Next
End Sub

Public Function myweekday() As String
Dim myweek As VbDayOfWeek
Dim weekchr(7) As String * 1
weekchr(1) = "日": weekchr(2) = "一": weekchr(3) = "二": weekchr(4) = "三"
weekchr(5) = "四": weekchr(6) = "五": weekchr(7) = "六"
myweek = Weekday(Date)
myweekday = "星期" & weekchr(myweek)
End Function
Public Function key_value(a_ascii As Integer) As Integer
Dim mychr As String * 1
 key_value = a_ascii
 If a_ascii <> 8 Then
    mychr = Chr(a_ascii)
    If ("0" > mychr) Or (mychr > "9") Then key_value = 0
 End If
End Function
Public Sub OnErrStatement(title As String)
'检查可能发生的错误。
   Dim msg As String
   
   Select Case Err.Number
     Case 1
      msg = "广播表号失败，请检查串口号及线路连接是否正确。"
    Case 2
      msg = "表号错误。"
    Case 3
        msg = "时段数必须在1--12之间。"
    Case 4
        msg = "输入的电量过大。"
    Case 100
        msg = "文件未找到。"
    Case 600
      msg = "输入的日期非法。"
    Case 601
      msg = "输入的时间非法。"
    Case 602
      msg = "电表常数非法。"
    Case 603
      msg = "表号非法。"
    Case 604
      msg = "出厂编号无效。"
    Case 605
      msg = "局编号无效。"
   Case 621
      msg = "无有效选择项。"
   Case 622
        msg = "请输入编程密码。"
    Case 623
      msg = "请输入编程密码。"
    Case 624
      msg = "新编程密码错,请重新输入"
    Case 625
    msg = "清零密码错,请重新输入"
    Case 626
    msg = "新清零密码错,请重新输入"
    Case 627
    msg = "请输入清零密码"
    Case 630
        msg = "应答超时。请检查串口号,表号,密码及线路连接是否正确."
    Case 631
      msg = "应答命令错误。"
                     
End Select
      MsgBox msg, vbExclamation, title '错误信息，一个确认键，标题栏文本
      MARK = 0: end_s = True
      'Err.Clear   ' 清除 Err 对象字段。
End Sub


'填编程密码
Function FILL_BCPASS(passfield As TextBox, mima)
Dim k As Byte
If passfield.Text = "" Then
BC_err0:  Err.Number = 622
          GoTo BC_ERR2
    End If
    If Len(passfield.Text) <> 6 Then
BC_ERR1:
        Err.Number = 623    '编程密码输入错误
BC_ERR2:
        OnErrStatement (mtitle)
        MARK = 0
        Exit Function
    End If
   
    For k = 0 To 2
    x0 = Mid(passfield.Text, 1 + 2 * k, 1): y0 = Mid(passfield.Text, 2 + 2 * k, 1)
    If (x0 < "0") Or (x0 > "9") Or (y0 < "0") Or (y0 > "9") Then
        GoTo BC_ERR1
    Else
        mima(k) = (Val(x0) * 16 + Val(y0)) + &H33
        
    End If
    Next

End Function
Public Sub set_replay(aray() As Byte, INF)
Dim cx As Byte
Dim SUM1 As Integer
cx = UBound(aray()) '接收的字节数
If cx < 10 Then GoTo ERR_123
k = 0
'寻找FEH,68H开始的有效应答信号
Do
k = k + 1
Loop Until ((aray(k - 1) = 254) And (aray(k) = 104)) Or (k = cx)
'如果找到了，求和
SUM1 = 0
If (k < cx) Then
j = k + 9 + aray(k + 9)
If j > cx Then GoTo ERR_123 '如果接收到的数据长度<应答命令给出的数据长度，说明应答命令错误
For n = k To j
        SUM1 = SUM1 + aray(n)
        Next
        SUM1 = SUM1 Mod 256
        If SUM1 <> aray(n) Then
            frm_msg.ForeColor = &HFF&
          frm_msg.Print INF & "失败" 'COM_MSG(ii + 1) & "失败"
          frm_msg.ForeColor = &H0&
        Else
            frm_msg.ForeColor = &H0&
          frm_msg.Print INF & "成功" 'COM_MSG(ii + 1) & "成功"
        End If
Else
ERR_123:
frm_msg.ForeColor = &HFF&
frm_msg.Print INF & "失败" 'COM_MSG(ii + 1) & "失败"
frm_msg.ForeColor = &H0&
End If
End Sub