纯vba生成二维码（可选择ANSI（GB2312）和UTF8，调整大小，纠错等级等）

amao47kiki2

因为自己使用的勤哲系统，没有批量生成二维码的功能。因此在excelhome上找了不少纯vba生成二维码的案例。对比后，发现大神们给的案例都没有完全适合我的。


一、只生成了UTF8格式的
[分享] 二维码生成工具(纯vba代码)
http://club.excelhome.net/thread-1096940-1-1.html

[求助] VBA 草料二维码
http://club.excelhome.net/thread-1437197-1-1.html



这两位大神给的案例，我测试了一下，只能生成UTF8的二维码，而我的扫描仪只识别GB2312的。但是优点就是能直接生成可调节大小的二维码，而且不用产生临时文件。


二、[分享] 二维码很火，分享EXCEL二维码插件。（已追加分享源码）
http://club.excelhome.net/thread-1044486-1-1.html

这位大神的案例，二维码放在窗体里面了，如果excel里面直接用image控件，获得的二维码是很模糊的，无法解决。但是这个案例，可以选择调节二维码的编码格式（ANSI和UTF8），ANSI是兼容GB2312的，所以这个案例，只要能改为类似前一个案例一样，生成图片格式的就可以符合我的要求了。

因此我查看了两者的二维码编码原理，这里省略500000字，实在看不懂，但是最后生成二维码方块的vba程序基本一致。于是我就着手改编优化。

废话不说，直接上案例！！






特别感谢excelhome这些大神的案例，给出的解决方案太好了！

amao47kiki2

接下来说说我修改后，这个案例里面的关键代码。


如上，是工程窗口。关键的、不影响二维码生成算法的sub，集中在“模块1”和“clsQRCode”。


模块1中的Function ByteArrayToPicture就是生成二维码点阵的。原作者是把这个点阵作为image的方法/属性，赋值给窗体中的image控件。

而我为了生成图片格式，参考了案例一中作者的做法——用把点阵放到剪贴板中，然后粘贴在sheet1中。代码如下：

1. Public Function ByteArrayToPicture(ByVal lp As Long, ByVal nWidth As Long, ByVal nHeight As Long, Optional ByVal nLeftPadding As Long, _
   
2.         Optional ByVal nTopPadding As Long, Optional ByVal nRightPadding As Long, Optional ByVal nBottomPadding As Long, Optional times As Double = 5) As StdPicture
   
3.     'times： 二维码图形放大倍数，函数缺省值为5   这个5倍基本够用，如果是1倍的话，二维码要变大的话，就容易模糊，5倍比较适中，可以自行调整。
   
4.    
   
5.     Dim tBMI As BITMAPINFO
   
6.     Dim h As Long, hdc As Long, hBmp As Long, wdth As Long, hght As Long
   
7.     Dim hbr As Long
   
8.     Dim r As RECT
   
9. 
   
10.     With tBMI.bmiHeader
    
11.         .biSize = 40&
    
12.         .biWidth = nWidth
    
13.         .biHeight = -nHeight
    
14.         .biPlanes = 1
    
15.         .biBitCount = 8
    
16.         .biSizeImage = nWidth * nHeight
    
17.         .biClrUsed = 256
    
18.     End With
    
19.     tBMI.bmiColors(0) = &HFFFFFF
    
20.     tBMI.bmiColors(2) = &H808080
    
21.     h = GetDC(0)
    
22.     hdc = CreateCompatibleDC(h)
    
23.     r.Right = Round((nWidth) * times) + nLeftPadding + nRightPadding
    
24.     r.Bottom = Round((nHeight) * times) + nTopPadding + nBottomPadding
    
25.     hBmp = CreateCompatibleBitmap(h, r.Right, r.Bottom)
    
26.     hbr = CreateSolidBrush(vbWhite)
    
27.     hBmp = SelectObject(hdc, hBmp)
    
28.     FillRect hdc, r, hbr
    
29.     DeleteObject hbr
    
30.     StretchDIBits hdc, nLeftPadding, nTopPadding, Round((nWidth) * times), Round((nHeight) * times), 0, 0, nWidth, nHeight, ByVal lp, tBMI, 0, 13369376
    
31.     hBmp = SelectObject(hdc, hBmp)
    
32.     DeleteDC hdc
    
33.     ReleaseDC 0, h
    
34.     Set ByteArrayToPicture = BitmapToPicture(hBmp, 1)
    
35.    
    
36.    
    
37. '以下就是参考案例http://club.excelhome.net/thread-1096940-1-1.html的放到剪贴板的做法。

复制代码

说实话，我是知其然而不知其所以然。应该是调用了api。因此最顶上的这一段是必须的！！！！
' Clipboard Manager Functions
Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long

amao47kiki2

空空空空空空空

amao47kiki2

另外，clsQRCode类模块中的Function Encode是原作者直接通过image控件调用的函数，应该是主程序。这个函数的最后条代码最重要：

1.         Set Encode = ByteArrayToPicture(VarPtr(B(0, 0)), nModuleSize, nModuleSize, 2, 2, 2, 2)  '边框4个宽为2

复制代码

这个代码就是调用刚刚ByteArrayToPicture的程序。其中那4个2就是二维码周边空白的区域边框大小，这个可以自行调节。

amao47kiki2

对于窗体的生成二维码按钮，我设置的代码是

1. Private Sub Command1_Click()
   
2.     Call 生成二维码(Sheet2.[D2], Sheet2.[D5], Sheet2.[E5], 50)
   
3.     Call 生成二维码(Sheet2.[I2], Sheet2.[I5], Sheet2.[J5], 50)
   
4. End Sub

复制代码

其中的sub 生成二维码带了几个参数。其中outputrange 、QRwidth是可选参数，QRwidth缺省值为90

1. Sub 生成二维码(inputrange As Range, pasterange As Range, Optional outputrange As Range, Optional outputrange As Integer = "90")
   
2. '    Dim inputrange As Range        '输入数据的单元格
   
3. '    Dim pasterange As Range        '粘贴二维码的单元格
   
4. '    Dim outputrange As Range       '显示二维码的值的单元格
   
5. '    Dim QRwidth As Integer         '二维码的大小

复制代码

10080

有没有办法生成PDF417码？

YZC51

谢谢楼主分享！先上鲜花一朵，以后补上！

amao47kiki2

10080 发表于 2019-6-15 15:47
有没有办法生成PDF417码？

可以参考
[求助] VBA 草料二维码
http://club.excelhome.net/thread-1437197-1-1.html

以及可以免费生成pdf417的网站
https://barcode.tec-it.com/zh/MobileQRCode

然后替换我程序中生成二维码图片的部分，应该就可以了。可以试试

YZC51

再顶墙贴！！！

blackttea1

谢谢楼主分享！