使用 VBA Excel 生成二维码

Question

我正在使用此代码在 excel 中生成二维码。但是，如果 QR 已经存在，则仅当 QR 不在列 "example: F2" 中时，我才能生成它跳转到下一个单元格。因为每当我单击生成按钮并使其与 old/present QR 重叠时，它就会不断生成。很高兴有人能帮我解决这个问题。因为我已经被困在这里大约一个星期了。

Option Explicit

Public Sub QRGEN()

Sheet2.Activate
Dim c       As Range

Dim lRow    As Long
lRow = WorksheetFunction.Max(2, Cells(Rows.Count, 1).End(xlUp).Row)
For Each c In Range("F2:F" & lRow)
If c.Offset(0, -1) <> "" Then
    MakeQRCode sData:=c.Offset(0, -1).Text, _
    iForeCol:=vbBlack, iBackCol:=vbWhite, iSize:=60, cell:=c

End If

Next c

End Sub


Function MakeQRCode(sData As String, iForeCol As Long, iBackCol As Long, _
               ByVal iSize, cell As Range) As Boolean
Dim iPic          As Long
Dim sPic          As String
Dim oPic          As Picture
Dim sURL          As String

On Error Resume Next

Do
Set oPic = Nothing
iPic = iPic + 1
sPic = "QRCode(" & iPic & ")"
Set oPic = cell.Worksheet.Pictures(sPic)
Loop While Not oPic Is Nothing
err.Clear

If iSize > 1000 Then iSize = 1000
If iSize < 10 Then iSize = 10

sURL = "https://api.qrserver.com/v1/create-qr-code/?" & _
     "&data=" & sData & _
     "&size=" & iSize & "x" & iSize & _
     "&charset-source=UTF-8" & _
     "&charset-target=UTF-8" & _
     "&ecc=L" & _
     "&color=" & sRGB(iForeCol) & _
     "&bgcolor=" & sRGB(iBackCol) & _
     "&margin=0" & _
     "&qzone=1" & _
     "&format=png"
' Debug.Print sURL

With cell.Worksheet.Pictures.Insert(sURL)
.Name = sPic
.Left = cell.Left + 10.5
.Top = cell.Top + 4
End With

MakeQRCode = err.Number = 0
End Function

Function sRGB(iRGB As Long) As String
' converts an RGB long to RRGGBB
sRGB = Right("00000" & Hex(iRGB), 6)
sRGB = Right(sRGB, 2) & Mid(sRGB, 3, 2) & Left(sRGB, 2)
End Function

Answer 1

最简单但不是最优雅的方法是在 Sub QRGEN() 过程之上添加下一个代码：

Dim sh As Shape
 For Each sh In ActiveSheet.Shapes
    If InStr(sh.Name, "QRCode") > 0 Then sh.Delete
 Next

这将删除您所有的 QRCode 形状并重新处理所有内容，但会浪费时间...

更好的解决方案是创建一个能够查找 QRCode 图片的函数，检查它的 Top 属性，是否是 cell.Top + 4 中的一个，就像它已经在运行代码中定义。问题是如果你移动图片，代码将不会 return 正确的结果。所以，添加下一个函数：

Function testQRCodeExistence(cell As Range) As Boolean
    Dim sh As Shape
    For Each sh In ActiveSheet.Shapes
        If sh.top = cell.top + 4 Then testQRCodeExistence = True: Exit For
    Next
End Function

并在现有代码中添加这一行（容易理解的地方...）：

If c.Offset(0, -1) <> "" Then
    If Not testQRCodeExistence(c) Then
        MakeQRCode sData:=c.Offset(0, -1).Text, _
          iForeCol:=vbBlack, iBackCol:=vbWhite, iSize:=70, cell:=c
    End If
End If

但最好的解决办法是用不同的方式命名二维码图片。比如要命名为"QRCode" & Cell.Address... 因此，以这种方式调整命名部分：

Do
    sPic = "QRCode(" & cell.Address & ")"
    Set oPic = cell.Worksheet.Pictures(sPic)
Loop While Not oPic Is Nothing

新建函数查找二维码图片名称中的Cell.Addres：

Function checkQRPictExistence(cell As Range) As Boolean
    Dim sh As Shape
    For Each sh In ActiveSheet.Shapes
        If InStr(sh.Name, cell.Address) > 0 Then checkQRPictExistence = True: Exit For
    Next
End Function

并像上面的方法一样插入检查行，但使用最后一个函数：

If c.Offset(0, -1) <> "" Then
    If Not checkQRPictExistence(c) Then
        MakeQRCode sData:=c.Offset(0, -1).Text, _
          iForeCol:=vbBlack, iBackCol:=vbWhite, iSize:=70, cell:=c
    End If
End If

使用 VBA Excel 生成二维码

Generate QR using VBA Excel

excel

vba

qr-code