захват из интернета

[Invader]

как осущиствить захват скажем погоды с сайта чтоб инфу отображать
в своей проге при существующем подключении к интернет или из проги своей записав значение поиска в тексбокс, отправить в нет в форму поиска гугл либо вики, не вызывая браузер интернета

[r0ot]

видел такую тему вчера...попробуй поюзать поиск

[Invader]

без обращения к браузеру IE

[Хакер]

http://bbs.vbstreets.ru/viewtopic.php?t=35009

[Invader]

пасибо конечно только вот клиент окно мне не надо да и label интересно но не то мне для переменой надо а ятам уж картинками результаты украшать буду типа рабочий стол осень дождливая, лес в пурге ну не важно мне не с конкретного сайта а с любого , да и где там про обращения к серверу поиска я не нашёл...

[Хакер]

"Казнить нельзя помиловать".

Расставь запятые, а то написанное можно истолковать двояко.

[Invader]

Хакер
спасибо выручил; только вот в коде:

Set XmlHttp = CreateObject("Microsoft.XmlHttp")

Xmlhttp.Open "GET","http://www.mail.ru",False

XmlHttp.Send


мы принимаем данные, а как отправить, скажем в форму поиска?
"GET" на "SET"????

[Lumen]

SET? Это что такое?
Отправить можно с помощью того же GET или POST

[Хакер]

Invader
Не выручил.

Почему вас всех так танят использовать этот долбаный XmlHTTP, да ещё и (скорее всего) late-bounding?

[BION]

Хакер
спасибо выручил; только вот в коде:

Set XmlHttp = CreateObject("Microsoft.XmlHttp")

Xmlhttp.Open "GET","http://www.mail.ru",False

XmlHttp.Send


мы принимаем данные, а как отправить, скажем в форму поиска?
"GET" на "SET"????

Думаю можно так(у меня работает на ура):

Код: Выделить всё

Dim query$, host$
host = "http://host.ru"
query = "param1=1&param2=2"

XmlHttp.open "POST", host + "/index.py", False
XmlHttp.setRequestHeader "Accept", "text/plain"
XmlHttp.setRequestHeader "Accept", "text/html"
XmlHttp.setRequestHeader "Host", host
XmlHttp.setRequestHeader "Content-Length", CStr(Len(query))

XmlHttp.send query

[ALX_2002]

Вот наваял примерчик. Выглядит громоздко в основном из-за функций перевода UTF-8 в Winows-1251 и Наоборот. В коде 2 основных класса.

FormClass - класс формы для постороения запроса
RequestClass - класс отправки данных через XmlHttp c поддержкой

как обычной асинхронности XmlHttp так и множественных запросов на основе создания множества копий XmlHttp. Результат обработки сваливается в процедуры Progress (процесс загрузки) и Complete (окончание выполнения запроса)

Наверняка можно сделать всё удобнее, но это уже в ваших руках

Код: Выделить всё


Dim Form

Set Form = New FormClass

Form("Element1") = "Element1"
Form("Element2") = "Element2"
Form("Element3") = "Element3"
Form("Element4") = "Element4"

Form.Action = "http://URL"
Form.Method = "POST"

Submit Form

'/// Дефолтовая процедура
Public Sub Request_OnComplete(Request)
End Sub

'/// Дефолтовая процедура окончания запроса
Public Sub Request_OnProgress(Request)
End Sub

'/// Класс для отправки данных
Class RequestClass
   Private XmlHttpRequest

   Public ID,Method,varBody,Async,User,Password,Cache

   Private PropertyUrl
   Private PropertyCharset
   '/// Чтобы повторно не разбирать Content-Type ставим флаг
   Private CharsetParsed

   Public CallBack
   
   Private Sub Class_Initialize
      Async = True
      Set XmlHttpRequest = CreateObject("MSXML2.XMLHTTP")
      'Set XmlHttpRequest = CreateObject("Microsoft.XmlHttp")
      Cache = False
      Method = "GET"
   End Sub

   '//// URL
   Public Property Let Url(Param)
      PropertyUrl = Param   
   End Property
   
   Public Property Get Url()
      Url = PropertyUrl
   End Property

   '/// Получение кодировки данных
   Public Property Get ResponseCharset()
      if Not CharsetParsed Then
         ContentType = XmlHttpRequest.GetResponseHeader("Content-Type")
         ContentType = Replace(ContentType," ","")
         ContentType = Split(ContentType,";")
         For Each ParamGroup in ContentType
            Params = Split(ParamGroup,"=")
            if LCase(Params(0)) = "charset" and Ubound(Params) = 1 Then
               PropertyCharset = Params(1)
               CharsetParsed = True
            End if
         Next
      End if
      ResponseCharset = PropertyCharset
   End Property

   '//// Установка и получение Заголовков для отправки
   Public Property Let SetRequestHeader(HeaderName,HeaderValue)
      If XMLHttpRequest.readystate <> 1 Then Exit Property
      XMLHttpRequest.setRequestHeader HeaderName,HeaderValue
   End Property

   Public Function Open
      XMLHttpRequest.Abort

      if CallBackIsObject Then
         XMLHttpRequest.onreadystatechange = CallBack
      Else
         XMLHttpRequest.onreadystatechange = Me
      End if
      
   
      If UCase(Method) = "GET" Then PropertyUrl = PropertyUrl & "?" & VarBody

      MsgBox Method & "|" & Url & "|" & Async & "|" & User & "|" & Password & "|"

      if PropertyUrl = "" Then Exit Function

      XMLHttpRequest.Open Method,Url,Async,User,Password

      If Not Cache Then
         XMLHttpRequest.SetRequestHeader "If-Modified-Since",Now
         XMLHttpRequest.SetRequestHeader "Cache-Control","must-revalidate"
      End if      

      Open = True
   End Function
   
   Public Function Send
      If XMLHttpRequest.readystate <> 1 Then Exit Function
      XMLHttpRequest.Send varBody
      Send = True
   End Function

   Public Property Get Status
      Status = XmlHttpRequest.Status
   End Property

   Public Property Get StatusText
      StatusText = XmlHttpRequest.StatusText
   End Property
   
   Public Property Get GetResponseHeader(HeaderName)
      GetResponseHeader = XMLHttpRequest.GetResponseHeader(HeaderName)
   End Property

   Public Property Get ResponseText
      Select Case UCase(ResponseCharset)
      Case "WINDOWS-1251"
         ResponseText = XMLHttpRequest.ResponseText
      Case Else
         ResponseText = XMLHttpRequest.ResponseText
      End Select
   End Property

   Public Property Get ResponseBody
      ResponseBody = XMLHttpRequest.ResponseBody
   End Property
   
   Public Default Function onreadystatechange
      Select Case XMLHttpRequest.readyState
      Case 4
         Request_OnComplete Me 'Response
      Case Else
         Request_OnProgress Me
      End Select
   End Function
End Class


'/// Класс форма
Class FormClass

   Public Name

   Public Action

   Public Method
   
   Private Fields

   Private Sub Class_Initialize
      Set Fields = CreateObject("Scripting.Dictionary")
   End Sub

   Public Property Let Field(FieldName,FieldValue)
      FieldName = Escape(FieldName) 'encodeURIComponent(FieldName)
      FieldValue = Escape(FieldValue) 'encodeURIComponent(FieldValue)
      Fields(FieldName) = FieldValue
   End Property

   Public Default Property Get Field(FieldName)
      Field = Fields(FieldName)
   End Property
   
   Public Sub Clear
      Fields.RemoveAll
   End Sub
   
   Public Property Get VarBody
      For Each Key in Fields.Keys
           VarBody =  VarBody & Key & "=" & Fields(Key) & "&"
      Next
      VarBody = Left(VarBody,len(VarBody)-1)
   End Property
End Class

Function Submit(Form)
   With Request
      .ID = Form.Name
      .Method = Form.Method
      .URL = Form.Action
      .Open
      .SetRequestHeader("Content-Type") = "application/x-www-form-urlencoded; charset=UTF-8"
      .varBody = Form.VarBody
      .Send
      Form.Clear
   End With
End Function

' http://www.fisz.nl
'IsValidUTF8
' Tells if the string is valid UTF-8 encoded
'Returns:
' true (valid UTF-8)
' false (invalid UTF-8 or not UTF-8 encoded string)

Function IsValidUTF8(s)
   Dim i
   Dim c
   Dim n

   IsValidUTF8 = false
   i = 1
   do while i <= len(s)
      c = asc(mid(s,i,1))
      if c and &H80 then
         n = 1
         do while i + n < len(s)
         If (asc(mid(s,i+n,1)) and &HC0) <> &H80 then
            exit do
         End if
         n = n + 1
         loop
         Select case n
         Case 1
            exit function
         Case 2
            if (c and &HE0) <> &HC0 then
               exit function
            End if
         Case 3
            if (c and &HF0) <> &HE0 then
               exit function
            End if
         Case 4
            if (c and &HF8) <> &HF0 then
               exit function
            End if
         Case else
            Exit function
         End select
         i = i + n
      Else
         i = i + 1
      End if
   loop
   IsValidUTF8 = true
End function

'DecodeUTF8
' Decodes a UTF-8 string to the Windows character set
' Non-convertable characters are replace by an upside
' down question mark.
'Returns:
' A Windows string
Function DecodeUTF8(s)
   Dim i
   Dim c
   Dim n

   i = 1
   Do while i <= len(s)
      c = asc(mid(s,i,1))
      If c and &H80 then
         n = 1
         Do while i + n < len(s)
            if (asc(mid(s,i+n,1)) and &HC0) <> &H80 then
            Exit do
            End if
            n = n + 1
         Loop
         if n = 2 and ((c and &HE0) = &HC0) then
         c = asc(mid(s,i+1,1)) + &H40 * (c and &H01)
      Else
         c = 191
      End if
      s = left(s,i-1) + chr(c) + mid(s,i+n)
      End if
      i = i + 1
   Loop
   DecodeUTF8 = s
End function

'EncodeUTF8
'/// Кодирует Windows строку в UTF-8
'Возвращает:
'/// Закодированную в UTF-8 строку
function EncodeUTF8(s)
   Dim i
   Dim c

   i = 1
   Do while i <= len(s)
      c = asc(mid(s,i,1))
   if c >= &H80 then
      s = left(s,i-1) + chr(&HC2 + ((c and &H40) / &H40)) + chr(c and &HBF) + mid(s,i+1)
      i = i + 1
   End if
      i = i + 1
   loop
   EncodeUTF8 = s
End function



[Invader]

вы не шутите, аж даже так!!! переберу код (попытаюсь разобраться ), но за отклик и найденое время спасибо!

[Invader]

значит ещё раз буду конкретней
1. Есть страница www.google.ru, в её коде есть строчка
INPUT title="Поиск в Google" maxLength=2048 size=55 name=q
autocomplete="off"
если добавить параметр
INPUT title="Поиск в Google" maxLength=2048 size=55 name=q
autocomplete="off"
value="что нового!"
то в строке поиска появиться: "что нового!"

ещё есть кнопка <INPUT type=submit value="Мне повезёт!" name=btnI> цель

2.цель, переводить запрос из программы(из переменной$) в строку поиска google и затем нажать кнопку поиска, не исключаю что идея
не самая удачная - так как браузер вместе с его окном не нужен; и возможно есть способ прямого запроса на поисковый сервер но КАК

либо может есть у кого сылки о созданиях гаджетов для IE