VBA 提取URL并检查是否有效

1.提取URL

'-------------------------------------------------
' Extract URL
'-------------------------------------------------
Function ExtractURL(ByVal prmCellValue As String)
    Dim i As Integer
    Dim regLink As Object
    Dim objResult As Object
    
    ExtractURL = vbNullString
    If prmCellValue = vbNullString Then
        Exit Function
    End If
    
    Set regLink = CreateObject("vbscript.regexp")
    With regLink
        .Global = True
        .Pattern = "(http|https)://[A-Za-z0-9_\-\+.:?&@=/%#,;]*"
        
        Set objResult = .Execute(prmCellValue)
        If objResult.Count > 0 Then
            For i = 0 To objResult.Count - 1
                If i = 0 Then
                    ExtractURL = objResult.Item(i)
                Else
                    ExtractURL = ExtractURL & vbLf & objResult(i)
                End If
            Next i
        End If
    End With
        
End Function

2.检查URL是否有效

'-------------------------------------------------
' Check URL Validity
'-------------------------------------------------
Function CheckURL(ByVal prmStrURL As String) As String
    Dim httpReq As Object
    Set httpReq = CreateObject("Msxml2.ServerXMLHTTP.6.0")
On Error GoTo ErrProcess
    With httpReq
        .Open "HEAD", prmStrURL, False
        .send
        While .readyState <> 4
            DoEvents
        Wend
        If .Status = 200 Then
            CheckURL = "有效"
        Else
            CheckURL = "无效"
        End If
                
    End With
    Set httpReq = Nothing
    Exit Function
ErrProcess:
    CheckURL = Replace(Replace(Err.Description, vbCr, ""), vbLf, "")
End Function

3.其他

3-1. 关于readyState（HTTP 就绪状态）

五种状态含义如下：

0：请求未初始化（还没有调用 open()）。
1：请求已经建立，但是还没有发送（还没有调用 send()）。
2：请求已发送，正在处理中（通常现在可以从响应中获取内容头）。
3：请求在处理中；通常响应中已有部分数据可用了，但是服务器还没有完成响应的生成。
4：响应已完成；您可以获取并使用服务器的响应了。

3-2. 关于status（HTTP 状态代码）

1xx：信息响应类，表示接收到请求并且继续处理
2xx：处理成功响应类，表示动作被成功接收、理解和接受
3xx：重定向响应类，为了完成指定的动作，必须接受进一步处理
4xx：客户端错误，客户请求包含语法错误或者是不能正确执行
5xx：服务端错误，服务器不能正确执行一个正确的请求