В общем решил реализовать класс эмуляции отправки формы из VBScript через XmlHttp. В принципе примеров полным полно. Но ни где подроно не разобрано как отправлять файлы. Да и универсального класса ни где не находил. Вот и решил написать + сделать у формы такие же свойства как у обычного HTMLFormElement.
Весь код расписал с подробными комментариями
Вот пример отправки файла на сайт http://www.zalil.ru
Кто опробует - отпишитесь пожалуйта
- Код: Выделить всё
'Описание класса FormClass
'Пример создания: "Set WebForm = New WebFormClass"
'Form.Action ' Свойство - URL на который будут отправлены данные. (чтение/запись)
'Form.AddField ' Процедура - Добавление поля.
'Form.AddFile ' Процедура - Добавление файла.
'Form.Boundary ' Свойство - Разделитель между данными (чтение)
'Form.Enctype ' Свойство - Тип кодирования формы (Для отправки полей - "application/x-www-form-urlencoded". Для отправки полей и файлов - "multipart/form-data") (чтение/запись)
'Form.Method ' Свойство - Метод отправки данных (GET / POST)
'Form.VarBody ' Свойство - Сформированные данные для отправки (чтение/запись)
'Пример отправки файла на сайт http://www.zalil.ru
Dim WebForm
'/// Создаём новый класс формы
Set WebForm = New WebFormClass
'/// Указываем куда будем отправлять данные
WebForm.Action = "http://www.zalil.ru/upload/"
'/// Устанавливаем метод передачи POST
WebForm.Method = "POST"
'/// Для того чтобы передались файлы устанавливаем тип кодирования multipart/form-data
WebForm.Enctype = "multipart/form-data"
'/// Добавляем файл
WebForm.AddFile "file", "C:\boot.ini"
'/// Запускаем процедуру отправку
Submit WebForm
Sub Submit(WebForm)
'/// Создаём объект отправки данных
Dim XMLHTTP
Set XMLHTTP = CreateObject("MSXML2.XMLHTTP")
'/// Открываем соединение с URL
XMLHTTP.Open WebForm.Method, WebForm.Action, False
'/// Если тип передачи данных POST, то добавляем к пакету заголовки
If WebForm.Method = "POST" Then
'/// Если отправляем с кодированием "multipart/form-data", то добавляем информацию о разделителе данных
If WebForm.Enctype = "multipart/form-data" Then
XMLHTTP.setrequestheader "Content-type", WebForm.Enctype & "; boundary=" & WebForm.Boundary
Else '/// В ином случае добавляем информацию о том, что данные отправляются формой
XMLHTTP.setrequestheader "Content-type", WebForm.Enctype
End If
End If
'/// Отправляем запрос
XMLHTTP.Send WebForm.VarBody
'/// Смотрим статус ответа
Select Case XMLHTTP.Status
'/// Если 200 - OK. Данные переданы успешно
Case 200
Dim InternetExplorer
Set InternetExplorer = CreateObject("InternetExplorer.Application")
InternetExplorer.Visible = True
InternetExplorer.Navigate "about:blank"
Do
WScript.Sleep 100
Loop Until InternetExplorer.readystate = 4
InternetExplorer.document.write XMLHTTP.responsetext
Case Else
MsgBox XMLHTTP.Status & " " & StatusText, vbCritical, "Ошибка при передаче данных !"
End Select
End Sub
'/// Класс формы
Class WebFormClass
Private Fields, Files
Private PropertyEnctype, PropertyMethod, PropertyBoundary, PropertyAction
Private Sub Class_Initialize()
Fields = Array()
Files = Array()
PropertyEnctype = "application/x-www-form-urlencoded"
PropertyMethod = "GET"
PropertyBoundary = String(27, "-") & GenerateBoundary
PropertyAction = "about:blank"
End Sub
Public Property Let Action(Value)
PropertyAction = Value
End Property
Public Property Get Action()
Action = PropertyAction
If PropertyMethod = "GET" Then
Dim Params
Params = VarBody
If VarBody <> "" Then Action = Action & "?" & Params
End If
End Property
Public Property Get Boundary()
Boundary = PropertyBoundary
End Property
Public Property Get Method()
Method = PropertyMethod
End Property
Public Property Let Method(Value)
Value = UCase(Value)
If Value = "GET" Or Value = "POST" Then PropertyMethod = Value
End Property
Public Property Get Enctype()
Enctype = PropertyEnctype
End Property
Public Property Let Enctype(Value)
Value = LCase(Value)
If Value = "multipart/form-data" Or Value = "application/x-www-form-urlencoded" Then PropertyEnctype = Value
End Property
Public Sub AddField(Name, Value)
SetElement Fields, Name, Value
End Sub
Public Sub AddFile(Name, Value)
SetElement Files, Name, Value
End Sub
Private Function SetElement(ArrayRef, Name, Value)
For ElementID = 0 To UBound(ArrayRef)
If ArrayRef(ElementID)(0) = Name Then
ArrayRef(ElementID)(1) = Value
Exit Function
End If
Next
ReDim Preserve ArrayRef(UBound(ArrayRef) + 1)
ArrayRef(UBound(ArrayRef)) = Array(Name, Value)
End Function
Public Property Get VarBody()
If PropertyMethod = "POST" And PropertyEnctype = "multipart/form-data" Then
Const DefaultBoundary = "--"
Dim Stream
Set Stream = CreateObject("ADODB.Stream")
Stream.Type = 2
Stream.Mode = 3
Stream.Charset = "Windows-1251"
Stream.Open
Dim FieldHeader, FieldsBody
For Each Field In Fields
FieldHeader = "Content-Disposition: form-data; name=""" & Field(0) & """"
FieldsBody = FieldsBody & DefaultBoundary & PropertyBoundary & vbCrLf & FieldHeader & vbCrLf & Field(1) & vbCrLf
Next
Stream.WriteText FieldsBody
Dim FileHeader
For Each File In Files
If LoadFile(File(1), Data) Then
FileHeader = DefaultBoundary & Boundary & vbCrLf & "Content-Disposition: form-data; name=""" & File(0) & """; filename=""" & File(1) & """" & vbCrLf & "Content-Type: octet/stream" & vbCrLf & vbCrLf
Stream.WriteText FileHeader
Stream.Position = 0
Stream.Type = 1
Stream.Position = Stream.Size
Stream.write Data
Stream.Position = 0
Stream.Type = 2
Stream.Position = Stream.Size
End If
Next
Stream.Position = 0
Stream.Type = 2
Stream.Position = Stream.Size
Stream.WriteText vbCrLf & DefaultBoundary & PropertyBoundary & DefaultBoundary
Stream.Position = 0
Stream.Type = 1
VarBody = Stream.Read
Else
For Each Field In Fields
VarBody = VarBody & Escape(Field(0)) & "=" & Escape(Field(1)) & "&"
Next
For Each File In Files
VarBody = VarBody & Escape(File(0)) & "=" & Escape(File(1)) & "&"
Next
if Len(VarBody) > 0 Then VarBody = Left(VarBody, Len(VarBody) - 1)
End If
End Property
Private Function LoadFile(Path, Data)
On Error Resume Next
Dim Stream
Set Stream = CreateObject("ADODB.Stream")
Stream.Type = 1
Stream.Mode = 3
Stream.Open
Stream.LoadFromFile Path
If Err.Number <> 0 Then Exit Function
Data = Stream.Read
LoadFile = True
End Function
Private Function GenerateBoundary()
Dim Char
Dim N
For N = 1 To 12
Randomize
Char = Chr(CLng(Rnd * 25) + 97)
If N Mod 2 Then Char = UCase(Char)
GenerateBoundary = GenerateBoundary & Char
Next
End Function
End Class
