P.S Упёрся в то, что в VB нет функци Escape Есть ли где нибудь её исходник или что нибудь на замену ей ? Да и вообще на замену всей этой громосткости ?
- Код: Выделить всё
Login
Sub Login
Dim HttpRequest
Set HttpRequest = New HttpRequestClass
Dim UserName,Password
Title = "Заход на форум http://bbs.vbstreets.ru"
username = InputBox("Логин",Title)
password = InputBox("пароль",Title)
HttpRequest.AddVar "username",username
HttpRequest.AddVar "password",password
HttpRequest.AddVar "login","Вход"
HttpRequest.Send "POST","http://bbs.vbstreets.ru/login.php"
If HttpRequest.Status = 200 then
Set HTMLDocument = CreateObject("HTMLFile")
HTMLDocument.Open
HTMLDocument.Write "<HTML><BODY></BODY></HTML>"
HTMLDocument.body.innerhtml = HttpRequest.ResponseText
HTMLDocument.Close
For Each SPAN in HTMLDocument.body.all.tags("SPAN")
If SPAN.classname="gen" Then
MsgBox "Учётная запись отсутствует или пароль неверен !",vbExclamation,"Ошибка !!!"
Exit Sub
End if
Next
MsgBox "Вы успешно зашли на сайт.",vbInformation
Else
MsgBox HttpRequest.Status & " " & HttpRequest.StatusText,vbExclamation,"Request Error"
End if
End Sub
'///////////// Класс модуль
Class HttpRequestClass
Private Dictionary
Private XmlHttp
Private Stream
Private ByteData
Private adTypeText
Private adTypeBinary
Public DefaultCharset
Public RequestCharset
Public ResponseCharset
Public Status
Public StatusText
Public ResponseText
Sub Class_Initialize
On Error Resume Next
Set XmlHttp = CreateObject("Microsoft.XmlHttp")
if Err.Number <> 0 Then
MsgBox "Не удалось создать компонент Microsoft.XmlHttp",vbCritical
Exit Sub
End if
Set Stream = CreateObject("ADODB.Stream")
if Err.Number <> 0 Then
MsgBox "Не удалось создать компонент ADODB.Stream",vbCritical
Exit Sub
End if
adTypeText = 2
adTypeBinary = 1
Set Dictionary = CreateObject("Scripting.Dictionary")
if Err.Number <> 0 Then
MsgBox "Не удалось создать компонент Scripting.Dictionary",vbCritical
Exit Sub
End if
DefaultCharset = "Windows-1251"
RequestCharset = DefaultCharset
ResponseCharset = DefaultCharset
End Sub
Function AddVar(VarName,VarValue)
VarValue = Escape(VarValue)
Dictionary(VarName) = VarValue
End Function
Function Send(METHOD,URL)
Dim VarBody
For Each Var in Dictionary
VarBody = VarBody & Var & "=" & Dictionary(Var) & "&"
Next
VarBody = Left(VarBody,Len(VarBody)-1)
ByteData = TextToBytes(VarBody,RequestCharset)
METHOD = UCase(METHOD)
If METHOD <> "POST" Then METHOD = "GET"
if METHOD = "GET" Then
URL = URL & "?" & VarBody
XmlHttp.Open METHOD,URL,False
Else
XmlHttp.Open METHOD,URL,False
XmlHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
End if
XmlHttp.setRequestHeader "Cache-Control", "no-cache"
XmlHttp.Send ByteData
Charset = ResponseCharset
Groups = Split(XmlHttp.GetResponseHeader("Content-type"),";")
For Each Group in Groups
Group = Split(Group,"=")
if Ubound(Group)=1 Then
Group(0) = Trim(LCase(Group(0)))
if Group(0)="charset" then Charset = Trim(Group(1))
Exit For
End if
Next
ResponseText = BytesToText(XmlHttp.ResponseBody,Charset)
Status = XmlHttp.Status
StatusText = XmlHttp.StatusText
End Function
Private Function TextToBytes(TextData,Charset)
if IsEmpty(TextData) Then Exit Function
With Stream
.Type = adTypeText
if Charset <> "" Then .Charset = Charset
.Open
.WriteText TextData
.Position = 0
.Type = adTypeBinary
TextToBytes = Stream.Read
.Close
End With
End Function
Private Function BytesToText(ByteData,Charset)
if IsEmpty(ByteData) Then Exit Function
With Stream
.Type = adTypeBinary
.Open
.Write ByteData
.Position = 0
.Type = adTypeText
if Charset <> "" Then .Charset = Charset
BytesToText = Stream.ReadText
.Close
End With
End Function
End Class
