Excel一键生成炫彩二维码

技术文章大纲：VBA实现动态二维码生成（GenQRCode模块）

模块功能概述

通过API实现Excel VBA二维码生成
支持自定义文本、尺寸、颜色等参数
自动处理URL编码和错误校验

核心代码结构解析

Attribute VB_Name声明模块名称
Option Explicit强制变量声明规范
主过程GenQRCode的Sub定义

参数输入与校验机制

文本输入校验（空值处理）
尺寸参数验证（数值有效性检查）
颜色格式校验（IsHexString函数）
容错率枚举值限制（L/M/Q/H）

API调用技术细节

第三方QR Code API接口说明
URL参数拼接规范（size/color/ecc等）
UTF-8字符编码处理（URLEncode函数）
网络请求错误处理机制

图像插入与格式控制

Shapes.AddPicture方法应用
锁定宽高比（LockAspectRatio属性）
像素尺寸精确控制

辅助函数实现

IsHexString十六进制校验算法
URLEncode的流处理技术
ADODB.Stream对象的使用

异常处理设计

On Error跳转机制
网络连接失败提示
参数格式错误回退策略

应用场景扩展

工作表事件绑定建议
批量生成二维码方案
企业内网API替代方案

性能优化方向

缓存机制实现
异步加载方案
本地二维码生成库对比

安全注意事项

敏感信息传输风险
API服务稳定性建议
离线备用方案设计

（注：实际文章中每个章节应包含代码片段、参数说明和效果演示图）

bash 复制代码

Attribute VB_Name = "GenQRCode"
Option Explicit
 
Sub GenQRCode()
    ' --- 用户自定义参数 ---
    Dim Text As String
    Dim size As Integer
    Dim targetSheet As Worksheet
    Dim targetCell As Range
    
    ' 1. 输入要生成二维码的文本
    Text = InputBox("请输入要生成二维码的文本：", "二维码文本输入", "生成二维码")
    If Text = "" Then
        MsgBox "未输入任何文本，已取消生成二维码！", vbInformation
        Exit Sub
    End If
 
    ' 2. 输入基础尺寸（默认200x200）
    size = val(InputBox("请输入二维码尺寸（像素，如200）：", "二维码尺寸设置", 200))
    If size <= 0 Then size = 200 ' 校验：输入非正数则用默认值
    
    ' 3. 输入样式参数（带默认值+格式校验）
    Dim foreColor As String     ' 前景色（二维码颜色）
    Dim bgColor As String       ' 背景色
    Dim margin As Integer       ' 边框宽度
    Dim eccLevel As String      ' 容错率
    
    ' 3.1 前景色（6位十六进制，默认蓝色0066CC）
    foreColor = UCase(InputBox("请输入二维码前景色（6位十六进制，如FF0000=红色）：", "前景色设置", "0066CC"))
    ' 校验：非6位则用默认值
    If Len(foreColor) <> 6 Or Not IsHexString(foreColor) Then
        foreColor = "0066CC"
        MsgBox "前景色格式错误，已自动使用默认值：0066CC（蓝色）", vbExclamation
    End If
    
    ' 3.2 背景色（6位十六进制，默认白色FFFFFF）
    bgColor = UCase(InputBox("请输入二维码背景色（6位十六进制，如FFFFFF=白色）：", "背景色设置", "FFFFFF"))
    If Len(bgColor) <> 6 Or Not IsHexString(bgColor) Then
        bgColor = "FFFFFF"
        MsgBox "背景色格式错误，已自动使用默认值：FFFFFF（白色）", vbExclamation
    End If
    
    ' 3.3 边框宽度（像素，默认0=无边框）
    margin = val(InputBox("请输入二维码边框宽度（像素，0=无边框）：", "边框宽度设置", 0))
    If margin < 0 Then margin = 0 ' 校验：负数则用默认值
    
    ' 3.4 容错率（默认H，仅支持L/M/Q/H）
    eccLevel = UCase(InputBox("请输入容错率（L/M/Q/H，H=最高容错）：", "容错率设置", "H"))
    If Not (eccLevel = "L" Or eccLevel = "M" Or eccLevel = "Q" Or eccLevel = "H") Then
        eccLevel = "H"
        MsgBox "容错率格式错误，已自动使用默认值：H（高容错）", vbExclamation
    End If
    
    ' 4. 工作表和位置参数（固定，也可改为InputBox）
    Set targetSheet = ThisWorkbook.ActiveSheet
    Set targetCell = targetSheet.Range("B2")
    ' --- 参数定义结束 ---
 
    ' API基础地址
    Dim apiUrl As String
    apiUrl = "https://api.qrserver.com/v1/create-qr-code/"
 
    ' URL编码文本（解决中文乱码）
    Dim encodedText As String
    encodedText = URLEncode(Text)
 
    ' 拼接完整请求URL（包含所有自定义样式参数）
    Dim fullUrl As String
    fullUrl = apiUrl & "?data=" & encodedText & _
              "&size=" & size & "x" & size & _
              "&charset-source=UTF-8" & _
              "&color=" & foreColor & _
              "&bgcolor=" & bgColor & _
              "&margin=" & margin & _
              "&ecc=" & eccLevel
 
    ' 下载并插入二维码图片
    On Error GoTo ErrorHandler
    Dim pic As Object
    Set pic = targetSheet.Shapes.AddPicture( _
        fullUrl, msoFalse, msoCTrue, _
        targetCell.Left, targetCell.Top, -1, -1)
 
    ' 调整图片大小（锁定宽高比）
    pic.LockAspectRatio = msoTrue
    pic.Width = size
 
    ' 提示生成成功并显示参数
    MsgBox "二维码已成功生成！" & vbCrLf & _
           "尺寸：" & size & "x" & size & "像素" & vbCrLf & _
           "前景色：" & foreColor & " 背景色：" & bgColor & vbCrLf & _
           "边框：" & margin & "像素 容错率：" & eccLevel, vbInformation
    Exit Sub
 
ErrorHandler:
    MsgBox "生成二维码失败！请检查：" & vbCrLf & _
           "1. 电脑是否能正常上网。" & vbCrLf & _
           "2. 输入的参数是否符合格式要求。", vbCritical
End Sub
 
' --- 辅助函数：校验是否为十六进制字符串 ---
Private Function IsHexString(ByVal str As String) As Boolean
    Dim i As Integer
    IsHexString = True
    For i = 1 To Len(str)
        Select Case Mid(str, i, 1)
            Case "0" To "9", "A" To "F"
                ' 合法十六进制字符，继续
            Case Else
                IsHexString = False
                Exit Function
        End Select
    Next i
End Function
 
' --- 保留原有URLEncode函数，无需修改 ---
Private Function URLEncode(ByVal Text As String) As String
    Dim adoStream As Object
    Dim encoded As String
 
    On Error GoTo CleanUp
    Set adoStream = CreateObject("ADODB.Stream")
 
    adoStream.Type = 2 ' adTypeText
    adoStream.Charset = "UTF-8"
    adoStream.Open
    adoStream.WriteText Text
    adoStream.Position = 0
    adoStream.Type = 1 ' adTypeBinary
 
    Do Until adoStream.EOS
        Dim byteHex As String
        byteHex = Hex(AscB(adoStream.Read(1)))
        If Len(byteHex) = 1 Then byteHex = "0" & byteHex
        encoded = encoded & "%" & byteHex
    Loop
 
    adoStream.Close
    Set adoStream = Nothing
    encoded = Replace(encoded, "%20", "+")
    URLEncode = encoded
    Exit Function
 
CleanUp:
    If Not adoStream Is Nothing Then
        adoStream.Close
        Set adoStream = Nothing
    End If
    URLEncode = Text
End Function