工具分享：Excel制作的条形码生成器

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