VB生成条形码(EAN-13)

14年给别人写的一个库存软件,用到扫码枪,所以就有了这个类.

编码规则相对简单,详见百度百科EAN-13

示例运行效果如下:

类模块:cEAN13.cls

Option Explicit
'★━┳━━━━━━━━━━━━━━━━━━━━
'☆  ┃2014/10/5 18:14:58 |13位EAN-13条码条形码生成类
'☆  ┃悠悠然(QQ:2860898817,VB交流群:369088586)
'┗━┻━━━━━━━━━━━━━━━━━━━━
'-----------------------------------------------------
'文字绘制API
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal h As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal i As Long, ByVal u As Long, ByVal s As Long, ByVal c As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Private Const ANSI_CHARSET = 0 '设置语言系统,中国汉字,西欧文,中东文字等... ...
Private Const FW_HEAVY = 200 '设置字体的粗细程度
Private Const OUT_DEFAULT_PRECIS = 0
Private Const CLIP_DEFAULT_PRECIS = 0
Private Const DEFAULT_QUALITY = 0
Private Const DEFAULT_PITCH = 0
Private Const FF_SWISS = 32

Private Const FONT_XIE = 0 '设置字体是否倾斜
Private Const FONT_DOWN_LINE = 0 '设置字体是否有下画线
Private Const FONT_MID_LINE = 0 '设置字体是否有中画线
'-----------------------------------------------------
'线条绘制API
Private Type POINTAPI
        x As Long
        y As Long
End Type
Private Declare Function MoveToEx Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Const PS_SOLID = 0
'-----------------------------------------------------
Dim lstData(2, 9) As String 'A/B/C集
Dim LeftCode As String
Dim MidCode As String
Dim RightCode As String

Dim Lmode(5) As Byte '左侧的线型即
Dim Rmode(5) As Byte '右侧线型集

Dim oldrndnum1 As Long '随机生成时防重复
Dim oldrndnum2 As Long '随机生成时防重复
Private myHair As Long

'★┳━━━━━━━━━━━━━━━━━━━━
'┃┃ 2014/10/5 18:14:24 PrintCode
'┃┃ 打印条形码到DC
'┃┃ 参数分别是 打印目标的DC句柄,条纹代码,偏移坐标X,偏移坐标Y,条码高度
'┗┻━━━━━━━━━━━━━━━━━━━━
Public Function PrintCode(printDC As Long, strCode As String, Optional devX As Long = 0, Optional devY As Long = 0, Optional LineHeight As Long = 50) As Boolean
    Dim SC As String
    Dim LeftData As String
    Dim RightData As String
    Dim SS As String
    SC = CheckCode(strCode)
    If Len(SC) <> 13 Then Exit Function
    
    LeftData = CreateData(Mid(SC, 2, 6), Lmode)
    RightData = CreateData(Mid(SC, 8, 6), Rmode)
    SS = LeftCode & LeftData & MidCode & RightData & RightCode
    
    Dim i As Long
    Dim n As Long
    Dim j As Long
    For i = 1 To Len(SS)
        j = CLng(Mid(SS, i, 1))
        Select Case j
            Case 1
                DrawLine printDC, devX + n, devY, devX + n, LineHeight
            Case 3
                DrawLine printDC, devX + n, devY, devX + n, LineHeight + 5
        End Select
        n = n + 1
    Next i
    DrawFont printDC, Mid(SC, 1, 1), devX + 3, LineHeight
    DrawFont printDC, Mid(SC, 2, 6), devX + 18, LineHeight
    DrawFont printDC, Mid(SC, 8, 6), devX + 64, LineHeight
    PrintCode = True
End Function

'★┳━━━━━━━━━━━━━━━━━━━━
'┃┃ 2014/10/5 18:14:24 CreateData
'┃┃ 用于创建条码左右两侧的数据
'┗┻━━━━━━━━━━━━━━━━━━━━
Private Function CreateData(data As String, mode() As Byte) As String
    Dim i As Long
    Dim j As Long
    Dim s As String
    For i = 1 To 6
        j = CLng(Mid(data, i, 1))
        s = s & lstData(mode(i - 1), j)
    Next i
    CreateData = s
End Function

'★┳━━━━━━━━━━━━━━━━━━━━
'┃┃ 2014/10/5 18:14:24 CreateCode
'┃┃ 创造一个条码,lastCode参数最好是9位数
'┗┻━━━━━━━━━━━━━━━━━━━━
Public Function CreateCode(Optional lastCode As Long) As String
    Dim i As Long
    Dim j As Long
    Dim s As String
    If lastCode = 0 Then
        i = DateDiff("s", "2014-1-1 12:12:12", Now)
        If oldrndnum1 = i Then
            Do
               j = Rnd * 9
               If j <> oldrndnum2 Then Exit Do
            Loop
        Else
            j = Rnd * 9
        End If
        oldrndnum1 = i
        oldrndnum2 = j
        s = "699" & i & j
    Else
        s = "699" & CStr(lastCode + 1)
        If Len(s) <> 13 Then s = s & "0000000000"
    End If
    s = Left(s, 13)
    Dim n(12) As Long
    For i = 1 To Len(s)
        n(i - 1) = CLng(Mid(s, i, 1))
    Next i
    Dim m As Long
    Dim v As Long
    Dim h As Long
    Dim sw As String
    m = n(0) + n(2) + n(4) + n(6) + n(8) + n(10)
    v = n(1) + n(3) + n(5) + n(7) + n(9) + n(11)
    h = m + v * 3
    sw = CStr(h)
    sw = Mid(sw, Len(sw), 1)
    h = CLng(sw)
    h = 10 - h
    If h = 10 Then h = 0
    n(12) = h
    For i = 0 To 12
        CreateCode = CreateCode & n(i)
    Next i
End Function
'★┳━━━━━━━━━━━━━━━━━━━━
'┃┃ 2014/10/5 18:14:24 CheckCode
'┃┃ 判断条码是否正确
'┗┻━━━━━━━━━━━━━━━━━━━━

'检测编码是否正确
Public Function CheckCode(strCode As String) As String
    On Error GoTo errLine
    Dim SC As String
    SC = Trim(strCode)
    If Len(SC) <> 13 Then Exit Function
    Dim n(12) As Long
    Dim i As Long
    For i = 1 To Len(SC)
        n(i - 1) = CLng(Mid(SC, i, 1))
    Next i
    Dim m As Long
    Dim v As Long
    Dim h As Long
    Dim sw As String
    m = n(0) + n(2) + n(4) + n(6) + n(8) + n(10)
    v = n(1) + n(3) + n(5) + n(7) + n(9) + n(11)
    h = m + v * 3
    sw = CStr(h)
    sw = Mid(sw, Len(sw), 1)
    h = CLng(sw)
    h = 10 - h
    If h = 10 Then h = 0
    If h <> n(12) Then Exit Function
    CheckCode = SC
errLine:
End Function


'★┳━━━━━━━━━━━━━━━━━━━━
'┃┃ 2014/10/5 18:14:24 DrawLine
'┃┃ 画条码线
'┗┻━━━━━━━━━━━━━━━━━━━━
Private Sub DrawLine(hDC As Long, startpx As Long, startpy As Long, endpx As Long, endpy As Long)
    Dim old As Long
    Dim p As Long
    Dim a As POINTAPI
    p = CreatePen(PS_SOLID, 1, vbBlack) '线型,线宽,颜色
    old = SelectObject(hDC, p)
    MoveToEx hDC, startpx, startpy, a
    LineTo hDC, endpx, endpy
    SelectObject hDC, old
    DeleteObject p
End Sub


'★┳━━━━━━━━━━━━━━━━━━━━
'┃┃ 2014/10/5 18:14:24 DrawFont
'┃┃ 画条码数字
'┗┻━━━━━━━━━━━━━━━━━━━━
Private Sub DrawFont(ShowHdc As Long, YouStr As String, sx As Long, sy As Long)
    Dim strNum As Long
    Dim mFont As Long
    strNum = lstrlen(YouStr)
    mFont = CreateFont(12, 0, 0, 0, FW_HEAVY, _
                                                FONT_XIE, _
                                                FONT_DOWN_LINE, _
                                                FONT_MID_LINE, _
                                                ANSI_CHARSET, _
                                                OUT_DEFAULT_PRECIS, _
                                                CLIP_DEFAULT_PRECIS, _
                                                DEFAULT_QUALITY, _
                                                DEFAULT_PITCH Or FF_SWISS, _
                                                "宋体")
    SelectObject ShowHdc, mFont
    SetTextColor ShowHdc, vbBlack
    TextOut ShowHdc, sx, sy, YouStr, strNum
    DeleteObject mFont
End Sub


Private Sub Class_Initialize()
    lstData(0, 0) = "0001101":       lstData(1, 0) = "0100111":      lstData(2, 0) = "1110010":
    lstData(0, 1) = "0011001":       lstData(1, 1) = "0110011":      lstData(2, 1) = "1100110":
    lstData(0, 2) = "0010011":       lstData(1, 2) = "0011011":      lstData(2, 2) = "1101100":
    lstData(0, 3) = "0111101":       lstData(1, 3) = "0100001":      lstData(2, 3) = "1000010":
    lstData(0, 4) = "0100011":       lstData(1, 4) = "0011101":      lstData(2, 4) = "1011100":
    lstData(0, 5) = "0110001":       lstData(1, 5) = "0111001":      lstData(2, 5) = "1001110":
    lstData(0, 6) = "0101111":       lstData(1, 6) = "0000101":      lstData(2, 6) = "1010000":
    lstData(0, 7) = "0111011":       lstData(1, 7) = "0010001":      lstData(2, 7) = "1000100":
    lstData(0, 8) = "0110111":       lstData(1, 8) = "0001001":      lstData(2, 8) = "1001000":
    lstData(0, 9) = "0001011":       lstData(1, 9) = "0010111":      lstData(2, 9) = "1110100":
    
    Lmode(0) = 0: Lmode(1) = 1: Lmode(2) = 1: Lmode(3) = 1: Lmode(4) = 0: Lmode(5) = 0 'ABBBAA
    Rmode(0) = 2: Rmode(1) = 2: Rmode(2) = 2: Rmode(3) = 2: Rmode(4) = 2: Rmode(5) = 2 'CCCCCC
    
    LeftCode = "00000000000" & "303"
    MidCode = "03030"
    RightCode = "303" & "0000000"
    Randomize (Time)
End Sub