zlgcomport.bas

这个的用于DP51单片机的串口通讯的系列程序

    Dim j As Integer
       
    WriteE2PRom = 1
    nFrameLen = 8                            '每帧发送八个数据
    nBgnAdr_l = BgnAdr_L
    nBgnAdr_h = BgnAdr_H
      
    nLen = Len(WriteDate)                    '取字符串长度
    If nLen > 0 Then
        nFrameNum = Int(nLen / nFrameLen)
        nFrameLeave = nLen Mod nFrameLen
    End If
    
    
    For i = 1 To nFrameNum                   '发送nFrameNum帧数据
        cAFrameOrder(0) = &H12
        cAFrameOrder(1) = &H21
        cAFrameOrder(2) = &HD                '长度
        cAFrameOrder(3) = DpAdr              'DP-51地址
        cAFrameOrder(4) = nBgnAdr_l          '取发送地址
        cAFrameOrder(5) = nBgnAdr_h
        
        For j = 1 To nFrameLen                '取发送数据
           cAFrameOrder(5 + j) = Asc(Mid(WriteDate, (i - 1) * 8 + j, 1))
        Next j
        
           cAFrameOrder(14) = 0               '计算校验和
        For j = 0 To 13
          cAFrameOrder(14) = cAFrameOrder(14) Xor cAFrameOrder(j)
        Next j
        
        nBgnAdr_l = nBgnAdr_l + 8             '计算下一个地址

        
        St = SendOrder(cAFrameOrder(0), cAFrameAck(0), 1000)
        Sleep 100                              '挂起100毫秒
        
        If St = 0 Then                         '判断发送数据是否正确
              If cAFrameAck(1) = &HA0 Then
                  WriteE2PRom = 0
              Else
                  St = ErrManage(cAFrameAck(2), cAFrameAck(3), cAFrameAck(4)) '取返回错误帧数据
                  WriteE2PRom = 1              '向调用程序返回出错信息
                   Exit Function
              End If
           
        Else
          St = ErrManage(cAFrameAck(2), cAFrameAck(3), cAFrameAck(4)) '取返回错误帧数据
          WriteE2PRom = 1              '向调用程序返回出错信息
          Exit Function
        End If
    Next i
     
     
     
  If nFrameLeave > 0 Then
        cAFrameOrder(0) = &H12                '发最后一帧数据
        cAFrameOrder(1) = &H21
        cAFrameOrder(2) = 4 + nFrameLeave
        cAFrameOrder(3) = DpAdr               'DP-51地址
        cAFrameOrder(4) = nBgnAdr_l           '取发送地址
        cAFrameOrder(5) = nBgnAdr_h
        
        For j = 1 To nFrameLeave              '取发送数据
           cAFrameOrder(5 + j) = Asc(Mid(WriteDate, nFrameNum * 8 + j, 1))
        Next j
        
           cAFrameOrder(nFrameLeave + 6) = 0   '计算校验和
        For j = 0 To nFrameLeave + 5
          cAFrameOrder(nFrameLeave + 6) = cAFrameOrder(nFrameLeave + 6) Xor cAFrameOrder(j)
        Next j
        
        
        St = SendOrder(cAFrameOrder(0), cAFrameAck(0), 1000)
        Sleep 100                              '挂起100毫秒
        
        If St = 0 Then                         '判断发送数据是否正确
           If cAFrameAck(1) = &HA0 Then
                   WriteE2PRom = 0
           Else
                  St = ErrManage(cAFrameAck(2), cAFrameAck(3), cAFrameAck(4)) '取返回错误帧数据
                  WriteE2PRom = 1              '向调用程序返回出错信息
                   Exit Function
           End If
        Else
          St = ErrManage(cAFrameAck(2), cAFrameAck(3), cAFrameAck(4)) '取返回错误帧数据
          WriteE2PRom = 1              '向调用程序返回出错信息
          Exit Function
        End If
 End If
 
End Function
        '------------------------------------------------------------
        '说明:  十六进制字符转为十进制值
        '参数:  HChar 十六进制字符(两位)
        '
        '返回:  返回十进制值
        '------------------------------------------------------------
Function HtoD(ByVal HChar As String)
    Dim Ch1 As Long
    Dim Ch2 As Long
    
    Ch1 = Asc(Left$(HChar, 1))
    Ch2 = Asc(Right$(HChar, 1))
    Select Case Ch1
       Case 48 To 57
         Ch1 = Ch1 - 48
       Case 65 To 70
          Ch1 = Ch1 - 55
       Case 97 To 102
          Ch1 = Ch1 - 87
   End Select
   
    Select Case Ch2
       Case 48 To 57
         Ch2 = Ch2 - 48
       Case 65 To 70
          Ch2 = Ch2 - 55
       Case 97 To 102
          Ch2 = Ch2 - 87
   End Select
   Ch1 = Ch1 * 16 + Ch2
   HtoD = Ch1
End Function


        '------------------------------------------------------------
        '说明:  把字符串转为十六进制显示
        '参数:  Str字符串
        '
        '返回:  十六进制的字符串
        '------------------------------------------------------------
Function StoH(ByVal Str As String)
    Dim i As Integer
    Dim StrTem As String
    Dim StrTem2 As String
    
    If Len(Str) > 0 Then
     For i = 1 To Len(Str)
       StrTem2 = ""
       StrTem2 = Hex(Asc(Mid(Str, i, 1)))
       If Len(StrTem2) = 1 Then
          StrTem2 = "0" + StrTem2
       End If
       StrTem = StrTem + StrTem2 + " "
     Next i
       StoH = StrTem
    End If
End Function
        '------------------------------------------------------------
        '说明:  把字符串转为十六进制显示
        '参数:  Str十六进制字符
        '
        '返回:  字符串
        '------------------------------------------------------------
Function HtoS(ByVal Str As String)
    Dim i As Integer
    Dim StrTem As String
    Dim StrTem2 As String
    
    If Len(Trim(Str)) > 0 Then
     For i = 1 To Len(Trim(Str))
        If Asc(Mid(Trim(Str), i, 1)) <> 32 Then            '不为空格时
              StrTem2 = Mid(Trim(Str), i, 1)
              i = i + 1                                    '指向下一个
            If i <= Len(Trim(Str)) Then
              If Asc(Mid(Trim(Str), i, 1)) <> 32 Then
                 StrTem2 = StrTem2 + Mid(Trim(Str), i, 1)
              End If
            End If
            If Len(StrTem2) = 1 Then
              StrTem2 = "0" + StrTem2
            End If
              StrTem = StrTem + Chr(HtoD(StrTem2))
              StrTem2 = ""
        End If
     Next i
       HtoS = StrTem
    End If
End Function
        '------------------------------------------------------------
        '说明:  错误处理
        '参数:  Par1  为返回帧的cAFrameAck(2)、Par1  为返回帧的cAFrameAck(3)
        '       Par1  为返回帧的cAFrameAck(4)
        '返回:  无
        '------------------------------------------------------------
Function ErrManage(ByVal par1 As Byte, ByVal par2 As Byte, ByVal par3 As Byte)

   
   Select Case par1
          Case 0                                        '超时操作
                MsgBox "操作超时！", vbInformation, "提示"
                Exit Function
          Case 2                                        '读数据操作
            If par2 = 0 Then
                MsgBox "命令或校验出错！", vbInformation, "提示"
                Exit Function
            End If
            
            If par2 = 1 Then
                MsgBox "读数据出错！", vbInformation, "提示"
                Exit Function
            Else
                MsgBox "其它未定义出错！", vbInformation, "提示"
                Exit Function
            End If
          
          Case 3                                        '写数据操作
                MsgBox "写E2PROM出错，出错地址:" & Hex(par3) & ":" & Hex(par2) & "H", vbInformation, "提示"
                Exit Function
            
          Case Else                                     '其它出错
                MsgBox "其它未定义出错！", vbInformation, "提示"
                Exit Function
   End Select
   
End Function