clsbarcode.cls

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

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsBarCode"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'坐标
Private mcorBarCode As Coordinate
Private mcorCodeNumber As Coordinate
Private mcorHospital As Coordinate
Private mcorPersonName As Coordinate
Private mcorPersonCard As Coordinate
'字体
Private mfonCodeNumber As FontType
Private mfonHospital As FontType
Private mfonPersonName As FontType
Private mfonPersonCard As FontType
'条形码类型
Private m_enuBarCodeType As BarCodeType
'其它
Private mblnLoaded As Boolean       '当前实例是否已经加载
Private mintPrintCount As Integer   '打印页数
Private mblnCountTips As Boolean    '是否提示输入页数
Private mstrHospital As String          '要打印的体检中心名称
Private m_strBarCodePrinterName As String '条形码打印机的名称

Public Function PrintBarcode( _
        ByVal strBarCode As String, _
        Optional ByVal intXPos As Integer = 7, _
        Optional ByVal intYPos As Integer = 3, _
        Optional ByVal intPrintHeight As Integer = 10, _
        Optional ByVal bolPrintText As Boolean = True, _
        Optional ByVal strPersonName As String, _
        Optional ByVal strPersonCard As String, _
        Optional ByVal lngGUID As Long) As Long
    Dim i As Integer
    Dim strRet As String
    Dim strOldDeviceName As String
    Dim strDWMC As String
    
    Screen.MousePointer = vbArrowHourglass
    If strBarCode = "" Then GoTo ExitLab ' 不打印空串
    
    strOldDeviceName = Printer.DeviceName
    If Not mblnLoaded Then
        '加载坐标设置
        If LoadCoordinate = False Then GoTo ExitLab
        
        mblnLoaded = True
    End If
    '获取打印机设置
    If GetPrinterSet = False Then GoTo ExitLab
    
    '是否要接收打印份数
    If mblnCountTips Then
        '打印份数。
        strRet = InputBox("请输入要打印条形码的份数：", "打印份数", mintPrintCount)
        If strRet = "" Then GoTo ExitLab
        mintPrintCount = CInt(Val(strRet))
    End If
    
    '获取单位名称
    strDWMC = GetPersonUnit(lngGUID, "", True)
    
    '如果打印系统档案号，条码是否支持字母A
    If (g_enuBarCodeContents = BC_SYSTEMID) Then
        If Right(strBarCode, 1) = AFFIRM Then
            strBarCode = Left(strBarCode, Len(strBarCode) - 1)
        End If
    End If
    
    '调用实际打印函数
    If mintPrintCount < 1 Then mintPrintCount = 1
    For i = 1 To mintPrintCount
        Call PrintOneBarCode(strBarCode, intXPos, intYPos, intPrintHeight, bolPrintText, strPersonName, strPersonCard, strDWMC)
        If i < mintPrintCount Then
            Printer.NewPage '新页
        End If
    Next i
    '提交打印
    Printer.EndDoc
    
    '恢复默认打印机
    Call SetDefaultPrinter(strOldDeviceName)
    GoTo ExitLab
ExitLab:
    Screen.MousePointer = vbDefault
End Function

Private Function PrintOneBarCode( _
        ByVal strBarCode As String, _
        Optional ByVal intXPos As Integer = 7, _
        Optional ByVal intYPos As Integer = 3, _
        Optional ByVal intPrintHeight As Integer = 10, _
        Optional ByVal bolPrintText As Boolean = True, _
        Optional ByVal strPersonName As String, _
        Optional ByVal strPersonCard As String, _
        Optional ByVal strPersonUnit As String) As Long
' 参数说明:
' strBarCode　　　　- 要打印的条形码字符串
' intXPos, intYPos - 打印条形码的左上角坐标(缺省为(0,0)，坐标刻度为:毫米)
' intHeight　　　　 - 打印高度(缺省为一厘米,坐标刻度为:毫米)
' bolPrintText　　 - 是否打印人工识别字符(缺省为true)
' intCount         - 打印份数(缺省为1)
'strPersonName     - 是否打印附加信息，比如姓名

    If strBarCode = "" Then Exit Function ' 不打印空串
    
    With Printer
        '保存打印机 ScaleMode
        Dim intOldScaleMode As ScaleModeConstants
        intOldScaleMode = .ScaleMode
    
        '保存打印机 DrawWidth
        Dim intOldDrawWidth As Integer
        intOldDrawWidth = .DrawWidth
    
        '保存打印机 Font
        Dim fntOldFont As StdFont
        Set fntOldFont = .Font
        
        '重新设置打印参数
        .ScaleMode = vbTwips ' 设置打印用的坐标刻度为缇(twip=1)
        .DrawWidth = 1    ' 线宽为 1
        
        '********************************************************************
        '打印体检中心
        '********************************************************************
        If mcorHospital.IsUse Then
            .FontName = mfonHospital.FontName
            .FontSize = mfonHospital.FontSize
            .FontBold = mfonHospital.FontBold
            .FontItalic = mfonHospital.FontItalic
            .FontUnderline = mfonHospital.FontUnderline
            .CurrentX = mcorHospital.x
            .CurrentY = mcorHospital.y
            Printer.Print strPersonUnit 'mstrHospital
        End If
        
        '********************************************************************
        '打印姓名+性别
        '********************************************************************
        If mcorPersonName.IsUse Then
            .FontName = mfonPersonName.FontName
            .FontSize = mfonPersonName.FontSize
            .FontBold = mfonPersonName.FontBold
            .FontItalic = mfonPersonName.FontItalic
            .FontUnderline = mfonPersonName.FontUnderline
            .CurrentX = mcorPersonName.x
            .CurrentY = mcorPersonName.y
            Printer.Print strPersonName
        End If
        
        '********************************************************************
        '打印身份证号
        '********************************************************************
        If mcorPersonCard.IsUse Then
            .FontName = mfonPersonCard.FontName
            .FontSize = mfonPersonCard.FontSize
            .FontBold = mfonPersonCard.FontBold
            .FontItalic = mfonPersonCard.FontItalic
            .FontUnderline = mfonPersonCard.FontUnderline
            .CurrentX = mcorPersonCard.x
            .CurrentY = mcorPersonCard.y
            Printer.Print strPersonCard
        End If
        
        '打印条形码和编码
        Select Case m_enuBarCodeType
            Case BarCodeType.CODE39
                Call PrintBarCode_39(strBarCode)
            Case BarCodeType.EAN8Or13
                Call PrintBarCode_EAN(strBarCode)
            Case Else
                '
        End Select
        
        '恢复打印机 ScaleMode
        .ScaleMode = intOldScaleMode
        '恢复打印机 DrawWidth
        .DrawWidth = intOldDrawWidth
        '恢复打印机 Font
        Set .Font = fntOldFont
    End With
End Function

'打印39码
Private Sub PrintBarCode_39(ByVal strBarCode As String, _
        Optional ByVal bolPrintText As Boolean = True)
   '"0"-"9","A-Z","-","%","$"和"*" 的条码编码格式,总共 40 个字符
    Static strBarTable(39) As String
    '初始化条码编码格式表
    strBarTable(0) = "001100100"     ' 0
    strBarTable(1) = "100010100"     ' 1
    strBarTable(2) = "010010100"     ' 2
    strBarTable(3) = "110000100"     ' 3
    strBarTable(4) = "001010100"     ' 4
    strBarTable(5) = "101000100"     ' 5
    strBarTable(6) = "011000100"     ' 6
    strBarTable(7) = "000110100"     ' 7
    strBarTable(8) = "100100100"     ' 8
    strBarTable(9) = "010100100"     ' 9
    strBarTable(10) = "100010010"    ' A
    strBarTable(11) = "010010010"    ' B
    strBarTable(12) = "110000010"    ' C
    strBarTable(13) = "001010010"    ' D
    strBarTable(14) = "101000010"    ' E
    strBarTable(15) = "011000010"    ' F
    strBarTable(16) = "000110010"    ' G
    strBarTable(17) = "100100010"    ' H
    strBarTable(18) = "010100010"    ' I
    strBarTable(19) = "001100010"    ' J
    strBarTable(20) = "100010001"    ' K
    strBarTable(21) = "010010001"    ' L
    strBarTable(22) = "110000001"    ' M
    strBarTable(23) = "001010001"    ' N
    strBarTable(24) = "101000001"    ' O
    strBarTable(25) = "011000001"    ' P
    strBarTable(26) = "000110001"    ' Q
    strBarTable(27) = "100100001"    ' R
    strBarTable(28) = "010100001"    ' S
    strBarTable(29) = "001100001"    ' T
    strBarTable(30) = "100011000"    ' U
    strBarTable(31) = "010011000"    ' V
    strBarTable(32) = "110001000"    ' W
    strBarTable(33) = "001011000"    ' X
    strBarTable(34) = "101001000"    ' Y
    strBarTable(35) = "011001000"    ' Z
    strBarTable(36) = "000111000"    ' -
    strBarTable(37) = "100101000"    ' %
    strBarTable(38) = "010101000"    ' $
    strBarTable(39) = "001101000"    ' *
    
    Dim strBC As String         ' 要打印的条码字符串
    strBC = UCase(strBarCode)

    Dim x As Single
    Dim y As Single
    Dim intHeight As Integer
    Const intWidthCU As Integer = 30 ' 粗线和宽间隙宽度
    Const intWidthXI As Integer = 10 ' 细线和窄间隙宽度
    Dim intIndex As Integer            ' 当前处理的字符串索引
    Dim i As Integer, j As Integer, K As Integer    ' 循环控制变量

    '添加起始字符
    If Left(strBC, 1) <> "*" Then
        strBC = "*" & strBC
    End If
    '添加结束字符
    If Right(strBC, 1) <> "*" Then
        strBC = strBC & "*"
    End If
    
    '重新设置条形码坐标（相当于忽略掉了传入的参数）
    x = mcorBarCode.x
    y = mcorBarCode.y
    intHeight = mcorBarCode.Height
    
    With Printer
        '设置条码编号的字体信息
        If bolPrintText = True Then
            .FontName = mfonCodeNumber.FontName
            .FontSize = mfonCodeNumber.FontSize
            .FontBold = mfonCodeNumber.FontBold
            .FontItalic = mfonCodeNumber.FontItalic
            .FontUnderline = mfonCodeNumber.FontUnderline
        End If
        
        '循环处理每个要显示的条码字符
        For i = 1 To Len(strBC)
            '确定当前字符在 strBarTable 中的索引
            Select Case Mid(strBC, i, 1)
                Case "*"
                    intIndex = 39
                Case "$"
                    intIndex = 38
                Case "%"
                    intIndex = 37
                Case "-"
                    intIndex = 36
                Case "0" To "9"
                    intIndex = CInt(Mid(strBC, i, 1))
                Case "A" To "Z"
                    intIndex = Asc(Mid(strBC, i, 1)) - Asc("A") + 10
                Case Else
                    MsgBox "要打印的条形码字符串中包含无效字符！当前版本只支持字符 '0'-'9','A'-'Z','-','%','$'和'*'"
            End Select
            
            '********************************************************************
            '是否在条形码下方打印人工识别字符
            If mcorCodeNumber.IsUse Then
                .CurrentX = x
                .CurrentY = mcorCodeNumber.y
                Printer.Print Mid(strBC, i, 1)
            End If
            '********************************************************************
    
            For j = 1 To 5
                '画细线
                If Mid(strBarTable(intIndex), j, 1) = "0" Then
                    For K = 0 To intWidthXI - 1
                        Printer.Line (x + K, y)-Step(0, intHeight)
                    Next K
    
                    x = x + intWidthXI
                '画宽线
                Else
                    For K = 0 To intWidthCU - 1
                        Printer.Line (x + K, y)-Step(0, intHeight)
                    Next K
    
                    x = x + intWidthCU
                End If
    
                '每个字符条码之间为窄间隙
                If j = 5 Then
                    x = x + intWidthXI * 3
                    Exit For
                End If
    
                '窄间隙
                If Mid(strBarTable(intIndex), j + 5, 1) = "0" Then
                    x = x + intWidthXI * 3
                '宽间隙
                Else
                    x = x + intWidthCU * 2
                End If
            Next j
        Next i
    End With
End Sub

'打印EAN8/13码
Private Sub PrintBarCode_EAN(ByVal strBarCode As String, _
        Optional ByVal blnPrintText As Boolean = True)
    Dim K As Single, i As Integer
    Dim sngPosX As Single
    Dim sngPosY As Single
    Dim sngScaleX As Single
    Dim strEANBin As String
    Dim lngBrush As Long

    Dim sngX As Single: Dim sngY As Single
    Dim sngWidth As Single: Dim sngHeight As Single
    Dim lpRect As Rect
    
    strBarCode = CheckDigit_EAN(strBarCode)
    If strBarCode = "" Then GoTo ExitLab
    strEANBin = EAN2Bin(strBarCode)
    
    sngX = mcorBarCode.x: sngY = mcorBarCode.y
    sngWidth = mcorBarCode.Width: sngHeight = mcorBarCode.Height
    
    sngPosX = sngX
    sngScaleX = sngWidth / Len(strEANBin)
    
    'Draw the BarCode lines
    For K = 1 To Len(strEANBin)
        If Mid(strEANBin, K, 1) = "1" Then