clsbarcode.cls

本系统可用于医院和专业体检中心的健康体检管理

            Printer.Line (sngPosX, sngY)-Step(sngScaleX - 1, sngHeight), vbBlack, BF
        End If
        sngPosX = sngX + (K * sngScaleX)
    Next K
    
    If blnPrintText = True Then
        'Draw strEAN Code text
        strBarCode = Left(strBarCode, Len(strBarCode) - 1) '去掉最后一位校验码
    
        '设置条码编号的字体信息
        With Printer
            '设置字体
            .FontName = mfonCodeNumber.FontName
            .FontSize = mfonCodeNumber.FontSize
            .FontBold = mfonCodeNumber.FontBold
            .FontItalic = mfonCodeNumber.FontItalic
            .FontUnderline = mfonCodeNumber.FontUnderline
        
            '********************************************************************
            '是否在条形码下方打印人工识别字符
            If mcorCodeNumber.IsUse Then
                .CurrentX = mcorCodeNumber.x
                .CurrentY = mcorCodeNumber.y
                Printer.Print strBarCode
            End If
            '********************************************************************
        End With
    End If
    
    GoTo ExitLab
ExitLab:
    '
End Sub

'生成校验码
Public Function CheckDigit_EAN(ByVal strEANCode As String) As String
    Dim Nums(12), i, K As Integer
'    Dim ck As String
    Dim realCK As String

    'If not is numeric EAN code Exit
    If Not IsNumeric(strEANCode) Then
        MsgBox "EAN码仅支持数字，请不要输入其他字符！", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    'check byte
'    ck = Right(strEANCode, 1)
    
    strEANCode = strEANCode & "W"
    i = 1
    If Len(strEANCode) = 8 Then
        'Check Digit For EAN 8
        Do While i < 8
            Nums(i) = CInt(Mid(strEANCode, i, 1))
            i = i + 1
        Loop

        K = (Nums(7) * 3)
        K = K + (Nums(6) * 1)
        K = K + (Nums(5) * 3)
        K = K + (Nums(4) * 1)
        K = K + (Nums(3) * 3)
        K = K + (Nums(2) * 1)
        K = K + (Nums(1) * 3)
        K = K Mod 10
        K = 10 - K

        realCK = CStr(K)

    ElseIf Len(strEANCode) = 13 Then
        'Check Digit For EAN 13
        Do While i < 13
            Nums(i) = CInt(Mid(strEANCode, i, 1))
            i = i + 1
        Loop

        K = (Nums(12) * 3)
        K = K + (Nums(11) * 1)
        K = K + (Nums(10) * 3)
        K = K + (Nums(9) * 1)
        K = K + (Nums(8) * 3)
        K = K + (Nums(7) * 1)
        K = K + (Nums(6) * 3)
        K = K + (Nums(5) * 1)
        K = K + (Nums(4) * 3)
        K = K + (Nums(3) * 1)
        K = K + (Nums(2) * 3)
        K = K + (Nums(1) * 1)
        K = K Mod 10
        K = 10 - K

        realCK = CStr(K)
    Else
        'Nothing EAN 8 or EAN 13 Code
        MsgBox "EAN码仅支持长度为7或者12的数字，请重新设置长度！", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    '防止出现10校验码
    If Len(realCK) > 1 Then realCK = Right(realCK, 1)
    
    '返回
    CheckDigit_EAN = Left(strEANCode, Len(strEANCode) - 1) & realCK
    
    GoTo ExitLab
ExitLab:
    '
End Function

'生成EAN码
Public Function EAN2Bin(ByVal strEANCode As String) As String
    Dim K As Integer
    Dim strAux As String
    Dim strExit As String
    Dim strCode As String

    strEANCode = Trim(strEANCode)
    strAux = strEANCode

    'Check EAN code (EAN8 or EAN13)
    If (Len(strAux) <> 13) And (Len(strAux) <> 8) Then
        Call Err.Raise(5, "EAN2Bin", "Invalid EAN Code!..")
    End If

    'Check numbers only
    For K = 1 To Len(strEANCode)
        Select Case Mid(strAux, K, 1)
            Case Is < "0", Is > "9"
                Call Err.Raise(5, "EAN2Bin", "Please don't use any number characters!..")
        End Select
    Next

    'For EAN13
    If (Len(strAux) = 13) Then

        strAux = Mid(strAux, 2)

        Select Case CInt(Left(strEANCode, 1))
            Case 0
                strCode = "000000"
            Case 1
                strCode = "001011"
            Case 2
                strCode = "001101"
            Case 3
                strCode = "001110"
            Case 4
                strCode = "010011"
            Case 5
                strCode = "011001"
            Case 6
                strCode = "011100"
            Case 7
                strCode = "010101"
            Case 8
                strCode = "010110"
            Case 9
                strCode = "011010"
        End Select
    Else 'For EAN8
        strCode = "0000"
    End If

    strExit = "000101"

    For K = 1 To Len(strAux) \ 2
        Select Case CInt(Mid(strAux, K, 1))
            Case 0
                strExit = strExit & IIf(Mid(strCode, K, 1) = "0", "0001101", "0100111")
            Case 1
                strExit = strExit & IIf(Mid(strCode, K, 1) = "0", "0011001", "0110011")
            Case 2
                strExit = strExit & IIf(Mid(strCode, K, 1) = "0", "0010011", "0011011")
            Case 3
                strExit = strExit & IIf(Mid(strCode, K, 1) = "0", "0111101", "0100001")
            Case 4
                strExit = strExit & IIf(Mid(strCode, K, 1) = "0", "0100011", "0011101")
            Case 5
                strExit = strExit & IIf(Mid(strCode, K, 1) = "0", "0110001", "0111001")
            Case 6
                strExit = strExit & IIf(Mid(strCode, K, 1) = "0", "0101111", "0000101")
            Case 7
                strExit = strExit & IIf(Mid(strCode, K, 1) = "0", "0111011", "0010001")
            Case 8
                strExit = strExit & IIf(Mid(strCode, K, 1) = "0", "0110111", "0001001")
            Case 9
                strExit = strExit & IIf(Mid(strCode, K, 1) = "0", "0001011", "0010111")
        End Select
    Next K

    strExit = strExit & "01010"

    For K = Len(strAux) \ 2 + 1 To Len(strAux)
        Select Case CInt(Mid(strAux, K, 1))
            Case 0
                strExit = strExit & "1110010"
            Case 1
                strExit = strExit & "1100110"
            Case 2
                strExit = strExit & "1101100"
            Case 3
                strExit = strExit & "1000010"
            Case 4
                strExit = strExit & "1011100"
            Case 5
                strExit = strExit & "1001110"
            Case 6
                strExit = strExit & "1010000"
            Case 7
                strExit = strExit & "1000100"
            Case 8
                strExit = strExit & "1001000"
            Case 9
                strExit = strExit & "1110100"
        End Select
    Next K

    strExit = strExit & "101000"
    EAN2Bin = strExit
End Function

'加载各个点的坐标到集合中
Private Function LoadCoordinate() As Boolean
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim arrFormat
    
    '读取坐标等信息
    strSQL = "select BCProperty,BCXPos,BCYPos,BCWidth,BCHeight,BCFont,IsUse from SET_BC" _
            & " where BCID=2" '2表示用户设置值
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If Not rstemp.EOF Then
        Do While Not rstemp.EOF
            Select Case rstemp("BCProperty")
                Case "BarCode" '条形码
                    mcorBarCode.x = Printer.ScaleX(rstemp("BCXPos"), vbMillimeters, vbTwips)
                    mcorBarCode.y = Printer.ScaleY(rstemp("BCYPos"), vbMillimeters, vbTwips)
                    mcorBarCode.Width = Printer.ScaleX(rstemp("BCWidth"), vbMillimeters, vbTwips)
                    mcorBarCode.Height = Printer.ScaleY(rstemp("BCHeight"), vbMillimeters, vbTwips)
                Case "CodeNumber" '条形码数字
                    mcorCodeNumber.x = Printer.ScaleX(rstemp("BCXPos"), vbMillimeters, vbTwips)
                    mcorCodeNumber.y = Printer.ScaleY(rstemp("BCYPos"), vbMillimeters, vbTwips)
                    arrFormat = Split(rstemp("BCFont"), ",")
                    With mfonCodeNumber
                        .FontName = arrFormat(0)
                        .FontSize = arrFormat(1)
                        .FontBold = arrFormat(2)
                        .FontItalic = arrFormat(3)
                        .FontUnderline = arrFormat(4)
                    End With
                    mcorCodeNumber.IsUse = rstemp("IsUse")
                Case "Hospital" '体检中心
                    mcorHospital.x = Printer.ScaleX(rstemp("BCXPos"), vbMillimeters, vbTwips)
                    mcorHospital.y = Printer.ScaleY(rstemp("BCYPos"), vbMillimeters, vbTwips)
                    arrFormat = Split(rstemp("BCFont"), ",")
                    With mfonHospital
                        .FontName = arrFormat(0)
                        .FontSize = arrFormat(1)
                        .FontBold = arrFormat(2)
                        .FontItalic = arrFormat(3)
                        .FontUnderline = arrFormat(4)
                    End With
                    mcorHospital.IsUse = rstemp("IsUse")
                Case "PersonName" '姓名＋性别
                    mcorPersonName.x = Printer.ScaleX(rstemp("BCXPos"), vbMillimeters, vbTwips)
                    mcorPersonName.y = Printer.ScaleY(rstemp("BCYPos"), vbMillimeters, vbTwips)
                    arrFormat = Split(rstemp("BCFont"), ",")
                    With mfonPersonName
                        .FontName = arrFormat(0)
                        .FontSize = arrFormat(1)
                        .FontBold = arrFormat(2)
                        .FontItalic = arrFormat(3)
                        .FontUnderline = arrFormat(4)
                    End With
                    mcorPersonName.IsUse = rstemp("IsUse")
                Case "PersonCard" '身份证号
                    mcorPersonCard.x = Printer.ScaleX(rstemp("BCXPos"), vbMillimeters, vbTwips)
                    mcorPersonCard.y = Printer.ScaleY(rstemp("BCYPos"), vbMillimeters, vbTwips)
                    arrFormat = Split(rstemp("BCFont"), ",")
                    With mfonPersonCard
                        .FontName = arrFormat(0)
                        .FontSize = arrFormat(1)
                        .FontBold = arrFormat(2)
                        .FontItalic = arrFormat(3)
                        .FontUnderline = arrFormat(4)
                    End With
                    mcorPersonCard.IsUse = rstemp("IsUse")
            End Select
            
            rstemp.MoveNext
        Loop
        rstemp.Close
    End If
    
    '当前使用的条码类型
    strSQL = "select SYSTEMPROPERTY from SET_SYSTEM" _
            & " where SYSTEMNAME='BarCodeType'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If rstemp.EOF Then
        m_enuBarCodeType = CODE39
        '增加新记录
        strSQL = "insert into SET_SYSTEM(SYSTEMNAME,SYSTEMPROPERTY) values(" _
                & "'BarCodeType'" _
                & ",'" & CStr(m_enuBarCodeType) & "'" _
                & ")"
        GCon.Execute strSQL
    Else
        m_enuBarCodeType = rstemp("SYSTEMPROPERTY")
        rstemp.Close
    End If
    
    LoadCoordinate = True
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    '
End Function

'获取打印设置
Private Function GetPrinterSet() As Boolean
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim arrFormat
    Dim prtPrinter As Printer
    
    '读取坐标等信息
    strSQL = "select BCProperty from SET_BC" _
            & " where BCID=0" '0表示系统设置值
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If Not rstemp.EOF Then
        arrFormat = Split(rstemp("BCProperty"), ",")
        mblnCountTips = arrFormat(2) '是否每次均提示
        mintPrintCount = arrFormat(1) '打印份数
        Call SetDefaultPrinter(arrFormat(3)) '设置打印机
        m_strBarCodePrinterName = arrFormat(3)
        mstrHospital = arrFormat(4) '体检中心
        
        rstemp.Close
    End If
    Set rstemp = Nothing
    
    GetPrinterSet = True
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    '
End Function

'获取打印机名称
Public Property Get BarCodePrinter() As String
    BarCodePrinter = m_strBarCodePrinterName
End Property