Ситуация в следующем, есть непрерывно работающий макрос по парсингу вебстраницы (регулярные запросы на сайт, извлечение в виде текста, и в случае поступления новой информации на этом сайте, передаче этой новой информации в группу телеграмм), иногда рандомно может 1 раз в сутки или 1 раз в 4-5 часов выскакивает ошибка " vba excel 91 object variable or with block variable not set" в строке помеченной в коде ниже и выполнение макроса соответственно останавливается что есть очень плохо так как я не могу постоянно отслеживать эту ошибку. Может есть мысли в чем причина?.P.S прошу не судить строго по коду, слепил из того что нашел в сети
| Код |
|---|
Public Function EncodeUTF8(str As String)
Dim ScriptEngine As Object
Set ScriptEngine = CreateObject("ScriptControl")
ScriptEngine.Language = "JScript"
EncodeUTF8 = ScriptEngine.Run("encodeURIComponent", str)
End Function
Function getText(ByRef url As String) As String
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", url, False
.send Null
getText = .responseText
End With
End Function
Sub Test()
Dim myFile As Object, myTag As Object
Dim pageText As String, Message As String
Const url As String = "https://mob.della.ua/results/?geo=a164bdeflolh6k0m"
Dim Data As String, marshrut As String, gruz As String, fraht As String
Application.OnTime Now + TimeValue("00:00:05"), "test"
pageText = getText(url)
Set myFile = CreateObject("HTMLFile")
myFile.body.innerHTML = pageText
Set myTag = myFile.getElementsByTagName("td")
Data = myTag(6).innerText '6 дата ВОТ ЗДЕСЬ И ВЫСКАКИВАЕТ ОШИБКА!!!, если убрать переменную Дата, то будет уже ошибка в след. в marshrut
Data = Data + " "
marshrut = myTag(7).innerText '7 маршрут
marshrut = marshrut + " "
gruz = myTag(9).innerText '9 груз
gruz = gruz + " "
fraht = myTag(10).innerText '10 фракт
fraht = fraht + " "
txt$ = Data & marshrut & gruz & fraht & url
If txt$ <> [A5] Then [A5] = txt$ Else End
Message = [A5]
Message = EncodeUTF8(Message)
sURI = "https://api.telegram.org/bot5036799064:AAEWVM0WlYPDyWLJobanFv47FKv_D-YUFd8/sendMessage?chat_id=-1001707707704&text=" & Message
On Error Resume Next
Set oHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
If Err.Number <> 0 Then
Set oHttp = CreateObject("MSXML.XMLHTTPRequest") 'можно ли здесь "MSXML.XMLHTTPRequest" заменить на "MSXML2.XMLHTTP"
' т.к MSXML.XMLHTTPRequest не работает или у них разное назнаечение?
End If
On Error GoTo 0
If oHttp Is Nothing Then Exit Sub
oHttp.Open "GET", sURI, False
oHttp.send
Set oHttp = Nothing
End Sub |
