frmcollectioncurrent.frm

一个完整的非接触IC卡会员管理系统

            MsgBox "采集数据错误!" + Chr(10) + Chr(13) + "错误ID:" + CStr(ltemp), , "提示"
            Kill sfPath + sfName    '删除建立的文件
            Screen.MousePointer = 0
            ltemp = CloseCom(hCom)
            txtMsg = "采集失败，请重试！"
            Exit Sub
        End If
        
        If Check1 And Option2.Value = True Then '黑名单
            psBlackPathFile = App.Path & "\bakup\dwn\black.blk"
            MakeBlackFile psBlackPathFile
            sfName = App.Path & "\bakup\dwn\black.blk"
            ltemp = DownloadBlacklist(hCom, sfName)
            If ltemp = 0 Then
                txtMsg = "黑名单下载完毕！"
            Else
                txtMsg = "下载黑名单错误！"
            End If
        End If
        
        Screen.MousePointer = 0
        ltemp = CloseCom(hCom)
        txtMsg = "操作完毕！"
    Else
        MsgBox "连接串口错误！", vbCritical, "中芯德立提示信息"
    End If
ElseIf Option1.Value = True Then
    Me.MousePointer = 11
    PB.Value = 10
    txtMsg = "开始采集消费数据包，请等待......"
    txtMsg.Refresh
    cur_tod_snt_path = App.Path & "\bakup\cur\tod\"
    bf_tod_snt_path = App.Path & "\bakup\bf\tod\"
    piRet = WHTOCX21.SetDir28(giCollectPort, mlBaud, "d:\current")
    If piRet < 0 Then
        txtMsg = "采集目录改变失败!"
    Else
        PB.Value = 30
        psFileName = Format(Now, "yyyymmddhhmmss") + "current.dat"
        psPCPathFile = cur_tod_snt_path + psFileName
        psBFPathFile = bf_tod_snt_path + psFileName
        piRet = WHTOCX21.ExFGet(psPCPathFile, "current.dat", giCollectPort, mlBaud, 0)
        If piRet < 0 Then
            txtMsg = "未找到消费数据包!"
            GoTo blk
        End If
        PB.Value = 60
        piRet = WHTOCX21.DeleteExFile(giCollectPort, mlBaud, "current.dat")
        If piRet < 0 Then
            MsgBox "删除Current文件失败！", vbCritical, "中芯德立提示信息"
            Me.MousePointer = 0
            Exit Sub
        End If
        PB.Value = 70
        piRet = WHTOCX21.DeleteExFile(giCollectPort, mlBaud, "current.idx")
        If piRet < 0 Then
            MsgBox "删除Current文件失败！", vbCritical, "中芯德立提示信息"
            Me.MousePointer = 0
            Exit Sub
        End If
        txtMsg = "消费数据包下载完毕!"
        PB.Value = 80
        Remove psPCPathFile
        FileCopy psPCPathFile, psBFPathFile
        Kill psPCPathFile
    End If
    
blk:
    '下载黑名单
    If Check1 Then
    piRet = WHTOCX21.SetDir28(giCollectPort, mlBaud, "d:\blkcard")
        txtMsg = "开始更新黑名单!"
        If piRet < 0 Then
            MsgBox "采集目录改变失败！", vbInformation, "中芯德立提示信息"
            Me.MousePointer = 0
            Exit Sub
        End If
        PB.Value = 80
        'psBlackPathFile = App.Path & "\bakup\dwn\black.dat"
        psBlackPathFile = App.Path & "\bakup\dwn\black.blk"
        MakeBlackFile psBlackPathFile
        piRet = WHTOCX21.ExFPut(psBlackPathFile, "bcardlst.blk", giCollectPort, mlBaud, 0)
        If piRet < 0 Then
            MsgBox "下载黑名单文件失败！", vbInformation, "中芯德立提示信息"
            Me.MousePointer = 0
            Exit Sub
        End If
        txtMsg = "黑名单更新完毕!"
    End If
    If Check2 Then
        txtMsg = "开始校时!"
        SetCollectorDateTime
    End If
    PB.Value = 100
    
    txtMsg = "操作完毕!"
    Me.MousePointer = 0
    'Exit Sub
End If

Exit Sub
E:
    Me.MousePointer = vbDefault
    MsgBox "系统错误:" & Error(err), vbCritical, "操作提示"
End Sub

Private Sub Command2_Click()
Unload Me
End Sub

Private Sub Form_Load()
Combo1.Clear
Combo1.AddItem "串口一"
Combo1.AddItem "串口二"
Combo1.ListIndex = 0
Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2

giCollectPort = 1
mlBaud = 115200
End Sub

'函数功能：红外线采集的一个DAT文件分成多个数据文件
Private Function Remove(psPathFile As String)
Dim pbOut(0 To 31) As Byte
Dim plL As Double
Dim psPath As String
Dim psFile As String
Dim psSubFileName As String
Dim plSubFileLen As Double
Dim psNewFlag As String
plL = 256 '字节进制
psPath = GetPath(psPathFile)
psFile = LCase(Mid(psPathFile, piPosTemp + 1)) '取出psPathFile文件名
Open psPathFile For Binary As #1
Do While Not EOF(1) '分成多个文件
    psSubFileName = ""
    Get #1, , pbOut
    If pbOut(0) * plL + pbOut(1) * plL + pbOut(2) * plL + pbOut(3) * plL = 0 Then Exit Do
    psSubFileName = psSubFileName + hex_to_char(pbOut(), 0, 28)
    If InStr(psFile, "current") <> 0 Then
        psSubFileName = Trim(psSubFileName) + ".sct"
    Else
        psSubFileName = Trim(psSubFileName) + ".sht"
    End If
    plSubFileLen = pbOut(28) + pbOut(29) * plL + pbOut(30) * plL * plL + pbOut(31) * plL * plL * plL
    Open psPath + psSubFileName For Binary As #2
    For i = 1 To plSubFileLen / 32
        Get #1, , pbOut
        Put #2, , pbOut
    Next i
    Close #2
    Get #1, , pbOut
Loop
Close #1
End Function

'取出psPathFile路径
Private Function GetPath(psPathFile As String) As String
Dim piPos As Integer
Dim piPosTemp As Integer
piPos = 1
Do While piPos <> 0
    piPosTemp = piPos
    piPos = InStr(piPos + 1, psPathFile, "\")
Loop
GetPath = Mid(psPathFile, 1, piPosTemp)
End Function

'函数功能：1字节BYTE类型的数转变成可见的字符
Private Function hex_to_char(pbIn() As Byte, piBeginAddr As Integer, piLen As Integer) As String
Dim i As Integer
For i = piBeginAddr To piBeginAddr + piLen - 1
    hex_to_char = hex_to_char + Chr(pbIn(i))
Next i
End Function

'函数功能：长整型数用5个字节存储
Private Function Black_LongToHex(plCardNO As Long, pbOut() As Byte)
Dim plL As Long
plL = 256
'plCardNO = plL * plL * plL * 101 + plL * plL * 198 + plL * 103 + 104
'最大数不能超过2,147,483,647
'最高位不能超过128
'pbOut(4) = 0
pbOut(3) = (plCardNO) \ (plL * plL * plL)
pbOut(2) = (plCardNO Mod (plL * plL * plL)) \ (plL * plL)
pbOut(1) = ((plCardNO Mod (plL * plL * plL)) Mod (plL * plL)) \ (plL)
pbOut(0) = plCardNO Mod 256

''dqyang BCD
'pbOut(0) = "&H" & Mid(Format(plCardNO, "00000000"), 1, 2)
'pbOut(1) = "&H" & Mid(Format(plCardNO, "00000000"), 3, 2)
'pbOut(2) = "&H" & Mid(Format(plCardNO, "00000000"), 5, 2)
'pbOut(3) = "&H" & Mid(Format(plCardNO, "00000000"), 7, 2)
End Function

'函数功能：长整型数用5个字节存储
Private Function Black_Long(plCardNO As Long, pbOut() As Byte)
''Dim plL As Long
''plL = 256
'''plCardNO = plL * plL * plL * 101 + plL * plL * 198 + plL * 103 + 104
'''最大数不能超过2,147,483,647
'''最高位不能超过128
'''pbOut(4) = 0
''pbOut(3) = (plCardNO) \ (plL * plL * plL)
''pbOut(2) = (plCardNO Mod (plL * plL * plL)) \ (plL * plL)
''pbOut(1) = ((plCardNO Mod (plL * plL * plL)) Mod (plL * plL)) \ (plL)
''pbOut(0) = plCardNO Mod 256

'dqyang BCD
pbOut(0) = "&H" & Mid(Format(plCardNO, "00000000"), 1, 2)
pbOut(1) = "&H" & Mid(Format(plCardNO, "00000000"), 3, 2)
pbOut(2) = "&H" & Mid(Format(plCardNO, "00000000"), 5, 2)
pbOut(3) = "&H" & Mid(Format(plCardNO, "00000000"), 7, 2)
End Function
Private Function MakeBlackFile(psPathFile As String) As Boolean
Dim pbOut(3) As Byte
If Dir(psPathFile) <> "" Then Kill psPathFile
Open psPathFile For Binary As #1
Dim rs As New ADODB.Recordset
Set rs = GetRecordset(maSys_db, "select distinct IC卡号 from 黑名单 where 状态='挂失' order by IC卡号")
If Not (rs.EOF And rs.BOF) Then
    Black_LongToHex rs.RecordCount, pbOut
    'Black_LongToHex rs.RecordCount, pbOut
    rs.MoveFirst
    Put #1, , pbOut
Else
    Put #1, , pbOut
End If
Do While Not rs.EOF
    Black_Long rs!IC卡号, pbOut
    Put #1, , pbOut
    rs.MoveNext
Loop
Close #1
End Function

Private Function SetCollectorDateTime() As Boolean
Dim result As Integer
Dim cTimer(0 To 6) As Byte
Dim cTemp(0 To 15) As Byte
Dim cTemp1() As Byte
Dim TimerStr As String
Dim i As Integer
Dim j As Integer
        
cTimer(0) = 0     'month
cTimer(1) = 0     'date
cTimer(2) = 0     'year low
cTimer(3) = 0     'year high
cTimer(4) = 0     'hours
cTimer(5) = 0     'minute
cTimer(6) = 0     'second

'calculate year month date
j = 0
cTemp1 = StrConv(Format(Now, "yyyy/mm/dd") + " ", vbFromUnicode)
For i = LBound(cTemp1) To UBound(cTemp1)
   If cTemp1(i) >= 48 And cTemp1(i) <= 57 Then
       cTemp(j) = cTemp1(i)
       j = j + 1
     If j = 4 Then
       cTimer(2) = ((cTemp(0) - 48) * 1000 + (cTemp(1) - 48) * 100 + (cTemp(2) - 48) * 10 + (cTemp(3) - 48)) Mod 256
       cTimer(3) = (((cTemp(0) - 48) * 1000 + (cTemp(1) - 48) * 100 + (cTemp(2) - 48) * 10 + (cTemp(3) - 48)) - cTimer(2)) / 256
     End If
     If j = 5 Then
        If cTemp1(i + 1) >= 48 And cTemp1(i + 1) <= 57 Then
           cTimer(0) = (cTemp(4) - 48) * 10 + cTemp1(i + 1) - 48
           i = i + 1
        Else
           cTimer(0) = (cTemp(4) - 48)
        End If
     End If
     If j = 6 Then
        If cTemp1(i + 1) >= 48 And cTemp1(i + 1) <= 57 Then
           cTimer(1) = (cTemp(5) - 48) * 10 + cTemp1(i + 1) - 48
        Else
           cTimer(1) = (cTemp(5) - 48)
        End If
     End If
   End If
Next

'calculate hours minute
j = 0
cTemp1 = StrConv(Format(Now, "hh/mm/ss") + " ", vbFromUnicode)
For i = LBound(cTemp1) To UBound(cTemp1)
  If cTemp1(i) >= 48 And cTemp1(i) <= 57 Then
       cTemp(j) = cTemp1(i)
       j = j + 1
    If j = 1 Then
        If cTemp1(i + 1) >= 48 And cTemp1(i + 1) <= 57 Then
           cTimer(4) = (cTemp(0) - 48) * 10 + cTemp1(i + 1) - 48
           i = i + 1
        Else
           cTimer(4) = (cTemp(0) - 48)
        End If
    End If
    If j = 2 Then
        If cTemp1(i + 1) >= 48 And cTemp1(i + 1) <= 57 Then
           cTimer(5) = (cTemp(1) - 48) * 10 + cTemp1(i + 1) - 48
           i = i + 1
        Else
           cTimer(5) = (cTemp(1) - 48)
        End If
    End If
    If j = 3 Then
        If cTemp1(i + 1) >= 48 And cTemp1(i + 1) <= 57 Then
           cTimer(6) = (cTemp(2) - 48) * 10 + cTemp1(i + 1) - 48
        Else
           cTimer(6) = (cTemp(2) - 48)
        End If
    End If
 End If
Next

TimerStr = cTimer

result = WHTOCX21.SetHTNewTime(giCollectPort, mlBaud, TimerStr)
If result < 0 Then
    MsgBox "校对采集器", vbInformation, "中芯德立提示信息"
    Exit Function
End If
SetCollectorDateTime = True
End Function