VPF::Закачивание файлов по HTTP - Форум программистов

mihanik

Дата 24.11.2009, 15:18 (ссылка)

(нет голосов)

Загрузка ...

-=Белый Медведь=-

Профиль
Группа: Комодератор
Сообщений: 4054
Регистрация: 24.4.2006
Где: г. Тверь

Репутация: 61
Всего: 109

Нужно тут было через HTTP по заданию закачивать файл из тырнета (обновления для антивирусника от MS)

Вот...
Накидал решение.
Немного топорное и громоздкое (брал шаблон, а потом копи/паст).
И одна особенность есть. Файл log.log должен уже существовать.
Иначе будет ошибка времени выполнения, но скрипт пойдёт дальше, т.к.
On Error Resume Next

Код


On Error Resume Next

' Пишем в лог
Const FOR_APPENDING = 8
strFileName = "D:\AV\msse\log.log"
strContent  = "Start at - " & CStr(Now) & vbcrlf
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objTS = objFS.OpenTextFile(strFileName,FOR_APPENDING)
objTS.Write strContent
Set objTS = Nothing
Set objFS = Nothing

' Удаляем ненужные больше файлы
Const DeleteReadOnly = True
Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.DeleteFile("D:\AV\msse\mpam*"), DeleteReadOnly
Set objFSO = Nothing

' Закачиваем нужный нам файл...
HTTPFileGet "http://download.microsoft.com/download/DefinitionUpdates/mpam-fe.exe", "D:\AV\msse\mpam-fe.exe"

' Пишем в лог
strContent  = Err.Number & " - " & Err.Description & vbcrlf & "End at - " & CStr(Now) & vbcrlf
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objTS = objFS.OpenTextFile(strFileName,FOR_APPENDING)
objTS.Write strContent
Set objTS = Nothing
Set objFS = Nothing

' Выходим из программы...
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

--------------------

Программистами не рождаются, - это родовая травма...

Akina

Дата 24.11.2009, 15:43 (ссылка)

(нет голосов)

Загрузка ...

Советчик

Профиль
Группа: Модератор
Сообщений: 20580
Регистрация: 8.4.2004
Где: Зеленоград

Репутация: 42
Всего: 454

Цитата(mihanik @ 24.11.2009, 16:18

)

И одна особенность есть. Файл log.log должен уже существовать.
Иначе будет ошибка времени выполнения, но скрипт пойдёт дальше, т.к.
On Error Resume Next

Достаточно поправить строку 8

Код


Set objTS = objFS.OpenTextFile(strFileName,FOR_APPENDING, True)

и проблема отпадёт.

--------------------

О(б)суждение моих действий - в соответствующей теме, пожалуйста. Или в РМ. И высшая инстанция - Администрация форума.

mihanik

Дата 24.11.2009, 15:51 (ссылка)

(нет голосов)

Загрузка ...

-=Белый Медведь=-

Профиль
Группа: Комодератор
Сообщений: 4054
Регистрация: 24.4.2006
Где: г. Тверь

Репутация: 61
Всего: 109

Цитата(Akina @ 24.11.2009, 15:43

)

Достаточно поправить строку 8

Спасибо!

--------------------

Программистами не рождаются, - это родовая травма...

mihanik

Дата 30.11.2009, 21:30 (ссылка)

(нет голосов)

Загрузка ...

-=Белый Медведь=-

Профиль
Группа: Комодератор
Сообщений: 4054
Регистрация: 24.4.2006
Где: г. Тверь

Репутация: 61
Всего: 109

Прикольно!!!

Касперский мою программу определил как Trojan-Downloader.JS.gen

--------------------

Программистами не рождаются, - это родовая травма...

mihanik

Дата 30.11.2009, 23:22 (ссылка)

(нет голосов)

Загрузка ...

-=Белый Медведь=-

Профиль
Группа: Комодератор
Сообщений: 4054
Регистрация: 24.4.2006
Где: г. Тверь

Репутация: 61
Всего: 109

Немного доработал скрипт...

Код


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 = "http://download.microsoft.com/download/DefinitionUpdates/mpam-fe.exe"
    strFileName = "mpam-fe.exe"
    strLogFileName = "Log.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

--------------------

Программистами не рождаются, - это родовая травма...

1 Пользователей читают эту тему (1 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| MS Windows \| Следующая тема »