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:服务端错误,服务器不能正确执行一个正确的请求