Question

我的任务是确定我们团队内部网上的所有链接。目标是整理（找到重复的链接或死链接）。

我写了这个脚本，它将转到我们的页面并在识别文件扩展名的同时抓取每个链接。我不知道该怎么做才能使这个递归。一旦它进入我们的网站并擦除这些链接，如果它找到另一个URL（例如htm或html），我希望它跟随该链接并从那里抓取并继续，直到与初始URL相关联的每个链接都用尽。我想在csv中创建一种层次结构，例如（示例标题）： lvl0_Link_Title，lvl0_File_Type，lvl0_URL，lvl1_Link_Title，lvl1_File_Type，lvl1_URL，lvl2_Link_Title，lvl2_File_Type，lvl2_URL，lvl3_Link ...等。

显然，这最终会产生一个非常庞大的csv。如果有更好/更清洁的方法来实现同样的目标，我愿意接受它。

Set objWshShell = Wscript.CreateObject("Wscript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Set IE = CreateObject("internetexplorer.application")

on error resume next

filename = fso.GetParentFolderName(WScript.ScriptFullName) & "\URL_Dump_Oldsite.csv"

'==============================================
'Create headers for CSV
    set output = fso.opentextfile(filename,2,true) 
    output.writeline "Link Title,File Type,URL"
    output.close
'==============================================

IE.Visible = false
IE.Navigate "URL OF OUR INTRANET"
Do While IE.Busy or IE.ReadyState <> 4: WScript.sleep 100: Loop
Do Until IE.Document.ReadyState = "complete": WScript.sleep 100: Loop

for each url in ie.document.getelementsbytagname("a")

    if not url.href is nothing then

    ext = mid(url.href,instrrev(url.href,"."))

        set output = fso.opentextfile(filename,8,true) 
        output.writeline replace(url.innertext,","," / ") & "," & ext & ",=HYPERLINK(" & chr(34) & url.href & chr(34) & ")"
        output.close 

    end if

next

'===========================================
'Keyword filter for removal

Dim arrFilter
arrFilter = Array("bakpcweb", _
        "aims", _
        "element", _
        "objid", _
        "nodeid", _
        "objaction", _
        "javascript", _
        "itemtype")

'===========================================
'Delete lines from csv file containing keywords

strFile1 = fso.GetParentFolderName(WScript.ScriptFullName) & "\URL_Dump_Oldsite.csv"

Set objFile1 = fso.OpenTextFile(strFile1)

Do Until objFile1.AtEndOfStream

    i = 0

    strLine1 = trim(lcase(objFile1.Readline))

    for a = lbound(arrFilter) to ubound(arrFilter)

        if instr(strLine1,arrFilter(a)) <> 0 then
            i = i + 1
        End If

    next

    if i = 0 then
        strNewContents1 = strNewContents1 & strLine1 & vbCrLf
    end if

Loop

objFile1.Close

Set objFile1 = fso.OpenTextFile(strFile1,2,true)
objFile1.Write strNewContents1
objFile1.Close

'===========================================
'Delete blank lines from csv file

strFile = fso.GetParentFolderName(WScript.ScriptFullName) & "\URL_Dump_Oldsite.csv"

Set objFile = fso.OpenTextFile(strFile)

Do Until objFile.AtEndOfStream
    strLine = objFile.Readline
    strLine = Trim(strLine)
    If Len(strLine) > 0 Then
        strNewContents = strNewContents & strLine & vbCrLf
    End If
Loop

objFile.Close

Set objFile = fso.OpenTextFile(strFile,2,true)
objFile.Write strNewContents
objFile.Close

'===========================================

'Remove duplicate lines from csv file

Set objDictionary = CreateObject("Scripting.Dictionary")

strFile = fso.GetParentFolderName(WScript.ScriptFullName) & "\URL_Dump_Oldsite.csv"

Set objFile = fso.OpenTextFile(strFile)

Do Until objFile.AtEndOfStream
    strLine = objFile.Readline
    strLine = Trim(strLine)
    If Not objDictionary.Exists(strLine) Then
        objDictionary.Add strLine, strLine
    End If
Loop

objFile.Close

Set objFile = fso.opentextfile(strFile,2,true)

For Each strKey in objDictionary.Keys
    objFile.WriteLine strKey
Next

objFile.Close
objDictionary.clearall

'===========================================


wscript.echo "Done!"
ie.quit
wscript.quit

谢谢！

Answer 1

这可能不是你期望的答案，但听起来你在这里重新发明了轮子，并且使用了不合标准的工具。根据我的经验，我也不会发现lvl0，lvl1等格式在以后报告时特别有用。

我强烈建议您使用现有程序扫描您的Intranet，例如Xenu或进行更深入的分析，请尝试Screaming Frog SEO Spider（免费版本限制在500页左右，我记得，但你可以尝试一下）。这些工具具有保存报告的功能，可以满足您的需求。

如果这不适合您，请评论或编辑您的答案，以解释您必须自己执行此操作并以指定格式报告的原因。

编辑：这是来自免费Xenu程序的示例屏幕截图，其中列出了它尝试的每个资源，其状态，链接输入/输出和类型，这可以帮助您报告文件类型。如果您需要统计数据，它还会生成完整的HTML报告。

VBScript以递归方式抓取本地Intranet页面以获取链接

1 个答案: