Excel根据单号批量生成条形码，可支持特殊字符的字符串

Fannie_lxx

由于需要对订单excel生成订单条形码方便生产去扫描，普通数字字母组合的可以下个39字体插件就解决了，但是某类订单号需要含有特殊字符，如：@，#，；-等等特殊字符，查了很多字资料，最后在这一篇http://club.excelhome.net/thread-1223631-1-1.html查到了，但是还是识别不了特殊字符，
学习了，代码还是识别不了特殊字符集的，不能生成二维码，后面经过千辛万苦遇到的问题我更改过后现在可以用了，我的版本是2010版本EXCEL

Sub MainBatchAddBarCode()
    Application.Calculation = xlCalculationManual '1  禁止Excel自动运算公式
    Application.DisplayAlerts = False  '2 -禁止弹出警告框
    Application.ScreenUpdating = False '3 -禁止屏幕刷新

    Dim i%, str1$, str2$, str3$, tempStr$, d As Object, hegiht As Integer
    Dim count As Integer

    Dim r As Range
    Set r = Intersect(ActiveSheet.AutoFilter.Range, Range("B:B"))

    count = Application.WorksheetFunction.Subtotal(103, r) - 1  ’获得筛选到的特殊字符列的总行数，行数太多，性能太卡

    Set d = New DataObject

    If count = 0 Then
        MsgBox "A列单号为空，程序退出!"
        Exit Sub
    ElseIf (count > 150) Then
        MsgBox "批量数据大于150条！请减少数量！"
        Exit Sub
    Else
    i = Range("B65535").End(xlUp).Row
    For j = 2 To i
        tempStr = Replace(Cells(j, 2), "#", "%23") '128识别不了#相关字符需转换
        str1 = "<table><img src=""http://apps.99wed.com/360app/barcode/barcode.php?codebar=BCGcode128&text="
        str2 = "&resolution=2&thickness=30"" > "
        str3 = str3 & str1 & tempStr & str2 & Chr(10) 'Chr(10)为换行的意思
    Next
    d.SetText str3
    d.PutInClipboard

    Range("AD2").Select
    ActiveSheet.PasteSpecial Format:="Unicode Text", Link:=False, DisplayAsIcon:=False

    Set d = Nothing
    Columns(1).HorizontalAlignment = xlCenter
    Columns(1).VerticalAlignment = xlCenter

    Rows(1 & ":" & i).RowHeight = 72 '设为72标准高度

    Columns(1).ColumnWidth = ActiveSheet.Pictures(1).Width / 6.13
    End If

    Application.Calculation = xlCalculationAutomatic '1  禁止Excel自动运算公式
    Application.DisplayAlerts = True  '2 -禁止弹出警告框
    Application.ScreenUpdating = True '3 -禁止屏幕刷新
End Sub


Sub MainBatchDeleteShape()

    Application.Calculation = xlCalculationManual '1  禁止Excel自动运算公式
    Application.DisplayAlerts = False  '2 -禁止弹出警告框
    Application.ScreenUpdating = False '3 -禁止屏幕刷新

    Dim myshape As Shape

    '只删掉有关的条形码，而不删除其他形状
    For Each myshape In ActiveSheet.Shapes
        If Not Application.Intersect(myshape.TopLeftCell, ActiveSheet.Range("AD6:AD65535")) Is Nothing Then myshape.Delete
    Next

    Application.Calculation = xlCalculationAutomatic '1  禁止Excel自动运算公式
    Application.DisplayAlerts = True  '2 -禁止弹出警告框
    Application.ScreenUpdating = True '3 -禁止屏幕刷新

End Sub


这种方式适合code128识别特殊字符生成条形码针对于#号识别不了问题的代码，其中New DataObject需要引用包，点击Tools--》refrences勾选MicrosoftForms2.0ObjectLibray包就不会报错了