Скрипт для поиска внешних битых ссылок

' ***********************************************************
' bad_links.vbs
' Поиск внешних битых ссылок - разминка
' Сайт автора scriptcoding.ru
' ***********************************************************
Option Explicit
 
Dim fso, outFile, spd, objWINHTTP, pages, success, url, links, a, bad_list, bad_links_list, i, objXSHTTP
 
'Подключаем объекты
Set fso = CreateObject("Scripting.FileSystemObject")
Set outFile = fso.CreateTextFile("bad_links.txt", True)
set spd = CreateObject("Chilkat.Spider")
Set objWINHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
 
'Задаем начальный домен
spd.Initialize "scriptcoding.ru"
'Добавляем URL адрес для исследования
spd.AddUnspidered "https://scriptcoding.ru/"
 
'Исключаем заданные адреса из проверки
spd.AddAvoidPattern "feeds.feedburner.com*"
spd.AddAvoidPattern "www.liveinternet.ru*"
spd.AddAvoidPattern "twitter.com*"
spd.AddAvoidPattern "www.facebook.com*"
 
'Задаем количество страниц
pages=5
 
'Считываем внутренние ссылки сайта
For i = 0 To pages
            'Включаем обработку ошибок
            On Error Resume Next
            'Переходим к следующей странице
    success = spd.CrawlNext()
    If (success = 1) Then
 
            'Считываем внешние ссылки сайта
                       For a = 0 To spd.NumOutboundLinks - 1
                                   'Присваиваем переменной url адрес текущей ссылки
                                   url = spd.GetOutboundLink(a)
 
                                   'Инициализируем HTTP-запрос, тут false - синхронный запрос (ждем ответа)
                                   objWINHTTP.open "GET", url, false
                                   'добавление HTTP-заголовка
                                   objWINHTTP.SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MyApp 1.0; Windows NT 5.1)"
                                   'Отправляем запрос
                                   objWINHTTP.send
 
                                   'Проверяем код ответа
                                   If (objWINHTTP.status = 404) Then
                                               'Записываем в переменную адреса битых ссылок
                                               bad_links_list=bad_links_list & url & VBCrLf
                                   end if 
                       Next
                       'Если список не пустой - заносим битые ссылки в список
                       if bad_links_list <> "" then
                                               bad_list=bad_list & "Адрес: " & spd.LastUrl & VBCrLf & "Битые ссылки " & VBCrLf & bad_links_list & VBCrLf
                       end if
 
                       'Обнуляем найденные линки
                       spd.ClearOutboundLinks()
                       bad_links_list=""
    Else
        '  Условие возникновения ошибки, или закончился обход 
        If (spd.NumUnspidered = 0) Then
           MsgBox "Адрес отсутствует"
        Else
        '  Информацию об ошибке 
           MsgBox spd.LastErrorText
        End If
    End If
 
    'Ожидание в 1 секунду до перехода к следующему URL
    spd.SleepMs 1000
Next
 
'Не пустой ли список               
if bad_list <> "" then
            'Записываем в файл наш список битых ссылок
            outFile.WriteLine(bad_list)
end if
 
'  Закрываем открытый файл
outFile.Close
MsgBox "Обход адресов закончен"

' ***********************************************************
' bad_links_full.vbs
' Поиск внешних битых ссылок
' Сайт автора scriptcoding.ru
' ***********************************************************
 
'Создаем экземпляр объекта
set wso = CreateObject("Scripting.WindowSystemObject")
'Задаем начальные размеры и отступы
set f = wso.CreateForm(0,0,0,0)
'Задаем через свойства ширину и высоту
f.ClientWidth = 500
f.ClientHeight = 500
'Центрируем форму
f.CenterControl()
'Заголовок окна
f.Text = "Поиск битых ссылок"
'нельзя менять размеры
f.SizeGrip = false
'нельзя развернуть форму
f.MaximizeBox = false
 
MSG="Автор:Владимир Баталий" & vbCrLf &_
"Поиск внешних битых ссылок для заданого сайта"
set t = f.CreateHyperLink(10,10,250,20,"scriptcoding.ru")
f.TextOut 10,30,MSG
 
f.TextOut 350,65,"имя домена"
 
set my_site =f.CreateEdit(350,85,125,20,wso.Translate("ES_MULTILINE"))
my_site.Text = "scriptcoding.ru"
 
f.TextOut 350,125,"число страниц"
 
set pages = f.CreateEdit(350,145,124,20,wso.Translate("ES_MULTILINE"))
'Задаем тип вводимых данных
pages.DataType=wso.Translate("DT_INTEGER")
pages.Text="100"
 
set Button = f.CreateButton(350,180,125,25,"Поиск")
 
'Компонент список
 
set list_links = f.CreateEdit(5,70,300,400,wso.Translate("ES_MULTILINE"))
list_links.ScrollBars = wso.Translate("SS_BOTH")
list_links.ReadOnly = true
list_links.WordWrap = true
 
'Вызов функции Bad_Links после нажатия на кнопку
Button.OnClick = GetRef("Bad_Links")
 
'метод делает форму видимой
f.Show()
'Запуск встроенного цикла обработки сообщений, он будет продолжаться до тех пор, пока видна какая либо форма или до вызова метода Stop. 
wso.Run()
 
Sub Bad_Links
On Error Resume Next
 
Set fso = CreateObject("Scripting.FileSystemObject")
Set outFile = fso.CreateTextFile("badlinks.txt", True)
 
set spd = CreateObject("Chilkat.Spider")
Set objWINHTTP = CreateObject("WinHttp.WinHttpRequest.5.1") 
 
spd.Initialize my_site.Text
spd.AddUnspidered "http://" & my_site.Text & "/"
 
spd.AddAvoidPattern "*" & my_site.Text & "/*/*reply*"
spd.AddAvoidPattern "feeds.feedburner.com*"
spd.AddAvoidPattern "www.liveinternet.ru*"
spd.AddAvoidPattern "twitter.com*"
spd.AddAvoidPattern "www.facebook.com*"
 
list_links.Text="Идет поиск битых ссылок. ЖДИТЕ..."
 
MsgBox "Идет поиск битых ссылок. ЖДИТЕ..."
 
For i = 0 To CStr(pages.text)
    success = spd.CrawlNext()
    If (success = 1) Then
        'Считываем внешние ссылки сайта
        For a = 0 To spd.NumOutboundLinks - 1
            url = spd.GetOutboundLink(a)
 
            objWINHTTP.open "GET", url, false
            objWINHTTP.SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MyApp 1.0; Windows NT 5.1)"
            objWINHTTP.send
 
            'Проверяем код ответа
            If (objWINHTTP.status = 404) Then ' анализ ответа сервера
                bad_links_list=bad_links_list & url & VBCrLf
            end if    
        Next                  
            if (bad_links_list <> "") then
                bad_list=bad_list & "Адрес: " & spd.LastUrl & VBCrLf & "Битые ссылки " & VBCrLf & bad_links_list & VBCrLf
            end if
        spd.ClearOutboundLinks()
        bad_links_list=""
    Else
        ' Условие возникновения ошибки, или закончился обход  
        If (spd.NumUnspidered = 0) Then
            'Количество страниц сканируемых страниц закончелось
            MsgBox "Конец списка"
            'Выходим из цикла
            Exit for
        Else
        ' Информацию об ошибке  
            MsgBox spd.LastErrorText
        End If
    End If
    '  Ожидание в 1 секунду до перехода к следующему URL
    spd.SleepMs 1000
Next
if (bad_list="") then bad_list="Поздравляю, битых ссылок нет"
 
if (bad_list<>"") then list_links.text = bad_list
outFile.WriteLine(bad_list)
outFile.Close
MsgBox "Сканирование завершено!!!"
 
End Sub