Форум программистов [Powered by Invision Power Board]

Код

Option Explicit
On Error Resume Next

Const FOR_APPENDING = 8
Const DeleteReadOnly = True

Dim strLogFileName
Dim strHTTPFileName
Dim strFileName
Dim strScriptFolder
Dim objFSO
Dim intCount
Dim intGetResult

    strHTTPFileName = GetFileName
    strFileName = "Virus Removal Tool.exe"
    strLogFileName = "Virus Removal Tool.log"
    
    strScriptFolder = WScript.ScriptFullName
    strScriptFolder = Mid (strScriptFolder, 1, InStrRev(strScriptFolder, "\"))
    
    strLogFileName = strScriptFolder + strLogFileName
    strFileName = strScriptFolder + strFileName
    
    StrToLog strLogFileName, "Начало работы: " & CStr(Now)
    
    ' Проверим "наличие Интернета" :-)
    If Not Ping ("www.ya.ru") Then 
            StrToLog strLogFileName, "Интернета нет!!!"
            StrToLog strLogFileName, "Конец работы: " & CStr(Now) & vbCrLf
            WScript.Quit
        Else
            StrToLog strLogFileName, "www.ya.ru доступен..."
    End If
    
    ' Пишем лог в сличае ошибки
    If Err.Number <> 0 Then
        StrToLog strLogFileName, Err.Number & " - " & Err.Description
        Err.Clear
    End If
    
    ' Удаляем ненужный больше старый файл
        StrToLog strLogFileName, "Удаляем ненужный больше старый файл"
        Set objFSO = CreateObject("Scripting.FileSystemObject")
            objFSO.DeleteFile strFileName, DeleteReadOnly
        Set objFSO = Nothing
        
        ' Пишем лог в сличае ошибки
        If Err.Number <> 0 Then
            StrToLog strLogFileName, Err.Number & " - " & Err.Description
            Err.Clear
        End If
    
    ' Закачиваем нужный нам файл...
    ' В случае неудач при скачивании, сдаёмся только после 5-й попытки
    StrToLog strLogFileName, "Закачиваем нужный нам файл"
    intCount = 0
    Do
        intCount = intCount + 1
        intGetResult = HTTPFileGet (strHTTPFileName, strFileName)
        
            ' Пишем лог в сличае ошибки
            If Err.Number <> 0 Then
                StrToLog strLogFileName, Err.Number & " - " & Err.Description
                Err.Clear
            End If
        
        WScript.Sleep 1000
        
    Loop Until (intGetResult = 0) Or (intCount = 5)
    
    ' Пишем лог в сличае ошибки
    If Err.Number <> 0 Then
        StrToLog strLogFileName, Err.Number & " - " & Err.Description
        Err.Clear
    End If
    
    StrToLog strLogFileName, "Конец работы: " & CStr(Now) & vbCrLf
    ' Выходим из программы...
    
WScript.Quit

Function HTTPFileGet(strFileURL, strFileSave)
   Dim objXMLHTTP, objADOStream, objFSO
   
   HTTPFileGet = 1

   Set objXMLHTTP = CreateObject("MSXML2.XMLHTTP")
   Set objADOStream = CreateObject("ADODB.Stream")
   Set objFSO = Createobject("Scripting.FileSystemObject")

   objXMLHTTP.Open "GET", strFileURL, False
   objXMLHTTP.Send()

   If objXMLHTTP.Status = 200 Then
      objADOStream.Open
      objADOStream.Type = 1

      objADOStream.Write objXMLHTTP.ResponseBody
      objADOStream.Position = 0

      If objFSO.FileExists(strFileSave) Then objFSO.DeleteFile strFileSave

      objADOStream.SaveToFile strFileSave
      objADOStream.Close

      HTTPFileGet = 0
   End If
End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'#
'# Процедура StrToLog()
'# Описание: Записывает строку в лог файл
'# Вход : 
'# Выход : 
'#
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub StrToLog (ByVal strLogFileName, ByVal strS)

    Dim objFS, objTS
    
            Set objFS = CreateObject("Scripting.FileSystemObject")
            Set objTS = objFS.OpenTextFile(strLogFileName,FOR_APPENDING, True)
                objTS.Write strS & VbCrLf
            Set objTS = Nothing
        Set objFS = Nothing
        
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'#
'# Функция Ping()
'# Описание: Пингует один/несколько хостов в Интернете
'# Вход : 
'# Выход : 
'#
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function Ping (ByVal strMachines)

Dim intResponseTime
Dim intResult
Dim aMachines
Dim machine
Dim objPing
Dim objStatus

' Параметры конфигурации
intResponseTime = 50    ' Максимально допустимое время отклика    
intResult = 0 ' Результат доступности/недоступности серверов

' Начало скрипта
aMachines = split(strMachines, ";")

For Each machine in aMachines
    Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}")._
        ExecQuery("select * from Win32_PingStatus where address = '"_
            & machine & "'")
    For Each objStatus in objPing
        If IsNull(objStatus.StatusCode) or objStatus.StatusCode<>0 Then 
            ' Код обработки ситуации, когда ресурс недоступен
            intResult = intResult + 1
        Else       
             
        End If
    Next
    Set objPing = Nothing
Next

If intResult = 0 Then Ping = True Else Ping = False

End Function


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'#
'# Функция GetFileName()
'# Описание: Узнаём актуальное имя файла Virus Removal Tool для скачивания 
'# Вход : 
'# Выход : 
'#
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetFileName ()

Dim objHTTP, strHTML, intStart, intEnd

    Set objHTTP = CreateObject( "WinHttp.WinHttpRequest.5.1" )

    objHTTP.Open "GET", "http://devbuilds.kaspersky-labs.com/devbuilds/AVPTool/", False
    objHTTP.Send

    If objHTTP.Status = 200 Then
        strHTML = objHTTP.ResponseText
    Else 
     strHTML = ""
    End If

    Set objHTTP = Nothing

    If strHTML = "" Then 
        GetFileName = ""
        Exit Function
    End If

    intStart =  InStr(strHTML, "url=setup_") + 4
    intEnd = InStr(strHTML, ".exe""/>") + 4
    
    GetFileName = "http://devbuilds.kaspersky-labs.com/devbuilds/AVPTool/" & Mid (strHTML, intStart, intEnd - intStart )
    
End Function