标签:VBA,ActiveX控件
这是用Excel制作的一个条形码生成器,仍然是在forum.ozgrid.com中找到的一个很好的示例。
如下图1所示,工作表中有一个文本框,在其中输入文本后,在其下方自动生成相应的条形码。
图1
在该工作表代码模块中,输入下面的代码:
Private Sub tbBarcode_Change()
Dim Shp As Object
For Each Shp In ActiveSheet.Shapes
If Shp.Name = "BarCode39" Then Shp.Delete
Next
If Len(ActiveSheet.tbBarcode.Text) > 0 Then Draw39 ActiveSheet.tbBarcode.Text
End Sub
Sub Draw39(S As String)
Dim BC As Variant
Dim I As Integer, J As Integer, P As Integer
Dim Xpos As Integer, YPos As Integer
Dim SBin As String
Const Chars = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-. $/+%"
Const DW = 2
BC = Array("000110100", "100100001", "001100001", "101100000", "000110001", "100110000", "001110000", "000100101", _
"100100100", "001100100", "100001001", "001001001", "101001000", "000011001", "100011000", "001011000", _
"000001101", "100001100", "001001100", "000011100", "100000011", "001000011", "101000010", "000010011", _
"100010010", "001010010", "000000111", "100000110", "001000110", "000010110", "110000001", "011000001", _
"111000000", "010010001", "110010000", "011010000", "010000101", "110000100", "011000100", "010101000", _
"010100010", "010001010", "000101010", "010010100")
S = UCase(S)
SBin = ""
Xpos = 10
YPos = 70
J = 1
For I = 1 To Len(S)
P = InStr(Chars, Mid(S, I, 1))
If P = 0 Then
MsgBox "Invalid Character'" & Mid(S, I, 1) & "' Found", vbCritical, "Error"
Exit Sub
Else
SBin = SBin & BC(P - 1) & "0"
End If
Next
SBin = BC(43) & "0" & SBin & BC(43)
For I = 1 To Len(SBin)
If I Mod 2 = 0 Then
Xpos = Xpos + DW * (1 + (Val(Mid(SBin, I, 1))))
Else
For P = 0 To DW * (1 + 2 * (Val(Mid(SBin, I, 1))))
DLine Xpos * 0.75, YPos, Xpos * 0.75, YPos + 58, 0, J
Xpos = Xpos + 1
J = J + 1
Next
End If
Next
For I = 1 To J - 1
ActiveSheet.Shapes("Bar39" & CStr(I)).Select Replace:=False
Next
Selection.ShapeRange.Group.Select
Selection.Name = "BarCode39"
End Sub
Sub DLine(X1, Y1, X2, Y2, C, N)
With ActiveSheet.Shapes.AddLine(X1, Y1, X2, Y2)
.Name = "Bar39" & CStr(N)
With .Line
.Weight = 0.75
.Style = msoLineSingle
.ForeColor.RGB = RGB(C, C, C)
End With
End With
End Sub
有兴趣的朋友,可以到原论坛上下载该示例工作簿。