自动批量生成条形码，可能你用得上，欢迎进来看看

huang1314wei · 发表于 2015-8-14 12:49

昨天在回答一个坛友的提问，提问网址如下：http://club.excelhome.net/forum. ... ead&tid=1223409
刚开始以为挺简单，因为之前有弄过条形码，用字体生成的，论坛里面也有不少关于条形码生成的例子，比如这个二岁老师提供的方法
http://club.excelhome.net/forum. ... ertype=1&page=6
百度也搜了一下，多数都是下载条码字体包，然后放到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=""http://barcode.cnaidc.com/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

复制代码

以下是附件，宏工程无密码，可以直接查看源码

自动批量生成条形码.rar (20.52 KB, 下载次数: 7942)

huang1314wei · 发表于 2016-12-23 16:40

本帖最后由 huang1314wei 于 2016-12-26 21:34 编辑

fbcli 发表于 2016-12-23 16:27
大神求助，程序运行是下列出错，提示不能去的类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=""http://apps.99wed.com/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

复制代码

更新的附件如下，请下载新附件使用

批量生成条形码（2016-12-26更新）.rar (20.17 KB, 下载次数: 3627)

huang1314wei · 发表于 2017-4-13 20:10

本帖最后由 huang1314wei 于 2017-5-6 16:05 编辑

新的方法批量生成条形码请看下面连接，无须借助网络即可批量生成条形码的方法
http://club.excelhome.net/thread-1339950-1-1.html

huang1314wei · 发表于 2015-8-14 16:11

代码当中获取条形码图片是根据这个网站获取的
http://barcode.cnaidc.com/html/BCGcode39.php

范德萨 · 发表于 2015-8-25 14:20

非常好用，收藏

Janxy · 发表于 2015-8-25 14:24

如果源数据为文本，貌似不可以直接生成的哦？比如在文本列录入0600012345（10位数且开头为0）的数据，应该怎么样设置宏文本呢？谢谢!

huang1314wei · 发表于 2015-8-25 15:17

Janxy 发表于 2015-8-25 14:24
如果源数据为文本，貌似不可以直接生成的哦？比如在文本列录入0600012345（10位数且开头为0）的数据，应该 ...

不受影响，可以生成，如图

Janxy · 发表于 2015-8-25 15:24

追加问题：我要在J列Barcode那列批量生成附表的B列10位文本数字（开头为0）的条形码，便于打印，这个宏应当怎么编辑呢？

Barcode Batch Generator.zip (7.77 KB, 下载次数: 579)

Janxy · 发表于 2015-8-25 15:35

huang1314wei 发表于 2015-8-25 15:17
不受影响，可以生成，如图

谢谢大神的回复，我后面试过了可以生成，但我自己不会编辑宏，我想学会怎么去编辑宏里面的文本，对了，怎么可以给你的帖子评分呢？{:soso_e100:}

huang1314wei · 发表于 2015-8-25 15:59

Janxy 发表于 2015-8-25 15:24
追加问题：我要在J列Barcode那列批量生成附表的B列10位文本数字（开头为0）的条形码，便于打印，这个宏应当 ...

把我的源代码稍微改一下，就可以适合你的表格了，附件如下：（运行的时候可能会有点慢，跟网速有关，请耐心等待运行完成）

Barcode Batch Generator.rar (19.32 KB, 下载次数: 1127)

VBA万岁 · 发表于 2015-8-26 15:56

本帖最后由 VBA万岁于 2015-8-26 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="http://barcode.cnaidc.com/html/cnaidc.php?filetype=PNG&dpi=72&scale=1&rotation=0&font_family=Arial.ttf&font_size=14&text">http://barcode.cnaidc.com/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="http://barcode.cnaidc.com/html/cnaidc.php?filetype=PNG&dpi=72&scale=1&rotation=0&font_family=Arial.ttf&font_size=14&text">http://barcode.cnaidc.com/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>

复制代码

VBA万岁 · 发表于 2015-8-26 16:19

VBA万岁发表于 2015-8-26 15:56
以下第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=""http://barcode.cnaidc.com/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 = "http://barcode.cnaidc.com/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

复制代码

		自动登录	找回密码
密码			免费注册

[分享] 自动批量生成条形码，可能你用得上，欢迎进来看看

评分

评分

评分

评分