用VBA对Excel中的死超链接排序?

The title says it:

I have an excel Sheet with an column full of hyperlinks. Now I want that an VBA Script checks which hyperlinks are dead or work and makes an entry into the next columns either with the text 404 Error or active.

Hopefully someone can help me because I am not really good at VB.

EDIT:

I found @ http://www.utteraccess.com/forums/printthread.php?Cat=&Board=84&main=1037294&type=thread

A solution which is made for word but the Problem is that I need this solution for Excel. Can someone translate this to Excel solution?

Private Sub testHyperlinks()
    Dim thisHyperlink As Hyperlink
    For Each thisHyperlink In ActiveDocument.Hyperlinks
        If thisHyperlink.Address <> "" And Left(thisHyperlink.Address, 6) <> "mailto" Then
            If Not IsURLGood(thisHyperlink.Address) Then
                Debug.Print thisHyperlink.Address
            End If
        End If
    Next
End Sub


Private Function IsURLGood(url As String) As Boolean
    ' Test the URL to see if it is good
    Dim request As New WinHttpRequest

    On Error GoTo IsURLGoodError
    request.Open "GET", url
    request.Send
    If request.Status = 200 Then
        IsURLGood = True
    Else
        IsURLGood = False
    End If
    Exit Function
IsURLGoodError:
        IsURLGood = False
End Function

#0

First add a reference to Microsoft XML V3 (or above), using Tools->References. Then paste this code:

Option Explicit

Sub CheckHyperlinks()

    Dim oColumn As Range
    Set oColumn = GetColumn() ' replace this with code to get the relevant column

    Dim oCell As Range
    For Each oCell In oColumn.Cells

        If oCell.Hyperlinks.Count > 0 Then

            Dim oHyperlink As Hyperlink
            Set oHyperlink = oCell.Hyperlinks(1) ' I assume only 1 hyperlink per cell

            Dim strResult As String
            strResult = GetResult(oHyperlink.Address)

            oCell.Offset(0, 1).Value = strResult

        End If

    Next oCell


End Sub

Private Function GetResult(ByVal strUrl As String) As String

    On Error Goto ErrorHandler

    Dim oHttp As New MSXML2.XMLHTTP30

    oHttp.Open "HEAD", strUrl, False
    oHttp.send

    GetResult = oHttp.Status & " " & oHttp.statusText

    Exit Function

ErrorHandler:
    GetResult = "Error: " & Err.Description

End Function

Private Function GetColumn() As Range
    Set GetColumn = ActiveWorkbook.Worksheets(1).Range("A:A")
End Function

#1

Gary's code is perfect, but I would rather use a public function in a module and use it in a cell as function. The advantage is that you can use it in a cell of your choice or anyother more complex function.

In the code below I have adjusted Gary's code to return a boolean and you can then use this output in an =IF(CHECKHYPERLINK(A1);"OK";"FAILED"). Alternatively you could return an Integer and return the status itself (eg.: =IF(CHECKHYPERLINK(A1)=200;"OK";"FAILED"))

A1: http://www.whatever.com
A2: =IF(CHECKHYPERLINK(A1);"OK";"FAILED")

To use this code please follow Gary's instructions and additionally add a module to the workbook (right click on the VBAProject --> Insert --> Module) and paste the code into the module.


Option Explicit

Public Function CheckHyperlink(ByVal strUrl As String) As Boolean

    Dim oHttp As New MSXML2.XMLHTTP30

    On Error GoTo ErrorHandler
    oHttp.Open "HEAD", strUrl, False
    oHttp.send

    If Not oHttp.Status = 200 Then CheckHyperlink = False Else CheckHyperlink = True

    Exit Function

ErrorHandler:
    CheckHyperlink = False
End Function

Please also be aware that, if the page is down, the timeout can be long.

推荐文章

如何在MS Access 2007或mssqlserver2005中通过SQL将字段转换成行

如何在MS Access 2007或mssqlserver2005中通过SQL将字段转换成行

推荐文章

你要列出吗?

你要列出吗?

推荐文章

sqlite 使用

sqlite 使用

推荐文章

是否有相当于HKEY_Classes_Root\Record的HKEY_Current_用户?

是否有相当于HKEY_Classes_Root\Record的HKEY_Current_用户?

推荐文章

Laravel源码入门-启动引导过程(五)$kernel->handle($request)

Laravel源码入门-启动引导过程(五)$kernel->handle($request)

推荐文章

google赞助链接上的Javascript URL替换

google赞助链接上的Javascript URL替换

推荐文章

尝试使用getBinaryStream()从数据库获取blob时出现“会话已关闭”错误

尝试使用getBinaryStream()从数据库获取blob时出现“会话已关闭”错误

推荐文章

【达内课程】SQLite(三)项目之增加和显示联系人列表

【达内课程】SQLite(三)项目之增加和显示联系人列表

推荐文章

关于目录或文章不存在的报错代码

关于目录或文章不存在的报错代码

推荐文章

如何摆脱选中列表框选择突出显示的效果?

如何摆脱选中列表框选择突出显示的效果?

推荐文章

IIS性能优化篇

IIS性能优化篇

推荐文章

使用jQuery验证插件向ASP.NET MVC控制器操作发送多个值?

使用jQuery验证插件向ASP.NET MVC控制器操作发送多个值?

推荐文章

在资源管理器中打开文件夹并选择文件

在资源管理器中打开文件夹并选择文件

推荐文章

【达内课程】SQLite(一)创建数据库、创建数据表、增删改查

【达内课程】SQLite(一)创建数据库、创建数据表、增删改查

推荐文章

映射共享上应用程序的SEHException

映射共享上应用程序的SEHException

推荐文章

数据库集群 ---续集

数据库集群 ---续集