mcomsend.bas

RS485文件传送程序

Attribute VB_Name = "mComSend"
Option Explicit
Public mTools As New cSundries
Public mMath As New cExpressions

Const BlockSize As Long = 1000

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Const SendCMD_Host As String = "Host"
Public Const SendCMD_Sub As String = "Sub"

Public Const SendCMD_Data As String = "Data"
Public Const SendCMD_Over As String = "Over"

Public Const SendCMD_SubOk As String = "Ok"
Public Const SendCMD_SubNg As String = "Ng"
Public Const SendCMD_SubReSend As String = "Re"


Public Const SendCMD_SubReLen As Integer = 2

Public Const SendCMD_HostCmdLen As Integer = 4
Public Const SendCMD_HostBlockCountLen As Integer = 4
Public Const SendCMD_HostDataCRCLen As Integer = 4


Public Const AddressStrLen As Integer = 3
Public Const FileNameStrLen As Integer = 21

Public ReSendCount As Integer
Public Const ReSendMax As Integer = 5



Private FileNo As Integer
Private FileName As String
Private BlockCount As Long
Private BlockToTal As Long
Public ComSendErr As String




Enum Sub_State
    OK = 0
    NG
    RE
    TimeOut
    CmdErr
    AddrErr
    Over
End Enum



Public Function SendFile(ByVal vPort As Long, ByVal vBaud As Long, ByVal vPortSetting As Long, ByVal vAddress As Long, ByVal vFullFileName As String) As Boolean


    Dim oldtime As Long
    Dim newtime As Long
    Dim senddata, Buffer As String
    Dim dvalue As Single
    Dim ReturnStr As String * 256
    Dim Addr As Integer
    Dim aa As Integer
    Dim i As Integer
    Dim ll As Integer
    Dim FlagTime As Boolean
    Dim FlagEof As Boolean
    Dim kkk As Long
    Dim ReadByte As Byte
    Dim SubTakeState As Integer
    Dim SendFlag As Boolean
    
    Dim SendDataVarr() As Integer
    Dim mCRC_Hi As Integer
    Dim mCRC_Lo As Integer
    
    SendFile = False
    
    
    FileName = mTools.GetAfileName(vFullFileName)
    
    If Len(Trim(FileName)) >= FileNameStrLen Then
        ComSendErr = "文件名太长！"
        Exit Function
    End If
    
    
    
    If Dir(vFullFileName) = "" Then
        ComSendErr = "文件没有找到！"
        Exit Function
    End If
    
    
    If FileSystem.FileLen(vFullFileName) <= 0 Then
    
        ComSendErr = "不能传送空文件！"
        Exit Function
    
    End If
    
    
    
    FileNo = FreeFile()
    
    
    Open vFullFileName For Binary Lock Read As #FileNo
    
    kkk = sio_flush(vPort, 2) '清缓存区，KKK= -1 端口未打开
    
    If kkk = 0 Then
        GoTo PortIsOpen
    End If
    
    If sio_open(vPort) <> SIO_OK Then
        ComSendErr = "端口打开失败！"
        Exit Function
    End If
    
    '确定波特率
    If sio_ioctl(vPort, vBaud, vPortSetting) <> SIO_OK Then
        ComSendErr = "端口设置失败！"
        GoTo Err
    End If
    
PortIsOpen:
    
    
    senddata = SendCMD_Host
    senddata = senddata & Format(Left(CStr(vAddress), AddressStrLen), "000")
    
    senddata = senddata & FileName & Space(FileNameStrLen - Len(FileName))
    
'    senddata = senddata & Chr$(&HD)
    
    
    If CheckSubTake(vPort, senddata, vAddress, 1000) <> OK Then
        GoTo Err
    End If
    
    senddata = ""
    BlockCount = 0
    BlockToTal = 0
    SendFlag = False
    ReDim SendDataVarr(0) As Integer
    Seek #FileNo, 1
    
    Do
    
        DoEvents
        BlockCount = BlockCount + 1
        Get #FileNo, (BlockToTal * BlockSize + BlockCount), ReadByte
        senddata = senddata & IIf(Len(Hex(ReadByte)) = 1, "0" & Hex(ReadByte), Hex(ReadByte))
        ReDim Preserve SendDataVarr(BlockCount - 1) As Integer
        SendDataVarr(BlockCount - 1) = ReadByte
        
        
        If (EOF(FileNo) = True) Then
            Call mMath.CheckSum_CRC_TwoByte(SendDataVarr, mCRC_Hi, mCRC_Lo)
            If BlockCount = BlockSize Then
                senddata = SendCMD_Over & Format(Left(CStr(vAddress), AddressStrLen), "000") & Format(BlockCount, "0000") & senddata & IIf(Len(Hex(mCRC_Hi)) = 1, "0" & Hex(mCRC_Hi), Hex(mCRC_Hi)) & IIf(Len(Hex(mCRC_Lo)) = 1, "0" & Hex(mCRC_Lo), Hex(mCRC_Lo))
            Else
                senddata = SendCMD_Over & Format(Left(CStr(vAddress), AddressStrLen), "000") & Format(BlockCount, "0000") & senddata & Space((BlockSize * 2) - (BlockCount * 2)) & IIf(Len(Hex(mCRC_Hi)) = 1, "0" & Hex(mCRC_Hi), Hex(mCRC_Hi)) & IIf(Len(Hex(mCRC_Lo)) = 1, "0" & Hex(mCRC_Lo), Hex(mCRC_Lo))
            End If
            SendFlag = True
            
        ElseIf BlockCount = BlockSize Then
            Call mMath.CheckSum_CRC_TwoByte(SendDataVarr, mCRC_Hi, mCRC_Lo)
            senddata = SendCMD_Data & Format(Left(CStr(vAddress), AddressStrLen), "000") & Format(BlockCount, "0000") & senddata & IIf(Len(Hex(mCRC_Hi)) = 1, "0" & Hex(mCRC_Hi), Hex(mCRC_Hi)) & IIf(Len(Hex(mCRC_Lo)) = 1, "0" & Hex(mCRC_Lo), Hex(mCRC_Lo))
            SendFlag = True
        End If
        
        ReSendCount = 0
        Do While (SendFlag = True)
            
            DoEvents
            SubTakeState = CheckSubTake(vPort, senddata, vAddress, 2000)
            If SubTakeState <> Sub_State.OK Then
                If SubTakeState = Sub_State.RE Then
                    
                    If ReSendCount >= ReSendMax Then
                        Exit Do
                    End If
                    ReSendCount = ReSendCount + 1
                Else
                    GoTo Err
                End If
        
            Else
                Exit Do
            End If
        Loop
        
        If ReSendCount >= ReSendMax Then
            GoTo Err
        Else
            If EOF(FileNo) = True Then
                Form1.Label1.Caption = BlockCount + Val(Form1.Label1.Caption)
                Exit Do
            ElseIf SendFlag = True Then
                Form1.Label1.Caption = BlockCount + Val(Form1.Label1.Caption)
                senddata = ""
                BlockCount = 0
                SendFlag = False
                ReDim SendDataVarr(0) As Integer
                BlockToTal = BlockToTal + 1
            End If
        End If


    Loop
    
    
    SendFile = True
    Close #FileNo
    Exit Function
Err:
    
    
    Close #FileNo

End Function

Public Function CheckSubTake(ByVal vPort As Long, ByVal vSendData As String, ByVal vAddress As Integer, ByVal vTimeOut As Long) As Sub_State


    Dim oldtime As Long
    Dim newtime As Long
    Dim senddata, Buffer As String
    Dim aa As Integer
    Dim i As Integer
    Dim ll As Integer
    Dim FlagTime As Boolean
    Dim FlagEof As Boolean
    
    senddata = vSendData
    

    aa = sio_flush(vPort, 2)
    
    oldtime = timeGetTime
    
    '把命令发送
    aa = sio_write(vPort, senddata, Len(senddata))
    
'    MsgBox timeGetTime - oldtime
    
    '查看缓冲区
    oldtime = timeGetTime
    FlagTime = False
    FlagEof = False
    Do
        DoEvents
        aa = sio_iqueue(vPort)
        newtime = timeGetTime
        If (newtime < oldtime) Then
            oldtime = 0
        Else
            If (newtime - oldtime) > vTimeOut Then
                FlagTime = True
            End If
        End If
    Loop While (aa <> (Len(SendCMD_Sub) + AddressStrLen + SendCMD_SubReLen)) And (FlagTime = False)
    
    If FlagTime = True Then
        '超时
        ComSendErr = "下位机应答超时！ "
        CheckSubTake = TimeOut
        GoTo Err
        
    End If
    Buffer = Space(aa)
    Call sio_read(vPort, Buffer, aa)
    
    
    If (UCase(Mid(Buffer, 1, Len(SendCMD_Sub))) <> UCase(SendCMD_Sub)) Then
        ComSendErr = "下位机应答回应码错误！ "
        CheckSubTake = CmdErr
        GoTo Err
    End If
    
    
    
    If (Val(Mid(Buffer, 1 + Len(SendCMD_Sub), AddressStrLen)) <> vAddress) Then
        ComSendErr = "下位机应答地址错误！ "
        CheckSubTake = AddrErr
        GoTo Err
    End If
    
    If (UCase(Mid(Buffer, 1 + Len(SendCMD_Sub) + AddressStrLen, SendCMD_SubReLen)) = UCase(SendCMD_SubNg)) Then
        ComSendErr = "下位机有错误发生！ "
        CheckSubTake = NG
        GoTo Err
    End If
    
    If (UCase(Mid(Buffer, 1 + Len(SendCMD_Sub) + AddressStrLen, SendCMD_SubReLen)) = UCase(SendCMD_SubReSend)) Then
        ComSendErr = "下位机要求重传！ "
        CheckSubTake = RE
        GoTo Err
    End If
    

    CheckSubTake = OK
    Exit Function
Err:
    
    Call sio_flush(vPort, 2)

End Function