ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 126946|回复: 140

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

  [复制链接]

TA的精华主题

TA的得分主题

发表于 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等类型的条形码,代码如下:
  1. Sub 生成条码()
  2.     Dim i%, str1$, str2$, str3$, d As Object
  3.     Set d = New DataObject
  4.     Application.ScreenUpdating = False
  5.     If Application.CountA(Range("A:A")) = 0 Then
  6.         MsgBox "A列单号为空,程序退出!"
  7.         Exit Sub
  8.     Else
  9.     i = Range("A1048576").End(xlUp).Row
  10.     For j = 1 To i
  11.       If Cells(j, 1) <> "" Then
  12.         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="
  13.         str2 = "&thickness=30&checksum=&code=BCGcode39"" > "
  14.         str3 = str3 & str1 & Cells(j, 1) & str2 & Chr(10)
  15.       End If
  16.     Next
  17.     d.SetText str3
  18.     d.PutInClipboard
  19.     Range("B1").Select
  20.     ActiveSheet.PasteSpecial Format:="Unicode 文本", Link:=False, DisplayAsIcon:=False
  21.     Columns(1).HorizontalAlignment = xlCenter
  22.     Columns(1).VerticalAlignment = xlCenter
  23.     Rows(1 & ":" & i).RowHeight = ActiveSheet.Pictures(1).Height
  24.     Columns(2).ColumnWidth = ActiveSheet.Pictures(1).Width / 6.13
  25.     End If
  26.     Application.ScreenUpdating = True
  27. End Sub
复制代码
以下是附件,宏工程无密码,可以直接查看源码
自动批量生成条形码.rar (20.52 KB, 下载次数: 7907)

评分

7

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-12-23 16:40 | 显示全部楼层
本帖最后由 huang1314wei 于 2016-12-26 21:34 编辑
fbcli 发表于 2016-12-23 16:27
大神求助,程序运行是下列出错,提示不能去的类worksheet的pictures属性

Rows(4 & ":" & i).RowHeight ...

一楼代码及附件由于网站规则改变,导致不能使用,现更新代码如下:

  1. Sub 生成条码()
  2.     Dim i%, str1$, str2$, str3$, d As Object
  3.     Set d = New DataObject
  4.     Application.ScreenUpdating = False
  5.     If Application.CountA(Range("A:A")) = 0 Then
  6.         MsgBox "A列单号为空,程序退出!"
  7.         Exit Sub
  8.     Else
  9.     i = Range("A1048576").End(xlUp).Row
  10.     For j = 1 To i
  11.       If Cells(j, 1) <> "" Then
  12.         str1 = "<table><img src=""http://apps.99wed.com/360app/barcode/barcode.php?codebar=BCGcode128&text="
  13.         str2 = "&resolution=2&thickness=30"" > "
  14.         str3 = str3 & str1 & Cells(j, 1) & str2 & Chr(10)
  15.       End If
  16.     Next
  17.     d.SetText str3
  18.     d.PutInClipboard
  19.     Range("B1").Select
  20.     ActiveSheet.PasteSpecial Format:="Unicode 文本", Link:=False, DisplayAsIcon:=False
  21.     Columns(1).HorizontalAlignment = xlCenter
  22.     Columns(1).VerticalAlignment = xlCenter
  23.     Rows(1 & ":" & i).RowHeight = ActiveSheet.Pictures(1).Height
  24.     Columns(2).ColumnWidth = ActiveSheet.Pictures(1).Width / 6.13
  25.     End If
  26.     Application.ScreenUpdating = True
  27. End Sub
复制代码

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

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

评分

6

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-4-13 20:10 | 显示全部楼层
本帖最后由 huang1314wei 于 2017-5-6 16:05 编辑

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

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-8-14 16:11 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2015-8-25 14:20 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2015-8-25 14:24 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
如果源数据为文本,貌似不可以直接生成的哦?比如在文本列录入0600012345(10位数且开头为0)的数据,应该怎么样设置宏文本呢?谢谢!

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-8-25 15:17 | 显示全部楼层
Janxy 发表于 2015-8-25 14:24
如果源数据为文本,貌似不可以直接生成的哦?比如在文本列录入0600012345(10位数且开头为0)的数据,应该 ...

不受影响,可以生成,如图
123.jpg

TA的精华主题

TA的得分主题

发表于 2015-8-25 15:24 | 显示全部楼层
追加问题:我要在J列Barcode那列批量生成附表的B列10位文本数字(开头为0)的条形码,便于打印,这个宏应当怎么编辑呢? Barcode Batch Generator.zip (7.77 KB, 下载次数: 576)

TA的精华主题

TA的得分主题

发表于 2015-8-25 15:35 | 显示全部楼层
huang1314wei 发表于 2015-8-25 15:17
不受影响,可以生成,如图

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

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-8-25 15:59 | 显示全部楼层
Janxy 发表于 2015-8-25 15:24
追加问题:我要在J列Barcode那列批量生成附表的B列10位文本数字(开头为0)的条形码,便于打印,这个宏应当 ...

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

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






评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2015-8-26 15:56 | 显示全部楼层
本帖最后由 VBA万岁 于 2015-8-26 16:06 编辑

以下第2段代码是用Excel矩形加载网页条码图片的,不知条码枪能否识别?

  1. <P>Sub 生成条码()
  2. Dim i%, str1$, str2$, str3$, d As Object
  3. Set d = New DataObject
  4. Application.ScreenUpdating = False
  5. If Application.CountA(Range("A:A")) = 0 Then
  6.     MsgBox "A列单号为空,程序退出!"
  7.     Exit Sub
  8. Else
  9.     i = Range("A1048576").End(xlUp).Row
  10.     For j = 1 To i
  11.       If Cells(j, 1) <> "" Then
  12.         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>="
  13.         str2 = "&thickness=30&checksum=&code=BCGcode39"" ></table> "
  14.         str3 = str3 & str1 & Cells(j, 1) & str2 & Chr(10)
  15.       End If
  16.     Next
  17.     d.SetText str3
  18.     d.PutInClipboard
  19.     Range("B" & Range("A1").End(xlDown).Row).Select
  20.     ActiveSheet.Paste
  21.     Rows(1 & ":" & i).RowHeight = ActiveSheet.Pictures(1).Height
  22.     Columns(2).ColumnWidth = ActiveSheet.Pictures(1).Width / 5.13
  23. End If
  24. Application.ScreenUpdating = True
  25. End Sub</P>
  26. <P>Sub 生成条码2()
  27. Dim Shp
  28. For Each Shp In ActiveSheet.Shapes
  29.     If Left(Shp.Name, 6) <> "Button" Then Shp.Delete
  30. Next
  31. Rows(Range("A1").End(xlDown).Row & ":" & Cells(Rows.Count, 1).End(xlUp).Row).RowHeight = 51.25
  32. For Each cel In Range("a" & Range("A1").End(xlDown).Row & ":a" & Cells(Rows.Count, 1).End(xlUp).Row)
  33.     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>="
  34.     str2 = "&thickness=30&checksum=&code=BCGcode39"
  35.     cel.Offset(, 2).Select
  36.     ActiveSheet.Shapes.AddShape(msoShapeRectangle, cel.Offset(, 2).Left, cel.Offset(, 2).Top, cel.Offset(, 2).Width, cel.Offset(, 2).Height).Select
  37.     Selection.ShapeRange.Fill.UserPicture str1 & cel.Value & str2
  38. Next
  39. End Sub
  40. </P>
复制代码

TA的精华主题

TA的得分主题

发表于 2015-8-26 16:19 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
VBA万岁 发表于 2015-8-26 15:56
以下第2段代码是用Excel矩形加载网页条码图片的,不知条码枪能否识别?

重传代码:
  1. Sub 生成条码()
  2. Dim i%, str1$, str2$, str3$, d As Object
  3. Set d = New DataObject
  4. Application.ScreenUpdating = False
  5. If Application.CountA(Range("A:A")) = 0 Then
  6.     MsgBox "A列单号为空,程序退出!"
  7.     Exit Sub
  8. Else
  9.     i = Range("A1048576").End(xlUp).Row
  10.     For j = 1 To i
  11.       If Cells(j, 1) <> "" Then
  12.         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="
  13.         str2 = "&thickness=30&checksum=&code=BCGcode39"" ></table> "
  14.         str3 = str3 & str1 & Cells(j, 1) & str2 & Chr(10)
  15.       End If
  16.     Next
  17.     d.SetText str3
  18.     d.PutInClipboard
  19.     Range("B" & Range("A1").End(xlDown).Row).Select
  20.     ActiveSheet.Paste
  21.     Rows(1 & ":" & i).RowHeight = ActiveSheet.Pictures(1).Height
  22.     Columns(2).ColumnWidth = ActiveSheet.Pictures(1).Width / 5.13
  23. End If
  24. Application.ScreenUpdating = True
  25. End Sub

  26. Sub 生成条码2()
  27. Dim Shp
  28. For Each Shp In ActiveSheet.Shapes
  29.     If Left(Shp.Name, 6) <> "Button" Then Shp.Delete
  30. Next
  31. Rows(Range("A1").End(xlDown).Row & ":" & Cells(Rows.Count, 1).End(xlUp).Row).RowHeight = 51.25
  32. For Each cel In Range("a" & Range("A1").End(xlDown).Row & ":a" & Cells(Rows.Count, 1).End(xlUp).Row)
  33.     str1 = "http://barcode.cnaidc.com/html/cnaidc.php?filetype=PNG&dpi=72&scale=1&rotation=0&font_family=Arial.ttf&font_size=14&text="
  34.     str2 = "&thickness=30&checksum=&code=BCGcode39"
  35.     cel.Offset(, 2).Select
  36.     ActiveSheet.Shapes.AddShape(msoShapeRectangle, cel.Offset(, 2).Left, cel.Offset(, 2).Top, cel.Offset(, 2).Width, cel.Offset(, 2).Height).Select
  37.     Selection.ShapeRange.Fill.UserPicture str1 & cel.Value & str2
  38. Next
  39. End Sub
复制代码

评分

1

查看全部评分

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 18:11 , Processed in 0.057509 second(s), 12 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表