查看: 15920|回复: 72
自动批量生成条形码，可能你用得上，欢迎进来看看
阅读权限95
在线时间 小时
& && &&&昨天在回答一个坛友的提问，提问网址如下：
刚开始以为挺简单，因为之前有弄过条形码，用字体生成的，论坛里面也有不少关于条形码生成的例子，比如这个二岁老师提供的方法
百度也搜了一下，多数都是下载条码字体包，然后放到C:\Windows\Fonts下面，这个方法必须切换成指定的字体，有的还需要配合函数才能实现生成条形码，但是，我发现很多条形码字体包并不完美，有的生成的条形码打印出来，扫描枪无法扫描，有的无端的在上面加个字母或者星号*，这都不是我要的。
& && &&&回答这个坛友提问的时候，本来我也是想放个字体包上去，但是，自己实际测试发现，条码打印出来扫描不了，可能是因为分辨问题或者其它原因，总之是扫描枪识别不了，那生成的条形码就有瑕疵了，为了解决这个问题，我查询了海量资料，很喜欢一些在线生成条码的网站，上面生成的条形码基本都是很好扫描的，于是就有了“如何把在线条码网站上面的条形码图片插入到excel中来”的想法，然后我就花了一个下午时间时间整理写出了以下自动生成条码的过程，由于之前从没有写过类似代码，写的时候也走了好多弯路，个中滋味言语是形容不了的，不弄出来绝不放弃，然后在worksheet.pastesepcial方法上就纠结了好长时间，之前一直尝试用新建txt，然后把图片网址写入txt，再复制出来粘贴，但是均以失败告终，print,get等许多方法都不凑效，查询了很多资料，终于找到了DataObject对象，利用这个对象就能很好解决复制无格式的剪切板内容，于是就有了以下成果，高手可以一笑而过或者看看代码思路也没有关系，分享的目的主要是方便有需要坛友，以下方法生成的条形码是图片形式的，只要扫描枪支持code39，那就一定可以扫描，也可以把代码稍微修改一下，就可以支持生成code128,code128B，code139等类型的条形码，代码如下：
Sub 生成条码()
& & Dim i%, str1$, str2$, str3$, d As Object
& & Set d = New DataObject
& & Application.ScreenUpdating = False
& & If Application.CountA(Range(&A:A&)) = 0 Then
& && &&&MsgBox &A列单号为空，程序退出!&
& && &&&Exit Sub
& & Else
& & i = Range(&A1048576&).End(xlUp).Row
& & For j = 1 To i
& && &If Cells(j, 1) && && Then
& && &&&str1 = &&table&&img src=&&/html/cnaidc.php?filetype=PNG&dpi=72&scale=1&rotation=0&font_family=Arial.ttf&font_size=14&text=&
& && &&&str2 = &&thickness=30&checksum=&code=BCGcode39&& & &
& && &&&str3 = str3 & str1 & Cells(j, 1) & str2 & Chr(10)
& && &End If
& & Next
& & d.SetText str3
& & d.PutInClipboard
& & Range(&B1&).Select
& & ActiveSheet.PasteSpecial Format:=&Unicode 文本&, Link:=False, DisplayAsIcon:=False
& & Columns(1).HorizontalAlignment = xlCenter
& & Columns(1).VerticalAlignment = xlCenter
& & Rows(1 & &:& & i).RowHeight = ActiveSheet.Pictures(1).Height
& & Columns(2).ColumnWidth = ActiveSheet.Pictures(1).Width / 6.13
& & End If
& & Application.ScreenUpdating = True
End Sub复制代码以下是附件，宏工程无密码，可以直接查看源码
(20.52 KB, 下载次数: 2413)
12:48 上传
点击文件名下载附件
阅读权限95
在线时间 小时
本帖最后由 huang1314wei 于
21:34 编辑
大神求助，程序运行是下列出错，提示不能去的类worksheet的pictures属性
Rows(4 & &:& & i).RowHeight ...
一楼代码及附件由于网站规则改变，导致不能使用，现更新代码如下：
Sub 生成条码()
& & Dim i%, str1$, str2$, str3$, d As Object
& & Set d = New DataObject
& & Application.ScreenUpdating = False
& & If Application.CountA(Range(&A:A&)) = 0 Then
& && &&&MsgBox &A列单号为空，程序退出!&
& && &&&Exit Sub
& & Else
& & i = Range(&A1048576&).End(xlUp).Row
& & For j = 1 To i
& && &If Cells(j, 1) && && Then
& && &&&str1 = &&table&&img src=&&/360app/barcode/barcode.php?codebar=BCGcode128&text=&
& && &&&str2 = &&resolution=2&thickness=30&& & &
& && &&&str3 = str3 & str1 & Cells(j, 1) & str2 & Chr(10)
& && &End If
& & Next
& & d.SetText str3
& & d.PutInClipboard
& & Range(&B1&).Select
& & ActiveSheet.PasteSpecial Format:=&Unicode 文本&, Link:=False, DisplayAsIcon:=False
& & Columns(1).HorizontalAlignment = xlCenter
& & Columns(1).VerticalAlignment = xlCenter
& & Rows(1 & &:& & i).RowHeight = ActiveSheet.Pictures(1).Height
& & Columns(2).ColumnWidth = ActiveSheet.Pictures(1).Width / 6.13
& & End If
& & Application.ScreenUpdating = True
End Sub复制代码
更新的附件如下，请下载新附件使用
(20.17 KB, 下载次数: 279)
21:34 上传
点击文件名下载附件
优秀作品，非常感谢
阅读权限95
在线时间 小时
代码当中获取条形码图片是根据这个网站获取的
阅读权限30
在线时间 小时
非常好用，收藏
阅读权限20
在线时间 小时
如果源数据为文本，貌似不可以直接生成的哦？比如在文本列录入（10位数且开头为0）的数据，应该怎么样设置宏文本呢？谢谢!
阅读权限95
在线时间 小时
如果源数据为文本，貌似不可以直接生成的哦？比如在文本列录入（10位数且开头为0）的数据，应该 ...
不受影响，可以生成，如图
123.jpg (25.29 KB, 下载次数: 582)
15:17 上传
阅读权限20
在线时间 小时
追加问题：我要在J列Barcode那列批量生成附表的B列10位文本数字（开头为0）的条形码，便于打印，这个宏应当怎么编辑呢？
(7.77 KB, 下载次数: 378)
15:23 上传
点击文件名下载附件
阅读权限20
在线时间 小时
不受影响，可以生成，如图
谢谢大神的回复，我后面试过了可以生成，但我自己不会编辑宏，我想学会怎么去编辑宏里面的文本，对了，怎么可以给你的帖子评分呢？{:soso_e100:}
阅读权限95
在线时间 小时
& & & & & & & &
追加问题：我要在J列Barcode那列批量生成附表的B列10位文本数字（开头为0）的条形码，便于打印，这个宏应当 ...
把我的源代码稍微改一下，就可以适合你的表格了，附件如下：（运行的时候可能会有点慢，跟网速有关，请耐心等待运行完成）
(19.32 KB, 下载次数: 565)
15:59 上传
点击文件名下载附件
多谢分享！
阅读权限95
在线时间 小时
本帖最后由 VBA万岁 于
16:06 编辑
以下第2段代码是用Excel矩形加载网页条码图片的，不知条码枪能否识别？
&P&Sub 生成条码()
Dim i%, str1$, str2$, str3$, d As Object
Set d = New DataObject
Application.ScreenUpdating = False
If Application.CountA(Range(&A:A&)) = 0 Then
& & MsgBox &A列单号为空，程序退出!&
& & Exit Sub
Else
& & i = Range(&A1048576&).End(xlUp).Row
& & For j = 1 To i
& && &If Cells(j, 1) && && Then
& && &&&str1 = &&table&&img src=&&&A href=&/html/cnaidc.php?filetype=PNG&dpi=72&scale=1&rotation=0&font_family=Arial.ttf&font_size=14&text&&/html/cnaidc.php?filetype=PNG&dpi=72&scale=1&rotation=0&font_family=Arial.ttf&font_size=14&text&/A&=&
& && &&&str2 = &&thickness=30&checksum=&code=BCGcode39&& &&/table& &
& && &&&str3 = str3 & str1 & Cells(j, 1) & str2 & Chr(10)
& && &End If
& & Next
& & d.SetText str3
& & d.PutInClipboard
& & Range(&B& & Range(&A1&).End(xlDown).Row).Select
& & ActiveSheet.Paste
& & Rows(1 & &:& & i).RowHeight = ActiveSheet.Pictures(1).Height
& & Columns(2).ColumnWidth = ActiveSheet.Pictures(1).Width / 5.13
End If
Application.ScreenUpdating = True
End Sub&/P&
&P&Sub 生成条码2()
Dim Shp
For Each Shp In ActiveSheet.Shapes
& & If Left(Shp.Name, 6) && &Button& Then Shp.Delete
Next
Rows(Range(&A1&).End(xlDown).Row & &:& & Cells(Rows.Count, 1).End(xlUp).Row).RowHeight = 51.25
For Each cel In Range(&a& & Range(&A1&).End(xlDown).Row & &:a& & Cells(Rows.Count, 1).End(xlUp).Row)
& & str1 = &&A href=&/html/cnaidc.php?filetype=PNG&dpi=72&scale=1&rotation=0&font_family=Arial.ttf&font_size=14&text&&/html/cnaidc.php?filetype=PNG&dpi=72&scale=1&rotation=0&font_family=Arial.ttf&font_size=14&text&/A&=&
& & str2 = &&thickness=30&checksum=&code=BCGcode39&
& & cel.Offset(, 2).Select
& & ActiveSheet.Shapes.AddShape(msoShapeRectangle, cel.Offset(, 2).Left, cel.Offset(, 2).Top, cel.Offset(, 2).Width, cel.Offset(, 2).Height).Select
& & Selection.ShapeRange.Fill.UserPicture str1 & cel.Value & str2
Next
End Sub
&/P&复制代码
阅读权限95
在线时间 小时
以下第2段代码是用Excel矩形加载网页条码图片的，不知条码枪能否识别？
重传代码：
Sub 生成条码()
Dim i%, str1$, str2$, str3$, d As Object
Set d = New DataObject
Application.ScreenUpdating = False
If Application.CountA(Range(&A:A&)) = 0 Then
& & MsgBox &A列单号为空，程序退出!&
& & Exit Sub
Else
& & i = Range(&A1048576&).End(xlUp).Row
& & For j = 1 To i
& && &If Cells(j, 1) && && Then
& && &&&str1 = &&table&&img src=&&/html/cnaidc.php?filetype=PNG&dpi=72&scale=1&rotation=0&font_family=Arial.ttf&font_size=14&text=&
& && &&&str2 = &&thickness=30&checksum=&code=BCGcode39&& &&/table& &
& && &&&str3 = str3 & str1 & Cells(j, 1) & str2 & Chr(10)
& && &End If
& & Next
& & d.SetText str3
& & d.PutInClipboard
& & Range(&B& & Range(&A1&).End(xlDown).Row).Select
& & ActiveSheet.Paste
& & Rows(1 & &:& & i).RowHeight = ActiveSheet.Pictures(1).Height
& & Columns(2).ColumnWidth = ActiveSheet.Pictures(1).Width / 5.13
End If
Application.ScreenUpdating = True
End Sub
Sub 生成条码2()
Dim Shp
For Each Shp In ActiveSheet.Shapes
& & If Left(Shp.Name, 6) && &Button& Then Shp.Delete
Next
Rows(Range(&A1&).End(xlDown).Row & &:& & Cells(Rows.Count, 1).End(xlUp).Row).RowHeight = 51.25
For Each cel In Range(&a& & Range(&A1&).End(xlDown).Row & &:a& & Cells(Rows.Count, 1).End(xlUp).Row)
& & str1 = &/html/cnaidc.php?filetype=PNG&dpi=72&scale=1&rotation=0&font_family=Arial.ttf&font_size=14&text=&
& & str2 = &&thickness=30&checksum=&code=BCGcode39&
& & cel.Offset(, 2).Select
& & ActiveSheet.Shapes.AddShape(msoShapeRectangle, cel.Offset(, 2).Left, cel.Offset(, 2).Top, cel.Offset(, 2).Width, cel.Offset(, 2).Height).Select
& & Selection.ShapeRange.Fill.UserPicture str1 & cel.Value & str2
Next
End Sub
复制代码
最新热点 /1
ExcelHome每周都有线上直播公开课，
国内一流讲师真身分享，高手贴身答疑，
赶不上直播还能看录像，
关键居然是免费的！
厚木哥们都已经这么努力了，
你还好意思说学不好Office。
玩命加载中，请稍候
玩命加载中，请稍候
Powered by
本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！ & & 本站特聘法律顾问：徐怀玉律师 李志群律师查看: 4435|回复: 7
2010条形码的问题
阅读权限50
在线时间 小时
我有一个资产表想希望根据资产号产生条形码,想达到效果是根据资产号(数字组成)产生条形码,这样就可以打印出来并贴在资产上,然后以后拿扫描枪扫一下就知道是什么资产了.
但是我在网上搜索了下,还是不太清楚barcode控件怎么用,现在想问一下关于2010条形码控件的问题.
1.2010条形码控件如安装?我看到2003版是将将文件MSBCODE9.OCX复制到一个位置,还需要做其他什么注册吗?2010也是用这个控件吗,要放在什么目录?
2.如果条形码打印出来,我也有扫描枪,怎么样才能将信息(数字)扫描到电脑里?
(58.54 KB, 下载次数: 3)
21:03 上传
21:03 上传
点击文件名下载附件
6.66 KB, 下载次数: 82
阅读权限50
在线时间 小时
有谁知道关于条形码的吗？
阅读权限50
在线时间 小时
网上找了一下资料,然后自己录了一个宏,但是批量加上去还是不行.Sub AddBarcode()
Dim iCount&, i
'&Iá&E&×&LIST×&&ó&O&ÐÐ
iCount = Sheet3.[G65536].End(xlUp).Row
For i = 2 To iCount
With Sheet1.OLEObjects.Add(ClassType:=&BARCODE.BarCodeCtrl.1&)
& & .Object.Name = BarCtrl(i)
& & .Object.Style = BarStyle
& & .Object.Value = Sheet2.Cells(i, 7).Value
& & .Height = BarHigh
& & .Width = BarWidth
& & .Left = 15
& & .Top = 10 + i * BarHigh
End With
Next
End Sub复制代码
11:06 上传
点击文件名下载附件
15.62 KB, 下载次数: 90
阅读权限95
在线时间 小时
& & & & & & & &
前二天也在测QRCode问题
不过没有在2010测试过
提供几个帖给你看看
何用VBA批量生成二维条码图片
纯vba生成二维码（QRCode），无需第三方控件
你的附件代码，在2003下测试可行。其它沒测过
Option Explicit
Const BarHigh = 70
Const BarWidth = 140
Const BarStyle = 6
Sub AddBarcode()
Dim iCount&, i, QR
iCount = Sheet3.[G65536].End(xlUp).Row
For Each QR In Sheet1.Shapes
& & QR.Delete
Next QR
For i = 2 To iCount
& & Set QR = Sheet1.OLEObjects.Add(ClassType:=&QRMAKER.QRmakerCtrl.1&, Link:=False _
& && &&&, DisplayAsIcon:=False, Left:=15, Top:=10 + i * 70, Width:=140, Height:=70)
& & With QR.Object
& && &&&.AutoRedraw = ArOn
& && &&&.InputData = Sheet2.Cells(i, 7)
& & End With
'With Sheet1.OLEObjects.Add(ClassType:=&BARCODE.BarCodeCtrl.1&)
'& & .Object.Name = &BarCtrl& & i
'& & .Object.Style = BarStyle
'& & .Object.Value = Sheet2.Cells(i, 7).Value
'& & .Height = BarHigh
'& & .Width = BarWidth
'& & .Left = 15
'& & .Top = 10 + i * BarHigh
'End With
Next i
End Sub
复制代码
阅读权限95
在线时间 小时
1楼附件代码如下
QRMAKER.QRmakerCtrl.1 控件好像旡法指定字型大小喔
我自己在测试时是用Label控件，可指定字型种类和小大。
Sub AddBarcode()
Dim iCount&, i, QR
iCount = Sheet1.[A65536].End(xlUp).Row
For Each QR In Sheet1.Shapes
& & QR.Delete
Next QR
For i = 2 To iCount
& & Sheet1.Rows(i).RowHeight = 60
& & Set QR = Sheet1.OLEObjects.Add(ClassType:=&QRMAKER.QRmakerCtrl.1&, Link:=False _
& && &&&, DisplayAsIcon:=False, Left:=Sheet1.Cells(i, 3).Left, Top:=Sheet1.Cells(i, 3).Top, Width:=60, Height:=60)
& & With QR.Object
& && &&&.AutoRedraw = ArOn
& && &&&.InputData = Sheet1.Cells(i, 1)
& & End With
'With Sheet1.OLEObjects.Add(ClassType:=&BARCODE.BarCodeCtrl.1&)
'& & .Object.Name = &BarCtrl& & i
'& & .Object.Style = BarStyle
'& & .Object.Value = Sheet2.Cells(i, 7).Value
'& & .Height = BarHigh
'& & .Width = BarWidth
'& & .Left = 15
'& & .Top = 10 + i * BarHigh
'End With
Next i
End Sub
复制代码
阅读权限50
在线时间 小时
谢谢mineshine,不过我想达到的效果是用循环根据行号插入条形码,然后命名条形BarCtrl(i)...并且附值.
暂时遇到2个问题,一个是命名通不过,第二个是设置barcode属性的话提示要在设计模式下.
.Object.Name = BarCodeCtrl(i)
阅读权限50
在线时间 小时
RE: 2010条形码的问题(大致解决)
到最后也没有找到比较好的解决方式,但大致上排版打印了.留存,有备不时之需.
Option Explicit
Const BDstyle = 7
Const C_Width = 30
Const R_Height = 50
Private Sub Worksheet_Activate()
& &Dim WshShell As Object
& & Set WshShell = CreateObject(&Wscript.Shell&)
& & WshShell.RegWrite &HKCU\Software\Microsoft\Office\Common\Security\UFIControls&, 1, &REG_DWORD&
& & WshShell.RegWrite &HKCU\Software\Microsoft\VBA\Security\LoadControlsInForms&, 1, &REG_DWORD&
& & Set WshShell = Nothing
End Sub
Public Sub AddBarCode()
Dim MaxNumber%, i%
Dim rng As Range, RowControl%, ColumnControl%
Dim x1%, x2%, x3%, y%
Dim ShapeObj As Object
Sheet4.Activate
MaxNumber = Sheet3.[G65536].End(xlUp).Row - 1
For Each rng In ActiveSheet.Range(&A1&, &C& & MaxNumber)
&&With rng
&&.ColumnWidth = C_Width
&&.RowHeight = R_Height
&&End With
Next
With ActiveSheet
For i = 1 To MaxNumber
&&RowControl = Int(Application.RoundUp(i / 3, 0))
&&RowControl = RowControl * 3
&&ColumnControl = i Mod 3
& & If ColumnControl = 0 Then ColumnControl = ColumnControl + 3
&&x1 = RowControl - 2
&&y = ColumnControl
&&Set rng = .Cells(x1, y)
On Error Resume Next
Error.Clear
With Sheet4.OLEObjects.Add(ClassType:=&BARCODE.BarCodeCtrl.1&)
& & .Object.Style = BDstyle
& & .Object.Value = Sheet3.Cells(i + 1, 7)
& & .Height = rng.Height - 1
& & .Width = rng.Width - 1
& & 'LEFTÐè&O&&O&Shapes.fill.color&O&&I&&¼&A&C
& & .Left = rng.Left + 10
& & .Top = rng.Top + 2.5
& & .Object.lock = True
& & .Object.Color = xlNone
End With
&&x2 = RowControl - 1
With .Cells(x2, y)
& & .Value = Sheet3.Cells(i + 1, 8)
& & .HorizontalAlignment = xlCenter
& & .VerticalAlignment = xlTop
& & .WrapText = True
& & .Orientation = 0
& & .AddIndent = False
& & .IndentLevel = 0
& & .ShrinkToFit = False
& & .ReadingOrder = xlContext
& & .MergeCells = False
End With
& & For Each ShapeObj In .Shapes& & 'Shapes
& && &&&ShapeObj.Select
& && &&&ShapeObj.Fill.Visible = msoFalse
& & Next ShapeObj
End With
Set rng = Nothing
End Sub
Public Sub BarCode_Remove()
Dim Obj As Object
& & On Error Resume Next
Sheet4.Activate
& & For Each Obj In ActiveSheet.DrawingObjects
& && &&&Obj.Select
& && &&&Obj.Delete
& & Next Obj
End Sub复制代码
14:31 上传
点击文件名下载附件
69.11 KB, 下载次数: 261
阅读权限10
在线时间 小时
请问下。大神。
我在Excel基础界面可以看到条形码。然后打印预览时，却没有。该问题如何解决。
是用C# 导出的Excel
最新热点 /1
ExcelHome每周都有线上直播公开课，
国内一流讲师真身分享，高手贴身答疑，
赶不上直播还能看录像，
关键居然是免费的！
厚木哥们都已经这么努力了，
你还好意思说学不好Office。
玩命加载中，请稍候
玩命加载中，请稍候
Powered by
本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！ & & 本站特聘法律顾问：徐怀玉律师 李志群律师