Public Function PrintBarCode( _
ByVal strBarCode As String, _
Optional ByVal intXPos As Integer = 70, _
Optional ByVal intYPos As Integer = 20, _
Optional ByVal intPrintHeight As Integer = 15, _
Optional ByVal bolPrintText As Boolean = False _
)
Dim intOldScaleMode As ScaleModeConstants
Dim intOldDrawWidth As Integer
Dim fntOldFont As StdFont
Dim strBC As String
Dim x As Integer
Dim y As Integer
Dim intHeight As Integer
Dim intIndex As Integer
Dim I As Integer, j As Integer, K As Integer
' 参数说明:
' intXPos, intYPos - 条形码的左上角坐标(缺省为(0,0)，坐标刻度为:毫米)
' intHeight - 高度(缺省为一厘米,坐标刻度为:毫米)
' "0"-"9","A-Z","-","%","$"和"*" 的条码编码格式,总共 40 个字符
Static strBarTable(39) As String
' 初始化条码编码格式表
strBarTable(0) = "000110100" ' 0
strBarTable(1) = "100100001" ' 1
strBarTable(2) = "001100001" ' 2
strBarTable(3) = "101100000" ' 3
strBarTable(4) = "000110001" ' 4
strBarTable(5) = "100110000" ' 5
strBarTable(6) = "001110000" ' 6
strBarTable(7) = "000100101" ' 7
strBarTable(8) = "100100100" ' 8
strBarTable(9) = "001100100" ' 9
strBarTable(10) = "100001001" ' A
strBarTable(11) = "001001001" ' B
strBarTable(12) = "101001000" ' C
strBarTable(13) = "000011001" ' D
strBarTable(14) = "100011000" ' E
strBarTable(15) = "001011000" ' F
strBarTable(16) = "000001101" ' G
strBarTable(17) = "100001100" ' H
strBarTable(18) = "001001100" ' I
strBarTable(19) = "000011100" ' J
strBarTable(20) = "100000011" ' K
strBarTable(21) = "001000011" ' L
strBarTable(22) = "101000010" ' M
strBarTable(23) = "000010011" ' N
strBarTable(24) = "100010010" ' O
strBarTable(25) = "001010010" ' P
strBarTable(26) = "000000111" ' Q
strBarTable(27) = "100000110" ' R
strBarTable(28) = "001000110" ' S
strBarTable(29) = "000010110" ' T
strBarTable(30) = "110000001" ' U
strBarTable(31) = "011000001" ' V
strBarTable(32) = "111000000" ' W
strBarTable(33) = "010010001" ' X
strBarTable(34) = "110010000" ' Y
strBarTable(35) = "011010000" ' Z
strBarTable(36) = "000111000" ' -
strBarTable(37) = "100101000" ' %
strBarTable(38) = "010101000" ' $
strBarTable(39) = "010010100" ' *
If strBarCode = "" Then Exit Function
' 设置坐标刻度为缇(twip=1)
Me.DrawWidth = 1
' 线宽为 1
strBC = UCase(strBarCode)
' 将以毫米表示的 X 坐标转换为以缇表示
x = Me.ScaleX(intXPos, vbMillimeters, vbTwips)
' 将以毫米表示的 Y 坐标转换为以缇表示
y = Me.ScaleY(intYPos, vbMillimeters, vbTwips)
' 将以毫米表示的高度转换为以缇表示
intHeight = Me.ScaleY(intPrintHeight, vbMillimeters, vbTwips)
If bolPrintText = True Then
' 条码高度要减去下面的字符显示高度
intHeight = intHeight - Me.TextHeight(strBC)
End If
Const intWidthCU As Integer = 36
' 粗线和宽间隙宽度
Const intWidthXI As Integer = 12
' 细线和窄间隙宽度
' 添加起始字符
If Left(strBC, 1) <> "*" Then
strBC = "*" & strBC
End If
' 添加结束字符
If Right(strBC, 1) <> "*" Then
strBC = strBC & "*"
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
Exit Function
'当前版本只支持字符
'0\'-\'9\',\'A\'-\'Z\',\'-\',\'%\',\'$\'和\'*\'"
End Select
If bolPrintText = True Then
Me.CurrentX = x
Me.CurrentY = y + intHeight
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
Line (x + K, y)-Step(0, intHeight)
Next K
x = x + intWidthXI
' 画宽线
Else
For K = 0 To intWidthCU - 1
Line (x + K, y)-Step(0, intHeight)
Next K
x = x + intWidthCU
End If
' 每个字符条码之间为窄间隙
If j = 5 Then
x = x + intWidthXI * 4 - 10
Exit For
End If
' 窄间隙
If Mid(strBarTable(intIndex), j + 5, 1) = "0" Then
x = x + intWidthXI * 4 - 10
' 宽间隙
Else
x = x + intWidthCU * 2 - 20
End If
Next j
Next I
End Function
Private Sub Command1_Click()
PrintBarCode (Text1.Text)
Label1.Caption = Text1.Text
End Sub
Private Sub Command2_Click()
Unload Me
End Sub
Private Sub Command3_Click()
SavePicture Form1.Image, "d:\libing.bmp"
End Sub
