Excel自带控件批量生成条形码或二维码

Sub 批量生成二维码()    Dim k As Long, i As Long    Call 清除    k = ActiveSheet.Range("A65536").End(xlUp).Row    For i = 1 To k        With ActiveSheet.OLEObjects.Add(ClassType:="BARCODE.BarCodeCtrl.1") '新增控件            '控件的属性            .Left = ActiveSheet.Cells(i, 1).Width + 2            .Top = ActiveSheet.Cells(i, 1).Top + 2            .Width = 50            .Height = 50            '链接的参数单元格            .Object.Style = 11 '二维码            .Object.ShowData = 1            .LinkedCell = "A" & i        End With    NextEnd Sub
Sub 批量生成条形码()    Dim k As Long, i As Long    Call 清除    k = ActiveSheet.Range("A65536").End(xlUp).Row    For i = 1 To k        With ActiveSheet.OLEObjects.Add(ClassType:="BARCODE.BarCodeCtrl.1") '新增控件            '控件的属性            .Left = ActiveSheet.Cells(i, 1).Width + 2            .Top = ActiveSheet.Cells(i, 1).Top + 2            .Width = 150            .Height = 50             '链接的参数单元格            .Object.Style = 7 '条码            .Object.ShowData = 1            .LinkedCell = "A" & i        End With    NextEnd SubSub 清除()    Dim pic As Shape    With Sheet1        For Each pic In .Shapes            If pic.Type = 12 Then pic.Delete  '删除sheet1中所有二维码图片        Next pic    End WithEnd SubSub 导出二维码条形码()    Dim ad$, m&, mc$, shp As Shape    Dim nm$, n&, myFolder$    n = 0    myFolder = ThisWorkbook.Path & "\二维码图片\"   '指定文件夹名称    For Each shp In ActiveSheet.Shapes        If shp.Type = 12 Then            If Len(Dir(myFolder, vbDirectory)) = 0 Then                MkDir myFolder            End If            n = n + 1            m = shp.TopLeftCell.Row            mc = Cells(m, 1)'            If code_name = "" Then                nm = mc & ".jpg"  '图形对象的名字'            Else'                nm = ActiveSheet.Cells(m, code_name) & ".jpg"'            End If            shp.CopyPicture '将图形对象复制到剪切板            With ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart '在工作表中添加一个图表对象                .Parent.Select                .Paste '代码将剪切板中的图形对象以图片的格式粘贴到新添加的图表中                .Export myFolder & nm                .Parent.Delete '删除工作表中添加的图表对象            End With        End If    NextEnd Sub