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