基于VBA实现Chrome 115及对应ChromeDriver的匹配下载方案问询

针对Chrome 115+版本的新下载结构，以下是实现「读取本地Chrome版本+下载匹配ChromeDriver」的完整VBA代码：

核心功能说明 #

• 从Windows注册表读取本地已安装的Chrome版本
• 通过官方版本查询接口获取对应版本的ChromeDriver下载链接
• 自动下载并解压ChromeDriver到指定目录

完整VBA代码 #

Option Explicit

' 常量配置，可根据需求修改
Private Const JSON_VERSION_URL As String = "https://googlechromelabs.github.io/chrome-for-testing/known-good-versions-with-downloads.json"
Private Const CHROMEDRIVER_TARGET_PATH As String = "C:\Program Files\Google\Chrome\Application\" ' 建议放到Chrome安装目录或系统PATH目录
Private Const TEMP_ZIP_PATH As String = "C:\Temp\chromedriver.zip" ' 临时压缩包存放路径

Sub UpdateChromeDriver()
    Dim chromeVersion As String
    Dim driverDownloadUrl As String
    
    ' 步骤1：获取本地Chrome版本
    chromeVersion = GetChromeVersion()
    If chromeVersion = "" Then
        MsgBox "未检测到Chrome浏览器，请确认已安装Chrome", vbExclamation
        Exit Sub
    End If
    Debug.Print "当前Chrome版本：" & chromeVersion
    
    ' 步骤2：获取对应版本的ChromeDriver下载链接
    driverDownloadUrl = GetChromeDriverDownloadUrl(chromeVersion)
    If driverDownloadUrl = "" Then
        MsgBox "未找到匹配版本的ChromeDriver", vbExclamation
        Exit Sub
    End If
    Debug.Print "ChromeDriver下载链接：" & driverDownloadUrl
    
    ' 步骤3：下载ChromeDriver压缩包
    If Not DownloadFile(driverDownloadUrl, TEMP_ZIP_PATH) Then
        MsgBox "ChromeDriver下载失败", vbCritical
        Exit Sub
    End If
    
    ' 步骤4：解压并替换ChromeDriver
    If Not UnzipFile(TEMP_ZIP_PATH, CHROMEDRIVER_TARGET_PATH) Then
        MsgBox "ChromeDriver解压失败", vbCritical
        Exit Sub
    End If
    
    ' 清理临时文件
    On Error Resume Next
    Kill TEMP_ZIP_PATH
    On Error GoTo 0
    
    MsgBox "ChromeDriver更新完成，版本：" & chromeVersion, vbInformation
End Sub

' 获取本地Chrome版本（从注册表读取）
Private Function GetChromeVersion() As String
    Dim regPaths As Variant
    Dim regPath As Variant
    Dim version As String
    
    ' 覆盖32位和64位系统的Chrome注册表路径
    regPaths = Array( _
        "HKEY_LOCAL_MACHINE\SOFTWARE\Google\Chrome\BLBeacon\version", _
        "HKEY_LOCAL_MACHINE\SOFTWARE\WOW6432Node\Google\Chrome\BLBeacon\version", _
        "HKEY_CURRENT_USER\Software\Google\Chrome\BLBeacon\version" _
    )
    
    For Each regPath In regPaths
        On Error Resume Next
        version = CreateObject("WScript.Shell").RegRead(regPath)
        On Error GoTo 0
        If version <> "" Then
            GetChromeVersion = version
            Exit Function
        End If
    Next regPath
    
    GetChromeVersion = ""
End Function

' 通过JSON接口获取对应版本的ChromeDriver下载链接（Win64版本）
Private Function GetChromeDriverDownloadUrl(chromeVersion As String) As String
    Dim jsonText As String
    Dim jsonObj As Object
    Dim versions As Object
    Dim versionItem As Object
    Dim downloads As Object
    Dim driverItems As Object
    Dim item As Object
    
    ' 下载JSON版本数据
    jsonText = GetHTTP(JSON_VERSION_URL)
    If jsonText = "" Then Exit Function
    
    ' 解析JSON
    Set jsonObj = CreateObject("Scripting.Dictionary")
    Set jsonObj = JsonConverter.ParseJson(jsonText)
    Set versions = jsonObj("versions")
    
    ' 遍历版本列表，匹配目标版本
    For Each versionItem In versions
        If versionItem("version") = chromeVersion Then
            Set downloads = versionItem("downloads")
            Set driverItems = downloads("chromedriver")
            ' 筛选Win64版本的下载链接
            For Each item In driverItems
                If item("platform") = "win64" Then
                    GetChromeDriverDownloadUrl = item("url")
                    Exit Function
                End If
            Next item
        End If
    Next versionItem
    
    GetChromeDriverDownloadUrl = ""
End Function

' HTTP GET请求获取内容
Private Function GetHTTP(url As String) As String
    Dim xmlHttp As Object
    Set xmlHttp = CreateObject("MSXML2.XMLHTTP.6.0")
    xmlHttp.Open "GET", url, False
    xmlHttp.Send
    If xmlHttp.Status = 200 Then
        GetHTTP = xmlHttp.responseText
    End If
    Set xmlHttp = Nothing
End Function

' 下载文件到指定路径
Private Function DownloadFile(url As String, savePath As String) As Boolean
    Dim xmlHttp As Object
    Dim fso As Object
    Dim ts As Object
    
    ' 创建临时目录（如果不存在）
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(fso.GetParentFolderName(savePath)) Then
        fso.CreateFolder fso.GetParentFolderName(savePath)
    End If
    
    ' 下载文件
    Set xmlHttp = CreateObject("MSXML2.XMLHTTP.6.0")
    xmlHttp.Open "GET", url, False
    xmlHttp.Send
    
    If xmlHttp.Status = 200 Then
        Set ts = fso.CreateTextFile(savePath, True)
        ts.Write xmlHttp.responseBody
        ts.Close
        DownloadFile = True
    End If
    
    Set xmlHttp = Nothing
    Set fso = Nothing
    Set ts = Nothing
End Function

' 解压ZIP文件到指定目录
Private Function UnzipFile(zipPath As String, extractPath As String) As Boolean
    Dim shellApp As Object
    Dim fso As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(extractPath) Then
        fso.CreateFolder extractPath
    End If
    
    ' 使用Shell.Application解压
    Set shellApp = CreateObject("Shell.Application")
    shellApp.Namespace(CVar(extractPath)).CopyHere shellApp.Namespace(CVar(zipPath)).Items, 16 ' 16=覆盖现有文件
    
    ' 等待解压完成（简单延时，可根据文件大小调整）
    Application.Wait Now + TimeValue("00:00:03")
    
    UnzipFile = True
    
    Set shellApp = Nothing
    Set fso = Nothing
End Function

使用说明 #

1. 依赖JSON解析模块：代码中使用了JsonConverter.ParseJson，需先导入VBA-JSON模块到VBA工程
2. 权限要求：运行代码需要管理员权限（因为要写入Program Files目录）
3. 路径修改：可根据实际需求修改CHROMEDRIVER_TARGET_PATH和TEMP_ZIP_PATH常量
4. 错误处理：代码包含基础错误处理，可根据实际场景扩展

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