порт информации с сайта, в таблицу, поиск ошибки

[umnyakhin]

Короче необходимо забрать индексы с сайта
btk-online.ru
Есть таблица эксель с городами в нужной кодировке. В столбце первом название города, во втором региона.
и есть соответственно скрипт.

Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_OPEN_TYPE_PROXY = 3
Private Const scUserAgent = "VB Project"
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" (ByVal hOpen As Long, ByVal sUrl As String, ByVal sHeaders As String, ByVal lLength As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetReadFile Lib "wininet.dll" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
 
Private Function OpenURL(ByVal sUrl$)
'On Error GoTo error_handler
 
    Dim hOpen As Long
    Dim hOpenUrl As Long
    Dim bDoLoop As Boolean
    Dim bRet As Boolean
    Dim sReadBuffer As String * 2048
    Dim lNumberOfBytesRead As Long
    Dim sBuffer$
    hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
    hOpenUrl = InternetOpenUrl(hOpen, sUrl, vbNullString, 0, INTERNET_FLAG_RELOAD, 0)
    bDoLoop = True
    While bDoLoop
        sReadBuffer = vbNullString
        bRet = InternetReadFile(hOpenUrl, sReadBuffer, Len(sReadBuffer), lNumberOfBytesRead)
        sBuffer = sBuffer & Left$(sReadBuffer, lNumberOfBytesRead)
        If Not CBool(lNumberOfBytesRead) Then bDoLoop = False
    Wend
    If hOpenUrl <> 0 Then InternetCloseHandle (hOpenUrl)
    If hOpen <> 0 Then InternetCloseHandle (hOpen)
    OpenURL = sBuffer
    
    
exit_statements:
    Exit Function
 
'error_handler:
'    Call log_errors(Err.Description)
'    Resume exit_statements
 
End Function
 
Sub wiki_zip_nas()
 
    Dim st As String
    Dim pos2 As Long, pos1 As Long
    Dim i As Integer
    Dim str_dim As Variant
    Dim city As String
    i = 2
    
    While ActiveSheet.Cells(i, 1).Value <> ""
        city = ActiveSheet.Cells(i, 1).Value
        region = ActiveSheet.Cells(i, 2).Value
         If city <> "" Then
            If region = "" Then
                st = OpenURL("http://www.btk-online.ru/postrus/?&region=&postcodeno=&town=" & city)
            Else
                st = OpenURL("http://www.btk-online.ru/postrus/?&region=" & region & "&postcodeno=&town=" & city)
            End If
            
            pos1 = 0
            pos2 = 0
    
            pos1 = InStr(pos1 + 1, st, "<tr id=odd> <td><a href=?postcodeno=")
            pos2 = InStr(pos1 + 1, st, "</a></td>")
            
            If pos1 = 0 Or pos2 = 0 Then
                ActiveSheet.Cells(i, 6).Value = "НЕТ ДАННЫХ"
            Else
                str_dim = Split(Mid(st, pos1 + 36, pos2 - pos1 - 8))
                ActiveSheet.Cells(i, 5).Value = str_dim
            End If
    
            DoEvents
        End If
Debug.Print i
        i = i + 1
    Wend

В нем точно, что то не так) помогите разобраться. Значения идексов нужно выгружать в 3 и последующие столбцы. Заранее всем спасибо!!!

[Bape}l{ka]

вы б хоть сказали, где ругается

[umnyakhin]

Он не выдает значений. Пишет нет данных. Скрипт работает сам. Но где то есть неточности....

[EducatedFool]

Что-то слишком много букв в вашем скрипте...
Вы бы лучше прикрепили свой файл Excel, и показали, где и какую информацию надо получать с сайта.

Есть разные способы получения данных с сайта (например, веб-запросы и другие функции) - но вы, похоже, выбрали самый сложный путь.

Примеры веб-запросов:
http://excelvba.ru/programmes/Rating_and_Ranking
http://excelvba.ru/programmes/MoviesSearch

Примеры других функций:
http://excelvba.ru/code/CurrencyRate
http://excelvba.ru/code/GetHTTPResponse
http://excelvba.ru/code/GetWebPageText

[doober]

Плюс к выше сказанному EducatedFool страница в кодировке Utf8,на это надо внимание обратить

[umnyakhin]

каким образом учесть кодировку?

[EducatedFool]

А функцию перекодировки можно найти здесь:
http://excelvba.ru/code/URLEncode

[doober]

Сообщение от umnyakhin

каким образом учесть кодировку?

Например для МОСКВА,должна быть такая URL
?region=%D0%9C%D0%9E%D0%A1%D0%9A%D0 %92%D0%90&postcodeno=

Прочитать можно здесь

[umnyakhin]

даа, это перекодировка выполнена..