comdriver.bas

VB代码

Attribute VB_Name = "ComDriver"
'串口通讯的底层驱动程序
Option Explicit
'全局常量定义区
'Public Const c_CurrentComBitRate = 115200
Public Const c_CurrentComBitRate = 57600
'Public Const c_CurrentComBitRate = 56000
'Public Const c_CurrentComBitRate = 38400
'Public Const c_CurrentComBitRate = 19200
'模块常量定义区
'Const c_DataReceiveTimeOutCount = 3   'unit is second
Const c_DataReceiveTimeOutCount = 6  'unit is second

'Const c_DataReceiveTimeOutCount = 10   'unit is second
Const c_MaxRepeatCount = 3   '最大重发次数

'全局变量定义区
Public bComInitStatus   As Boolean '串口初始化成功的标志位

Public bComReceiveTimeOut As Boolean
Public ucCurrentComPortNumber  As Byte


'模块变量定义区

Public Function InitializeComPort(BitRate As Long, PortNumber As Byte) As Boolean
'Initializes the selected Com Port.
'All settings except BitRate are set explicitly in this routine.
'Some properties show alternate settings commented out.
    Dim sComSettingsString As String
    Dim bComPortOldOpenStatus As Boolean

    Dim bInitResult As Boolean
    
    
    bInitResult = True
    bComPortOldOpenStatus = False
    If FrmMain.MSComm1.PortOpen = True Then
    
        FrmMain.MSComm1.PortOpen = False
        bComPortOldOpenStatus = True
        
    End If

    On Error GoTo InitComPortError

    FrmMain.MSComm1.CommPort = PortNumber
'Use BitRate, no parity, 8 data, and 1 stop bit:
    sComSettingsString = CStr(BitRate) & ",N,8,1"
    FrmMain.MSComm1.Settings = sComSettingsString

'Properties relating to receiving:
'Read entire buffer on Input:
   FrmMain.MSComm1.InputLen = 0
'Read one byte at a time on Input:
'MSComm1.InputLen = 1

    FrmMain.MSComm1.InBufferSize = 1024

'Generate no OnComm event on received data:
    FrmMain.MSComm1.RThreshold = 0
'Generate an OnComm event on each character received:
'MSComm1.RThreshold = 1

'The Input property stores binary data:
    'FrmMain.MSComm1.InputMode = comInputModeBinary
'The Input property stores data as text:
    FrmMain.MSComm1.InputMode = comInputModeText    'for Program P89C61X2 is Text Mode and Communication with ASCII code

'Disable parity replacement"
'MSComm1.ParityReplace = ""

'Properties related to transmitting:

    FrmMain.MSComm1.OutBufferSize = 1024

'Generate no transmit OnComm event:
    FrmMain.MSComm1.SThreshold = 0
'Generate an OnComm event when the transmit buffer
'has SThreshold bytes or fewer:
'MSComm1.SThreshold = 512

'Handshaking options:
    FrmMain.MSComm1.Handshaking = comNone
'MSComm1.Handshaking = comXOnXoff
'MSComm1.Handshaking = comRTS
'MSComm1.Handshaking = comRTSXOnXOff

'Open the port.
    On Error GoTo InitComPortError
    'on err resume next
    FrmMain.MSComm1.PortOpen = True
    GoTo InitFuncEnd
    
InitComPortError:
    Select Case Err.Number
        Case 8002
            MsgBox ("无效的串口号，本机硬件不存在此串口" & Chr(&HD) & Chr(&HA) & "请打开Windows的控制面板，检查机器配置的串口状况")
        Case 8005
            MsgBox ("该串口已以被占用，请选择其它串口")
    End Select
    bInitResult = False
 
InitFuncEnd:
    If ((bInitResult = False) And (bComPortOldOpenStatus)) Then
        FrmMain.MSComm1.CommPort = ucCurrentComPortNumber
        FrmMain.MSComm1.PortOpen = True

    End If
'Return success or failure
    InitializeComPort = bInitResult
End Function

Public Function SetComPortNumber(ByVal ucSelectComPortNumber As Byte) As Boolean
    Dim bResult As Boolean
    
    bResult = InitializeComPort(c_CurrentComBitRate, ucSelectComPortNumber)
    
    If (bResult) Then
        ucCurrentComPortNumber = ucSelectComPortNumber
        FrmMain.lblPrintPortNo.Caption = "Com" & CStr(ucCurrentComPortNumber)
        FrmMain.lblPrintPortNo.Refresh
        
        Current_PGMSysInformation.PGMSysInfo_CommPortNumber = ucSelectComPortNumber
    End If
    
    bComInitStatus = bResult
    SetComPortNumber = bResult
End Function



Public Function ComSendData() As Boolean
    Dim ucCount As Byte
    Dim bReturnValue As Boolean
    
    
    'ReDim ucSendTempDataBuff(ucComSendDataLength) As Byte     'BUG add a Char in the end
    'ReDim ucSendTempDataBuff(ucComSendDataLength - 1) As Byte
    
    bReturnValue = True
    If (Not bComInitStatus) Then
        bReturnValue = False
        FrmMain.LblOperationInfoDisp.Caption = "串口未初始化,通讯失败!"
        GoTo ComSNDPackageEnd
    End If

    'For ucCount = 0 To ucComSendDataLength - 1 Step 1
    '    ucSendTempDataBuff(ucCount) = ucComSendDataBuff(ucCount)
    'Next ucCount

    FrmMain.MSComm1.Output = sComSendDataBuff
    
ComSNDPackageEnd:
    ComSendData = bReturnValue
End Function
Public Sub ClearComInputBuff()
    'Dim ucTempBuff() As Byte
    Dim sTempReadData As String
    Dim bReturnValue As Boolean

    bReturnValue = True
    If (Not bComInitStatus) Then
        bReturnValue = False
        FrmMain.LblOperationInfoDisp.Caption = "串口未初始化,通讯失败!"
        GoTo ComClearInputBuffEnd
    End If

    FrmMain.MSComm1.InputLen = 0
    sTempReadData = FrmMain.MSComm1.Input
    
ComClearInputBuffEnd:
    
End Sub
Public Function CheckReceivePackVolid() As Boolean
    Dim bResultValue As Boolean
    
 '   bResultValue = False
 '   If ((ucReceiveDataBuff(0) = &H4F) And (ucReceiveDataBuff(1) = &H4B)) Then
 '       bResultValue = True
 '   End If
    
 '   If ((ucReceiveDataBuff(0) = &H45) And (ucReceiveDataBuff(1) = &H52)) Then
 '       bResultValue = True
 '   End If
    
 '   If (bResultValue) Then
 '       If (bSendCmd_SelectProgramDeviceIDNuberFlag) Then
 '           If (ucReceiveDataBuff(2) = ucCurrentDeviceIDEnCode) Then
 '               If (ReceiveDataBuffCheckSum(ucReceiveDataLength - 1) <> ucReceiveDataBuff(ucReceiveDataLength - 1)) Then
 '                   bResultValue = False
 '                   MsgBox "对接收到的数据进行合法性检查，发现数据校验错误", vbCritical, "请注意"
 '               End If
 '           Else
 '               bResultValue = False
 '               MsgBox "数据包中当前编程器件的特征编码不一致，请重新执行操作", vbCritical, "请注意"
 '           End If
 '       Else
 '           If (ReceiveDataBuffCheckSum(ucReceiveDataLength - 1) <> ucReceiveDataBuff(ucReceiveDataLength - 1)) Then
 '               bResultValue = False
 '               MsgBox "对接收到的数据进行合法性检查，发现数据校验错误", vbCritical, "请注意"
 '           End If
 '       End If
 '   Else
 '       MsgBox "对接收到的数据进行合法性检查，发现数据帧头错误", vbCritical, "请注意"
 '   End If
    bResultValue = True
    CheckReceivePackVolid = bResultValue
End Function

'不带重发最后数据功能的数据接收函数
'Public Function ComReceiveData(ByVal ucDesireReturnDataLength) As Boolean
'    Dim ucGetDataLengthCount As Byte
   ' Dim ucBasicInfoDataLength As Byte
'    Dim ucParameterInfoDataLength As Byte
'
'    Dim bReturnValue As Boolean
'    Dim ucTempDataBuff() As Byte
'    Dim ucCount As Byte
'
'    bReturnValue = True
'
'    ucParameterInfoDataLength = ucDesireReturnDataLength - 6
    
'    FrmMain.MSComm1.InputLen = 6
'    bComReceiveTimeOut = False
'
'    FrmMain.TmrComReceive.Interval = c_DataReceiveTimeOutCount * 1000
'    FrmMain.TmrComReceive.Enabled = True
'
'    Do
'        DoEvents
'        ucGetDataLengthCount = FrmMain.MSComm1.InBufferCount
'
'    Loop Until (ucGetDataLengthCount >= 6) Or (bComReceiveTimeOut = True)
'
'    If (bComReceiveTimeOut) Then
'        bReturnValue = False
'       MsgBox "发送命令到设备后，返回帧头信息出现超时错误", vbCritical + vbOKOnly, "请检查"
'    Else
'        FrmMain.TmrComReceive.Enabled = False
'
'        ucReceiveDataLength = 6
'        ReDim ucTempDataBuff(6) As Byte
'
'        ucTempDataBuff = FrmMain.MSComm1.Input
'        For ucCount = 0 To 5 Step 1
'            ucReceiveDataBuff(ucCount) = ucTempDataBuff(ucCount)
'        Next ucCount
'
'        If (ucParameterInfoDataLength > 0) Then
'            Call Delay(50)
'            'FrmMain.MSComm1.InputLen = ucParameterInfoDataLength
'            FrmMain.MSComm1.InputLen = 0
'
'            FrmMain.TmrComReceive.Interval = 5000
'            bComReceiveTimeOut = False
'            FrmMain.TmrComReceive.Enabled = True
'
'            Do
'                DoEvents
'                ucGetDataLengthCount = FrmMain.MSComm1.InBufferCount
'            Loop Until (ucGetDataLengthCount >= ucParameterInfoDataLength) Or (bComReceiveTimeOut = True)
'
'            If (bComReceiveTimeOut) Then
'                bReturnValue = False
'                MsgBox "发送命令到设备后，返回数据体信息出现超时错误", vbCritical + vbOKOnly, "请检查"
'            Else
'                FrmMain.TmrComReceive.Enabled = False
'
'                ucReceiveDataLength = ucReceiveDataLength + ucParameterInfoDataLength
'                ReDim ucTempDataBuff(ucParameterInfoDataLength) As Byte
'
'                ucTempDataBuff = FrmMain.MSComm1.Input
'                For ucCount = 0 To ucParameterInfoDataLength - 1 Step 1
'                    ucReceiveDataBuff(ucCount + 6) = ucTempDataBuff(ucCount)
'                Next ucCount
'
'              End If
'        End If
'        bReturnValue = CheckReceivePackVolid()'
'
'    End If
'
'    ComReceiveData = bReturnValue
'End Function

'配置重发最后数据功能的数据接收函数
'返回接收数据的长度
Public Function ComReadData(ByVal ucDesireReturnDataLength As Byte) As Boolean
    Dim ucGetDataLengthCount As Byte
    Dim ucBasicInfoDataLength As Byte
    Dim ucParameterInfoDataLength As Byte

    Dim bReturnValue As Boolean
    
    Dim ucTempDataBuff() As Byte
    Dim ucCount As Byte

    bReturnValue = True

    FrmMain.MSComm1.InputLen = ucDesireReturnDataLength
    
    bComReceiveTimeOut = False
    FrmMain.TmrComReceive.Interval = c_DataReceiveTimeOutCount * 1000
    FrmMain.TmrComReceive.Enabled = True

    Do
        DoEvents
        ucGetDataLengthCount = FrmMain.MSComm1.InBufferCount

    Loop Until (ucGetDataLengthCount >= ucDesireReturnDataLength) Or (bComReceiveTimeOut = True)

    If (bComReceiveTimeOut) Then
        ucReceiveDataLength = ucGetDataLengthCount
        bReturnValue = False
       MsgBox "发送命令到设备后，返回帧头信息出现超时错误", vbCritical + vbOKOnly, "请检查"
    Else
        FrmMain.TmrComReceive.Enabled = False

        ucReceiveDataLength = ucDesireReturnDataLength
        sComReceiveDataBuff = FrmMain.MSComm1.Input
        bReturnValue = True
    End If

    ComReadData = bReturnValue
End Function
'Function ComReadUsefulData(ByVal ucDesireReturnDataLength As Byte) As Byte
Function ComReadUsefulData(ByVal ucDesireReturnDataLength As Byte) As Boolean
    
    Dim bReturnValue As Boolean

    bReturnValue = ComReadData(ucDesireReturnDataLength)
    
    ComReadUsefulData = bReturnValue
    
End Function

Public Function ComReceivePackage(ByVal ucDesireReturnDataLength As Byte) As Boolean

    Dim bReturnValue As Boolean
    Dim bGetValidDataFlag As Boolean
    
    Dim ucCount As Byte

    bReturnValue = True

    If (Not bComInitStatus) Then
        bReturnValue = False
        FrmMain.LblOperationInfoDisp.Caption = "串口未初始化,通讯失败!"
        GoTo ComRCVPackageEnd
    End If
    
    If (ComReadUsefulData(ucDesireReturnDataLength)) Then
    
        bReturnValue = CheckReceivePackVolid() '
        
    Else
        Call MsgBox("发送指令到设备后，无应答或应答数据长度不够")
        
    End If
    
ComRCVPackageEnd:
    ComReceivePackage = bReturnValue
End Function