请求修复VBA图片下载脚本：基于D列关键词插入谷歌首图至单元格

需求描述 #

需要一个VBA脚本，根据单元格中的关键词（如A1单元格的“Abelia chinensis Variegata”）查找谷歌图片搜索的首张图片，并插入到对应单元格（如B1）中。现有脚本以D列为关键词，但运行后A列返回0，无法正常插入图片，需修复该脚本实现需求。

原脚本问题分析 #

• 未定义变量：sImageSearchString未声明赋值，导致图片筛选逻辑完全失效，无法获取有效图片链接
• 链接解析错误：原脚本通过父级<a>标签的href截取图片URL的方式已不适用于当前谷歌图片的链接结构
• 错误处理滥用：全局On Error Resume Next掩盖了实际报错，无法定位问题
• 硬编码参数：固定从第3行开始、指定工作表名称，灵活性不足
• 无容错机制：未处理图片加载失败的情况

修复后的脚本 #

Public Sub InsertGoogleFirstImage()
    Dim IE As InternetExplorer
    Dim HTMLdoc As HTMLDocument
    Dim imgElements As IHTMLElementCollection
    Dim imgElement As HTMLImg
    Dim lastRow As Long, i As Long
    Dim searchUrl As String
    Dim imgUrl As String
    Dim targetCell As Range
    Dim img As Picture
    
    ' --- 可自定义参数 ---
    Const KEYWORD_COL As String = "D"       ' 关键词所在列
    Const IMAGE_TARGET_COL As String = "B"  ' 图片插入目标列
    Const START_ROW As Long = 3             ' 起始行（从第3行开始）
    Const SHEET_NAME As String = "one"      ' 工作表名称
    ' --- 可自定义参数结束 ---
    
    Set IE = New InternetExplorer
    IE.Visible = False ' 隐藏浏览器窗口
    
    With ThisWorkbook.Sheets(SHEET_NAME)
        lastRow = .Range(KEYWORD_COL & Rows.Count).End(xlUp).Row
        
        For i = START_ROW To lastRow
            ' 跳过空单元格
            If Trim(.Range(KEYWORD_COL & i).Value) = "" Then GoTo NextRow
            
            ' 构建谷歌图片搜索URL（含URL编码处理特殊字符）
            searchUrl = "https://www.google.com/search?q=" & _
                        URLEncode(.Range(KEYWORD_COL & i).Value) & _
                        "&tbm=isch&safe=off"
            
            ' 打开搜索页面并等待加载完成
            IE.navigate searchUrl
            Do Until IE.readyState = READYSTATE_COMPLETE And Not IE.Busy
                DoEvents
            Loop
            
            Set HTMLdoc = IE.document
            Set imgElements = HTMLdoc.getElementsByTagName("IMG")
            
            imgUrl = ""
            ' 遍历图片元素，跳过谷歌logo等非结果图片
            For Each imgElement In imgElements
                ' 筛选有效图片：排除谷歌默认图标，且src包含http
                If InStr(imgElement.src, "http") > 0 And _
                   InStr(imgElement.src, "google.com/images/branding") = 0 Then
                    imgUrl = imgElement.src
                    Exit For ' 取第一张有效图片
                End If
            Next imgElement
            
            ' 插入图片到目标单元格
            If imgUrl <> "" Then
                Set targetCell = .Range(IMAGE_TARGET_COL & i)
                On Error Resume Next
                ' 清除原有图片
                .Shapes(targetCell.Address).Delete
                ' 插入新图片
                Set img = .Pictures.Insert(imgUrl)
                On Error GoTo 0
                
                If Not img Is Nothing Then
                    ' 调整图片大小适配单元格（锁定宽高比）
                    With img
                        .Top = targetCell.Top
                        .Left = targetCell.Left
                        .ShapeRange.LockAspectRatio = msoTrue
                        ' 按单元格宽度缩放
                        If .ShapeRange.Width > targetCell.Width Then
                            .ShapeRange.Width = targetCell.Width
                        End If
                    End With
                    ' 记录图片URL到旁边单元格（可选）
                    .Range(IMAGE_TARGET_COL & i).Offset(0, 1).Value = imgUrl
                End If
            End If
            
NextRow:
        Next i
    End With
    
    IE.Quit
    Set IE = Nothing
    MsgBox "图片插入完成！", vbInformation
End Sub

' URL编码函数，处理关键词中的空格、特殊字符
Private Function URLEncode(ByVal str As String) As String
    Dim bytes() As Byte
    Dim i As Integer
    bytes = StrConv(str, vbUnicode)
    For i = 0 To UBound(bytes) Step 2
        URLEncode = URLEncode & "%" & Hex(bytes(i)) & Hex(bytes(i + 1))
    Next i
End Function

使用注意事项 #

• 引用库：打开VBA编辑器（Alt+F11），依次点击工具→引用，勾选Microsoft Internet Controls和Microsoft HTML Object Library
• 反爬提示：谷歌有反爬机制，请勿短时间内大量运行脚本，可能会触发验证码或IP限制
• 参数调整：可修改脚本顶部的KEYWORD_COL、IMAGE_TARGET_COL等参数，适配你的工作表结构
• 容错处理：脚本会跳过空关键词单元格，若图片加载失败会自动忽略，不会中断运行

内容的提问来源于stack exchange，提问作者steven_Learner