用宏命令批量生成二维码

new2654149

如图所示，我是使用QRmake来生成二维码，按钮做好以后发现我每次生成二维码必须先选中二维码下方的数字，按下按钮后才能生成二维码，并且只能单独操作，不能进行批量操作。我现在的需求是我按下按钮，所有的二维码能够一次性生成，求大神帮忙下，需要生成二维码的数字是引用另外一个工作表的：
=IF(MOD(ROW(A1),8)=1,OFFSET(排产单!AH$3,CEILING(ROW(A1)/8,1),0)&"","")
宏命令如下：
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Point01 As Long, Point02 As Long, Point03 As Long
Private i As Integer

Sub MakeQRCode()
    If Dir("D:\QRmake.exe") = "" Then
        MsgBox "QRmake.exe文件丢失，请确认！", vbCritical, "外部程序调用"
        Exit Sub
    End If
    i = MK_QR(ActiveCell.Value, "10", "4")
End Sub

Function MK_QR(Enc_Dat, ECL, SIZ)
    Dim F_Name As String
    F_Name = "[" & ActiveWorkbook.Name & "]" & ActiveSheet.Name & "!" & ActiveCell.Address
    Point01 = Shell("""" & "D:\QRmake.exe""" & " /S" & SIZ & " /L" & ECL + 1 & " /O""" & ThisWorkbook.Path & "\" & F_Name & ".bmp"" /T""" & Enc_Dat & """")
    Point02 = OpenProcess(&H100000, 1, Point01)
    Point03 = WaitForSingleObject(Point02, &HFFFFFFFF)
    Point03 = CloseHandle(Point02)
    Point01 = Empty
    Point02 = Empty
    Point03 = Empty
    ActiveCell.Offset(-4, 0).Select
    With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & F_Name & ".bmp")
        .Left = ActiveCell.Left
        .Top = ActiveCell.Top
    End With
    '将已经生成的二维码图像删除
    Kill (ThisWorkbook.Path & "\" & F_Name & ".bmp")
    ActiveCell.Offset(0, -1).Select
End Function

new2654149

自顶下。。求大佬帮一下忙。。拜谢

lzqlaj

Sub MakeQRCode()
    If Dir("D:\QRmake.exe") = "" Then
        MsgBox "QRmake.exe文件丢失，请确认！", vbCritical, "外部程序调用"
        Exit Sub
    End If
    For k = 1 To 10000
        i = MK_QR(Cells(7 + 8 * (k - 1), 6), "10", "4")
    Next k
End Sub

jiaxinl

new2654149 发表于 2017-7-20 16:51
自顶下。。求大佬帮一下忙。。拜谢

批量生成二维码

代码如下，请看以下代码中涂颜色的部分，就不上附件了


Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Point01 As Long, Point02 As Long, Point03 As Long
Private i As Integer

Sub MakeQRCode()
Dim k%, r%, Shp As Shape  '声明相关变量
Application.ScreenUpdating = False  '禁止屏幕刷新
    If Dir("D:\QRmake.exe") = "" Then
        MsgBox "QRmake.exe文件丢失，请确认！", vbCritical, "外部程序调用"
        Exit Sub
    End If
    With Sheet1
        For Each Shp In .Shapes '在所有图形中遍历
            If Shp.Type = 11 Then Shp.Delete  '删除之前已生成的二维码图片
        Next Shp
        On Error Resume Next
        r = .Range("A" & .Cells(Rows.Count, 1).End(xlUp).Row) '在A列最后一个非空单元格的值中循环
        If Err <> 0 Then MsgBox "请检查在A列最后一个非空单元格的值有错误值！", 16, "错误提示": Exit Sub
        For k = 1 To r   '循环进行批量生成二维码图片
            .Cells(7 + 8 * (k - 1), 6).Select  '选择需要生成二维码的数字的单元格
            i = MK_QR(.Cells(7 + 8 * (k - 1), 6), "10", "4")
        Next k
    End With
    MsgBox "批量生成二维码已完成！" & Chr(13) & "     共生成 " & k - 1 & "个", , "提示"
Application.ScreenUpdating = True  '启动屏幕刷新
End Sub

Function MK_QR(Enc_Dat, ECL, SIZ)
    Dim F_Name As String
    F_Name = "[" & ActiveWorkbook.Name & "]" & ActiveSheet.Name & "!" & ActiveCell.Address
    Point01 = Shell("""" & "D:\QRmake.exe""" & " /S" & SIZ & " /L" & ECL + 1 & " /O""" & ThisWorkbook.Path & "\" & F_Name & ".bmp"" /T""" & Enc_Dat & """")
    Point02 = OpenProcess(&H100000, 1, Point01)
    Point03 = WaitForSingleObject(Point02, &HFFFFFFFF)
    Point03 = CloseHandle(Point02)
    Point01 = Empty
    Point02 = Empty
    Point03 = Empty
    ActiveCell.Offset(-4, 0).Select
    With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & F_Name & ".bmp")
        .Left = ActiveCell.Left
        .Top = ActiveCell.Top
    End With
    Kill (ThisWorkbook.Path & "\" & F_Name & ".bmp") '将已经生成的二维码图像删除
    'ActiveCell.Offset(0, -1).Select  '此句可删除
End Function

new2654149

jiaxinl 发表于 2017-7-20 21:47
批量生成二维码

代码如下，请看以下代码中涂颜色的部分，就不上附件了

您好，非常感谢您的帮助，我现在还有个小问题，你代码中是在A列最后一个非空单元格值中循环，而我表格内数据是要在别的表格内引用的，在下方肯定会有长串空的单元格出现。这样的情况我应该如何修改代码，谢谢！

new2654149

如图所示。

jiaxinl

new2654149 发表于 2017-7-21 09:49
如图所示。

你A列中不是用公式编好序号了吗？
只要你A列中排序号的公式不出错就行
其实你I列也是等于A列中编好的序号吗
你编好的序号其实就是要批量生成二维码的个数

我发的代码你可以直接拿来用，不用再修改
只要你A列中排序号的公式不出错就行

new2654149

jiaxinl 发表于 2017-7-21 10:17
你A列中不是用公式编好序号了吗？
只要你A列中排序号的公式不出错就行
其实你I列也是等于A列中编好的 ...

实际情况是如果我不把空表格删除的话，还是会有错误提醒

jiaxinl

new2654149 发表于 2017-7-21 10:24
实际情况是如果我不把空表格删除的话，还是会有错误提醒

有可能是你A列中非空单元格的下面的单元格中有可以存在空格或其他不可见的字符(这样的单元格属于假空)

进行测试A列是否存在假空的单元格
你可以先选择A列，然后按Ctrl+G 定位
定位条件  选择空值

你可以把A列改为I列试试看会不会出现错误提示

  r = .Range("A" & .Cells(Rows.Count, 1).End(xlUp).Row) '在A列最后一个非空单元格的值中循环

改为:

r = .Range("I" & .Cells(Rows.Count, 9).End(xlUp).Row) '在I列最后一个非空单元格的值中循环

new2654149

jiaxinl 发表于 2017-7-21 10:29
有可能是你A列中非空单元格的下面的单元格中有可以存在空格或其他不可见的字符(这样的单元格属于假空)
...

我检查了下前面都是对的
到这一行就不对了我只要把这一行后面的删了，才能够不出现问题，改成I列也没有用的