Пример автоматической закачки файла на сайт http://www.zalil.ru. Скрипт отправляет файл C:\boot.ini методом POST и выдаёт окно InternetExplorer со ссылкой на файл.
Можно отправлять форму двумя типами кодирования: "application/x-www-form-urlencoded" - для отправки полей формы методом POST и "multipart/form-data" - для отправки файлов. Класс формы независим от компонентов передачи данных (таких, как XmlHttp и WinHttpRequest, или других компонентов, имеющих аналогичные возможности). Можно отправлять данные в любой кодировке.
'/// Создаём новый класс формы
Set Form = New HttpFormClass
'/// Отправлять будем на сайт www.zalil.ru
Form.Action = "http://www.zalil.ru/upload/"
'/// Т.к нужно отправить файлы, то указываем метод - POST
Form.Method = "POST"
'/// Добавляем файл boot.ini
Form.AddFile "file","C:\boot.ini"
'/// Указываем тип кодирования данных формы, необходимый для отправки файлов.
'/// Если его не указать, то вместо отправки содержимого файлов будут отправлены только их пути
Form.Enctype = "multipart/form-data"
'/// Создаём объект для передачи данных
Set XmlHttp = CreateObject("MSXML2.XMLHTTP")
'/// Проверяем каким методом нужно отправить форму
if Form.Method = "GET" Then
'/// Получаем содерживое VarBody
VarBody = Form.VarBody
'/// Если форма отправляется GET-ом то VarBody нужно присоединить к URL
If VarBody <> "" Then
Form.Action = Form.Action & "?" & VarBody
'/// В итоге получаем URL типа URL?param1=value¶m2=value
End if
End if
'/// Открываем Request. Последний параметр в примере поставлен в False.
'/// Таким образом отключена асинхронность передачи данных. Это сделано для упрощения примера.
XMLHttp.Open Form.Method,Form.Action,False
'/// Если метод "POST", то добавляем заголовок к отправляемым данным
'/// Пример:
'/// Content-type: multipart/form-data; boundary=--------------aAbSbIuL, если из формы отправляются файлы
'/// или
'/// Content-type: application/x-www-form-urlencoded, если отправляется обычная форма с полями.
If Form.Method = "POST" Then XMLHttp.setrequestheader "Content-type",Form.Enctype & ";boundary=" & Form.Boundary
'/// Отправляем запрос
XMLHttp.Send Form.VarBody
'/// Проверяем статус ответа сервера
Select Case XMLHttp.status
Case 200 'OK
'/// Данные успешно приняты
'/// Получив данные хорошо бы их просмотреть. Для этого откроем окно InternetExplorer-а
Set InternetExplorer = CreateObject("InternetExplorer.Application")
'/// Делаем его видимым
InternetExplorer.Visible = True
'/// По умолчанию в нём не существует объект Document. Поэтому переводим его на пустую страницу
InternetExplorer.navigate "about:blank"
'/// Ждём полной загрузки
Do
Loop Until InternetExplorer.readystate = 4
'/// Заполняем документ полученным содержимым
InternetExplorer.Document.body.innerhtml = XMLHttp.responsetext
Case Else
'/// Остальные статусы рассматриваются как ошибка.
'/// Но в принципе есть и статусы, которые не являются ошибкой. К примеру статус редиректа
MsgBox XMLHttp.StatusText,vbCritical,XMLHttp.status
End Select
'/// Класс HTTP формы
Class HttpFormClass
'/// Коллекция полей формы
Private Fields
'/// Коллекция файлов формы
Private Files
'/// Переменные для хранения Property формы
Private PropEnctype '/// Типа кодирования
Private PropAction '/// URL на который будут отправлены данные
Private PropMethod '/// Метод которым будут отправлены данные
Private PropBoundary '/// Разделитель которым будут разделены данные
Private PropCharset '/// Кодировка в которой данные будут отправлены
'/// Процедура создания класса
Private Sub Class_Initialize
'/// Создаём коллекции для хранения полей и файлов
Set Fields = CreateObject("Scripting.Dictionary")
Set Files = CreateObject("Scripting.Dictionary")
End Sub
'/// Установка Action
Public Property Let Action(Value)
PropAction = Value
End Property
'/// Чтение Action
Public Property Get Action
if PropAction = "" Then PropAction = "about:blank"
Action = PropAction
End Property
'/// Установка Method.
Public Property Let Method(Value)
PropMethod = UCase(Value)
End Property
'/// Чтение Method. По умолчанию возвращаем GET
Public Property Get Method
if PropMethod = "" Then PropMethod = "GET"
Method = PropMethod
End Property
'/// Установка Enctype.
Public Property Let Enctype(Value)
Value = lCase(Value)
Select Case Value
Case "multipart/form-data"
PropEnctype = Value
Case Else
PropEnctype = "application/x-www-form-urlencoded"
End Select
End Property
'/// Чтение Enctype. По умолчанию "application/x-www-form-urlencoded"
Public Property Get Enctype
if PropEnctype = "" Then PropEnctype = "application/x-www-form-urlencoded"
Enctype = PropEnctype
End Property
'/// Установка кодировки отправляемых данных
Public Property Let Charset(Param)
PropCharset = Param
End Property
'/// По умолчанию Windows-1251
Public Property Get Charset
Const DefaultCharset = "Windows-1251"
if PropCharset = "" Then PropCharset = DefaultCharset
Charset = PropCharset
End Property
'/// Добавление файла
Function AddFile(FieldName,FileName)
if FileName = "" Then Exit Function
'/// Создаём объект стрим(поток)
Dim Stream
Set Stream = CreateObject("ADODB.Stream")
'/// Выставляем его тип как двоичный.
Stream.Type = 1
'/// Открываем поток
Stream.Open
'/// Загружаем необходимый нам файл
Stream.LoadFromFile FileName
'/// Складываем путь и файл в массив из двух элементов
Dim FileContentArray(2)
'/// В нулевой элемент передаём путь
FileContentArray(0) = FileName
'/// Теперь определяет тип файла. И в первый элемент сохраняем тип содержимого.
Dim FileExtension,DotPosition,ContentType
'/// Проверяем есть ли у файла расширение и получаем его в переменную.
DotPosition = InStrRev(FileName,".")
if DotPosition > 0 Then FileExtension = LCase(mid(FileName,DotPosition + 1))
'/// Выбираем известные нам типы файлов. Для примера добавлены только несколько.
Select Case FileExtension
Case "bmp","gif","jpeg","jpg","png"'/// файлы картинок
FileContentArray(1) = "image/" & FileExtension
Case "zip"'/// zip архив
FileContentArray(1) = "application/x-zip-compressed"
Case "mdb"'/// файл базы данных ACCESS
FileContentArray(1) = "application/msaccess"
Case "xls"'/// Файл EXCEL
FileContentArray(1) = "application/vnd.ms-excel"
Case "doc","dot"'/// WORD документ
FileContentArray(1) = "application/msword"
Case Else'/// Для неизвестных файлов делаем заголовок "application/octet-stream"
FileContentArray(1) = "application/octet-stream"
End Select
'/// Во второй элемент считываем содержимое
FileContentArray(2) = Stream.Read
'/// Передаём созданный массив в коллекцию
Files(FieldName) = FileContentArray
End Function
'/// Добавление поля
Public Function AddField(Name,Value)
Fields(Name) = Value
End Function
'/// Функция кодирования недопустимых символов в URL.
Public Function EncodeURIcomponent(SourceString)
Dim I, C, Out
For I = 1 To Len(SourceString)
C = Asc(Mid(SourceString, I, 1))
'/// Пробелы заменяем на плюс
If C = 32 Then
EncodeURIcomponent = EncodeURIcomponent + "+"
'/// Запрещённые символы заменяем на "%" и HEX значение от кода символа
ElseIf (C < 48 Or C > 126) Or (C > 56 And C <= 64) Then
EncodeURIcomponent = EncodeURIcomponent + "%" + Hex(C)
Else
'/// Разрещённые символы добавляем как есть
EncodeURIcomponent = EncodeURIcomponent + Chr(C)
End If
Next
End Function
'/// Функция генерации разделителей между данными.
Private Function GenerateBoundary()
Dim Char
Dim N
'/// Запускаем цикл на 12 итераций. Генерим строку из 12 символов
For N = 1 To 12
Randomize
'/// Взяты символы от a-z.
Char = Chr(CLng(Rnd * 25) + 97)
'Если порядковый номер символа кратен двум, то делаем его заглавным
if N mod 2 Then Char = UCase(Char)
GenerateBoundary = GenerateBoundary & Char
Next
End Function
'/// Получение разделителя между данными. Если он не установлен, то генерим его
Public Property Get Boundary
if PropBoundary = "" Then PropBoundary = GenerateBoundary
'/// К началу добавляем 27 символов "-". Не знаю зачем так много, но IE так делает ))
Boundary = String(27,"-") & PropBoundary
End Property
'/// Получение
Public Property Get VarBody
'/// Определяем каким методом будут отправляться данные
Select Case Method
Case "POST"
Select Case Enctype
Case "multipart/form-data"
'/// Разделитель который добавляется по умолчанию всегда
Const DefaultBoundary = "--"
'/// Открываем объект стрим на запись
Dim Stream
Set Stream = CreateObject("ADODB.Stream")
Stream.Type = 1
Stream.Mode = 3
Stream.Open
'/// Если количество полей больше 0 то перебираем их собираем их в одну переменну, добавляя заголовки
If Fields.Count > 0 Then
'/// FieldsBody - контейнер для сбора всех полей. FieldHeader - заголовок поля
Dim FieldsBody,FieldHeader
For Each FieldName in Fields
'/// Добавляем в заголовке информацию о том, что данное поле относится к данным формы. На хвосте добавляем перенос
'/// Примерный вид заголовка "Content-Disposition: form-data; name="Имя_поля"
FieldHeader = "Content-Disposition: form-data; name=""" & FieldName & """" & vbCrLf
'/// Собираем тело поля и добавляем в общую переменную.
'/// Результат сборки одного поля выглядит так
'/// -----------------------------QoJtOkQvNnHa
'/// Content-Disposition: form-data; name="Field1"
'///
'/// FieldContent
FieldsBody = FieldsBody & DefaultBoundary & Boundary & vbCrlf & FieldHeader & vbCrlf & Fields(FieldName) & vbCrlf
Next
'//// Конвертируем собранные поля в двоичные данные записываем в поток
Stream.Write StringToBinary(FieldsBody,Charset)
End if
'/// Перебираем файлы
For Each FieldName in Files
'/// Собираем заголовок
'/// Пример вида заголовка:
'/// ---------------------------QoJtOkQvNnHz
'/// Content-Disposition: form-data; name="File1"; filename="C:\file.zip"
'/// Content-Type: application/octet-stream
'///
FieldHeader = DefaultBoundary & Boundary & vbCrlf & "Content-Disposition: form-data; name=""" & FieldName & """; filename=""" & Files(FieldName)(0) & """" & vbCrlf & "Content-Type: " & Files(FieldName)(1) & vbCrLf & vbCrlf
'/// Записываем заголовок в стрим
Stream.Write StringToBinary(FieldHeader,Charset)
'/// Записываем тело файла в стрим
if Not isNull(Files(FieldName)(2)) Then Stream.Write Files(FieldName)(2)
Next
'/// И в конце передаваемых данных добавляем окончательный разделитель.
'/// ---------------------------QoJtOkQvNnHz--
Stream.Write StringToBinary(vbCrlf & DefaultBoundary & Boundary & DefaultBoundary,Charset)
'/// Переводим курсор в объекте на начало данных
Stream.Position = 0
'/// Считываем данные в VarBody
VarBody = Stream.Read
End Select
Case Else '/// На случай если форма отправляется GET-ом
Dim FieldName
'/// Собираем поля и объединяем их следующим образом "имя_поля=значение_поля&имя_поля=значение_поля"
For Each FieldName in Fields.Keys
VarBody = VarBody & EncodeURIcomponent(FieldName) & "=" & EncodeURIcomponent(Fields(FieldName)) & "&"
Next
'/// Для файлов и делаем объединение "имя_поля=путь_файла&имя_поля=путь_файла"
For Each FieldName in Files.Keys
VarBody = VarBody & EncodeURIcomponent(FieldName) & "=" & EncodeURIcomponent(Files(FieldName)(0)) & "&"
Next
'/// Убираем лищний символ "&" на хвосте
if VarBody <> "" Then VarBody = Left(VarBody,len(VarBody)-1)
End Select
End Property
'/// Конвертор текста в двоичные данные с учётом кодировки
Private Function StringToBinary(SourceString,Charset)
'/// Если текст не передан, выходим из процедуры
if isEmpty(SourceString) Then Exit Function
'/// Создаём объект для работы с двоичными данными
Dim Stream
Set Stream = CreateObject("ADODB.Stream")
With Stream
'/// Если кодировка указана, то устанавливает её
if Charset <> "" Then .Charset = Charset
'/// Настраиваем объект
'Указываем тип данных которые в него передадим
.Type = 2 'adTypeText=2; adTypeBinary=1
'Разрешаем на запись и чтение. Чтобы после передачи данных в объект, получить из него изменённые.
.Mode = 3 'adModeRead=1; adModeWrite = 2; adModeReadWrite = 3;
.Open 'Открываем объект
'/// Передаём текст в объект
.WriteText SourceString
'/// Перемещаем курсор в нулевую позицию, чтобы встать на начало данных.
.Position = 0
'/// Меняем тип данных на двоичный adTypeBinary=1
.Type = 1
'/// Возвращаем данные из функции наружу
StringToBinary = Stream.Read
End With
End Function
'//// Функция очистки полей
Public Function Clear
'/// Очищаем коллекцию полей
Fields.RemoveAll
'/// Очищаем коллекцию файлов
Fields.RemoveAll
End Function
End Class
Автор примера - Xameleon.
Предложения в русском языке начинаются с большой буквы и заканчиваются точкой.
В названии ветки всегда должен быть указан язык программирования или среда исполнения скрипта, если это возможно.
Так что теперь WebFormClass v.3.0 ))
