如何无需打开超链接批量验证Access中URL的有效性？

原代码功能说明 #

原代码是窗体按钮的点击事件，实现以下功能：

• 用户在主窗体frmMain_Menu选择账号和运输类型后，子窗体subfrmRouting_Instructions加载对应运输数据
• 点击按钮尝试打开TxtWebsite控件中的超链接
• 若链接无效，弹窗提示错误，并将账号、运输类型、无效URL及检测日期记录到tblInvalid_URLs表中

原代码如下：

Private Sub Go_to_Link_Click()

On Error GoTo err_Go_to_Link_Click
        Application.FollowHyperlink [Forms]![frmMain_Menu]![subfrmRouting_Instructions]![TxtWebsite]
Exit_Go_to_Link_Click:
    Exit Sub
err_Go_to_Link_Click:
    MsgBox "Error Number: " & Err.Number & vbCrLf & "Error Description: " & Err.Description & vbCrLf & vbCrLf & "Shipping Website address is invalid, please inform customer service so they can update the URL in the routing guide"
    Dim rs As DAO.Recordset
    Dim freight_pack As String
    Dim Account_No As String
    Account_No = [Forms]![frmMain_Menu]![ComboAcctNum]
    freight_pack = [Forms]![frmMain_Menu]![ComboFreight_Packages]
    Set rs = CurrentDb.OpenRecordset("tblInvalid_URLs")
    rs.AddNew
        rs("Acct_Number") = Account_No
        rs("Shipping_Type") = freight_pack
        rs("Invalid_Shipping_Website_Link") = [Forms]![frmMain_Menu]![subfrmRouting_Instructions]![TxtWebsite]
        rs("Date_detected") = Now()
    rs.Update
    Resume Exit_Go_to_Link_Click

End Sub

需求说明 #

能否遍历主表中所有URL，无需实际打开即可验证有效性，批量记录所有无效URL，以便生成报表提交给负责更新URL的人员？

解决方案 #

可以通过MSXML2.XMLHTTP对象发送HEAD请求验证URL有效性，无需打开浏览器，实现批量检测。以下是完整的VBA代码：

Sub BatchValidateURLs()
    Dim mainRS As DAO.Recordset
    Dim invalidRS As DAO.Recordset
    Dim xmlHttp As Object
    Dim url As String
    Dim accountNo As String
    Dim shippingType As String
    Dim responseCode As Integer
    
    ' 初始化XMLHTTP对象
    Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
    ' 打开主表（需替换为实际存储URL的主表名称）
    Set mainRS = CurrentDb.OpenRecordset("SELECT Acct_Number, Shipping_Type, TxtWebsite FROM tblRouting_Instructions WHERE TxtWebsite IS NOT NULL AND TxtWebsite <> ''")
    ' 打开无效URL记录表
    Set invalidRS = CurrentDb.OpenRecordset("tblInvalid_URLs", dbOpenDynaset)
    
    ' 遍历主表所有记录
    Do While Not mainRS.EOF
        url = mainRS!TxtWebsite
        accountNo = mainRS!Acct_Number
        shippingType = mainRS!Shipping_Type
        
        ' 为缺少协议头的URL补全http前缀
        If Not url Like "http*" Then
            url = "http://" & url
        End If
        
        On Error Resume Next
        ' 发送HEAD请求验证URL状态
        xmlHttp.Open "HEAD", url, False
        xmlHttp.Send
        responseCode = xmlHttp.Status
        On Error GoTo 0
        
        ' 判断URL是否无效：状态码不在200-399范围内则视为无效
        If responseCode < 200 Or responseCode >= 400 Then
            ' 检查是否已存在相同记录，避免重复添加
            invalidRS.FindFirst "Acct_Number = '" & Replace(accountNo, "'", "''") & "' AND Shipping_Type = '" & Replace(shippingType, "'", "''") & "' AND Invalid_Shipping_Website_Link = '" & Replace(url, "'", "''") & "'"
            If invalidRS.NoMatch Then
                invalidRS.AddNew
                    invalidRS!Acct_Number = accountNo
                    invalidRS!Shipping_Type = shippingType
                    invalidRS!Invalid_Shipping_Website_Link = url
                    invalidRS!Date_detected = Now()
                invalidRS.Update
            End If
        End If
        
        mainRS.MoveNext
    Loop
    
    ' 清理对象
    mainRS.Close
    invalidRS.Close
    Set xmlHttp = Nothing
    Set mainRS = Nothing
    Set invalidRS = Nothing
    
    MsgBox "批量URL验证完成，无效链接已记录到tblInvalid_URLs表中。"
End Sub

关键说明 #

• 高效验证：使用HEAD请求仅获取响应状态码，不下载页面内容，比打开浏览器或发送GET请求效率更高
• 兼容性处理：自动补全URL的http协议头，避免因格式缺失导致的验证失败
• 去重机制：检查无效URL是否已存在于记录表中，防止重复记录
• 容错性：捕获请求过程中的错误，确保批量检测不会因单个URL异常中断

使用注意事项 #

1. 将代码中的tblRouting_Instructions替换为实际存储URL的主表名称
2. 确保主表包含Acct_Number、Shipping_Type、TxtWebsite三个字段
3. 64位Office环境下，可保持CreateObject方式创建XMLHTTP对象，无需额外引用库
4. 若部分网站阻止HEAD请求，可将代码中的HEAD改为GET（会降低验证效率）

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