vba实现二维码code-128码和code-39码

林程乐

这是从网上搜索来的放在一起。vba实现二维码code-128码和code-39码，里面没有api函数所以兼容64位和32位excel。代码简洁，清楚。运行速度快。就是生成的不是图片格式的。那位高手有能力将其转生成成图片。也改成批量生成。分享给大家。

改好了。安照高手liu0wei2008的思路加入了字典收集线条。后复制成图片。失去了X.Y坐标。用选择单元格来实现批量生成。等下上传附件。各位看看有什么要改进的地方，耗时一天半。本人vba只学了一点点。上传了附件，在17楼。

wcj6376tcp

循环给你调试好了
Sub test128()
    Set ws = ThisWorkbook.ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Call 清除
    For i = 1 To lastRow
    Call Code128Generate(52, 18 * (i - 1) + 2, 14, 2, ThisWorkbook.Sheets(1), Range("a" & i).Text)
    Next i
End Sub

林程乐

wcj6376tcp 发表于 2024-12-8 19:05
循环给你调试好了
Sub test128()
    Set ws = ThisWorkbook.ActiveSheet

感谢wcj6376tcp老师的代码，批量生成可以了，成生的不是一张图片的格式，生成的是一条一条的线条。我找到了不少api函数，改成图片没有成功。等下我上传一些api函数附件。请请参考一下，看看有什么办法。改成整张图片。

林程乐

各位老师。这是收集的一些api函数。兼容64位和32位提供参考。

林程乐

林程乐 发表于 2024-12-9 09:18
各位老师。这是收集的一些api函数。兼容64位和32位提供参考。

我试过将这几句代码加到最后，但不知道如何加，没有加成功。

wcj6376tcp

林程乐 发表于 2024-12-9 11:27
我试过将这几句代码加到最后，但不知道如何加，没有加成功。

条形码是很多线条组合成的，无法复制图形

wcj6376tcp

只能看哪位大师能否采取截图区域另存为图片看看得行不

liu0wei2008

1. Dim arr As Object
   
2. Set arr = CreateObject("scripting.dictionary")
   
3. For i = 1 To Len(ContentString)
   
4.     Select Case Mid(ContentString, i, 1)
   
5.     Case 0
   
6.         CurBar = CurBar + 1
   
7.     Case 1
   
8.         CurBar = CurBar + 1
   
9. ' (CurBar * LineWeight) * [B]0.9[/B] -  here is 10% overlapping :-)
   
10.         With TargetSheet.Shapes.AddLine(X + (CurBar * LineWeight) * 0.9, Y, X + (CurBar * LineWeight) * 0.9, (Y + Height)).Line
    
11.         .Weight = LineWeight
    
12.         .ForeColor.RGB = vbBlack ' my Excel writes light-blue lines by default, so the color is forcibly switched
    
13.         arr(.Parent.Name) = .Parent.Name
    
14.         End With
    
15.     End Select
    
16. Next i
    
17. all = arr.items
    
18. For i = 0 To arr.Count - 1
    
19.     ActiveSheet.Shapes(all(i)).Select Replace:=False
    
20. Next
    
21. With Selection.ShapeRange.Group
    
22.     .Select
    
23.     ActiveSheet.Shapes(Selection.Name).SaveAsPicture "D:\\桌面\" + Selection.Name + ".png"
    
24. End With

复制代码

循环什么的你来加吧，路径自己改下，代码放到CurBar = 0这句后面，这是Code128的

wcj6376tcp

liu0wei2008 发表于 2024-12-9 15:02
循环什么的你来加吧，路径自己改下，代码放到CurBar = 0这句后面，这是Code128的

现在 pic.tpye=6  是msoGroup了  ActiveSheet.Shapes(Selection.Name).SaveAsPicture "D:\\桌面\" + Selection.Name + ".png" 这句无法执行SaveAsPicture

林程乐

liu0wei2008 发表于 2024-12-9 15:02
循环什么的你来加吧，路径自己改下，代码放到CurBar = 0这句后面，这是Code128的

您好，卡在这一句ActiveSheet.Shapes(Selection.Name).SaveAsPicture "D:\\桌面\" + Selection.Name + ".png"
没有运行下去。看网上代码他们的思路是Dim grp As Variant   Set grp = ActiveSheet.Shapes.Range(shapeArr).Group将所有形状分组到一个单元中然后，grp.copy复制。然后选择活动工作表Worksheet.Select用这句复制成矢量图到单元格中Worksheet.PasteSpecial Format:="Picture (Enhanced Metafile)", Link:=False, DisplayAsIcon:=False然后再删除grp.Delete。但是shapeArr需要生成各条形状的名称，不知道如何搞了。