Я работаю над PowerPoint с поддержкой VBA, который получает фид с rssweather.com и анализирует его, чтобы найти текущую погоду (в текущем состоянии пока этого не происходит.) Пока что я использую getPageText чтобы получить фид в виде файла XML, а затем начать его синтаксический анализ (иногда при синтаксическом анализе возникает ошибка индекса. В настоящее время я изучаю это, но это не связано с вопросом, который я публикую). Я хотел иметь текстовый документ, который содержит канал для сравнения с входящим потоком и проверяет наличие изменений формата (так как это отключит анализатор). Моя проблема в том, что когда я пытаюсь получить содержимое файла, VBA не может его найти (он находится в том же каталоге, что и PowerPoint. Я кое-что прочитал, и вот некоторые из вещей, которые я пробовал, у других людей были проблемы с - перемещением файла в другое место и попыткой нового пути к файлу - проверкой скрытых атрибутов или атрибутов только для чтения - проверкой опечаток в пути к файлу (я пробовал вырезать и вставлять из файлового проводника) - проверкой escape / специальных символов в пути к файлу - убедиться, что файл не находится на сетевом диске (я использую RDP в P C для работы с PowerPoint, но файлы хранятся на его рабочем столе) - пробовать чужой рабочий код - проверять права доступа - добавлять backsla sh перед именем файла (функции, возвращающие рабочий каталог, не делают этого за вас)
Вот мой код, который получает фид:
Function getPageText(url As String) 'this function is used to get webpage data. in our Macro, it gets the current weather from www.rssweather.com
Dim waited As Integer 'used to see if webpage is responding
Dim temp 'this variable is involved when seeing i the webpage is done downloading
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", url
.send
'get the text
On Error GoTo Retry
getPageText = .responseText 'return as one massive string
End With
'attempt to use webpage and catch with error
Retry:
'bump up waited for entering
waited = waited + 1
'check for timeout
If waited = 30 Then GoTo No_connection 'if no response after 30 seconds, display error
'no timeout so try again
On Error GoTo Retry
Counters.Wait (1)
temp = getPageText
Exit Function
No_connection:
MsgBox "Error: RSS feed timed out. Please check the connection or contact your local VBA expert."
'kill the timers
Call KillOnTime
'set the function to nothing so WeatherUpdate will recogize it as an error in the rss feed format checking
getPageText = ""
End Function
Вот мой код, должен сравнивать и анализировать фид:
Sub WeatherUpdate()
'setup variables to represent the textboxes actual fields for ease of use
Dim curr As String
Dim fore As String
Dim img As String
curr = ""
fore = ""
img = ""
'get rss feed. getPageText returns the content in XML code as one massive string
Dim webcontent As String
webcontent = getPageText("http://www.rssweather.com/zipcode/24523/rss.php")
'verify rss feed is still using the same format CHECK LENGTH TOO
Dim iFile As Integer
Dim examplecontent As String
iFile = FreeFile
Open ActivePresentation.Path & "\Example RSS Feed.txt" For Input As iFile
examplecontent = Input(LOF(iFile), iFile)
Close iFile
'Debug.Print examplecontent
'Debug.Print simil(examplecontent, webcontent)
'start scraping out the XML code and keep the text we want by using XML features
curr = curr & Split(Split(webcontent, "<title>")(2), "F")(0) & "ºF, " & Split(Split(webcontent, "<span class=" & Chr(34) & "sky" & Chr(34) & ">")(1), "<")(0) ' this grabs the text between <title> and </title> to use as current conditions title
img = Split(Split(Split(webcontent, "<img src=" & Chr(34))(1), Chr(34))(0), "fcicons/")(1) 'this complicated splitting grabs the image name out of a webaddress so we know what icon/weather symbol they are trying to use so we can pick the same
webcontent = Right(webcontent, Len(webcontent) - Len(Split(webcontent, "<dd id=" & Chr(34))(0)) - 8) 'this shortens and simplifies the overall webcontent string by cutting out the beginning we took curr and img from
curr = curr & vbCrLf & "Humidity: " & Split(Split(webcontent, ">")(1), "<")(0) 'grab humidity value and pack it nicely into "Humidity: [value]"
curr = curr & vbCrLf & "Windspeed: " & Split(Split(webcontent, ">")(5), "<")(0) 'grab windspeed value
curr = curr & vbCrLf & "Wind Direction: " & Split(Split(webcontent, ">")(9), "(")(0) 'grab winddir value
'curr is now filled with what is needed. cut out the XML crap to skip to the next area
webcontent = Split(webcontent, "</guid>")(1)
'next, all forecast entries follow the same format. we will have to store them in a string array and refer to each area by index
Dim forecontent() As String
forecontent = Split(webcontent, "<item>")
'fill out the forecast for day+1 (index 3)
'start the timer to run again in an hour
'Call StartOnTime
End Sub
Вот мой код для you
Option Explicit
Dim weatherImage As Shape 'this variable will hold the location of the weather slide's changing image
Dim weatherCurrent As Shape 'this variable will hold the location of the current weather text on the weather slide
Dim weatherForecast As Shape 'this variable will hold the location of the forecast text on the weather slide
'timer code. runs a sub every x miliseconds. retrieved from https://social.msdn.microsoft.com/forums/en-US/9f6891f2-d0c4-47a6-b63f-48405aae4022/powerpoint-run-macro-on-timer. Thanks for the help user SJOO!
Dim lngTimerID As Long
Dim blnTimer As Boolean
Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal _
lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Sub StartOnTime()
If blnTimer Then
lngTimerID = KillTimer(0, lngTimerID)
If lngTimerID = 0 Then
MsgBox "Error : Timer Not Stopped"
Exit Sub
End If
blnTimer = False
Else
lngTimerID = SetTimer(0, 0, 3600000, AddressOf WeatherUpdate) 'modified from HelloTimer to Weather Update and timer length from 5 seconds (5000) to an hour (3600000)
If lngTimerID = 0 Then
MsgBox "Error : Timer Not Generated "
Exit Sub
End If
blnTimer = True
End If
End Sub
Sub KillOnTime()
lngTimerID = KillTimer(0, lngTimerID)
blnTimer = False
End Sub
'end of timer code
Function getPageText(url As String) 'this function is used to get webpage data. in our Macro, it gets the current weather from www.rssweather.com
Dim waited As Integer 'used to see if webpage is responding
Dim temp 'this variable is involved when seeing i the webpage is done downloading
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", url
.send
'get the text
On Error GoTo Retry
getPageText = .responseText 'return as one massive string
End With
'attempt to use webpage and catch with error
Retry:
'bump up waited for entering
waited = waited + 1
'check for timeout
If waited = 30 Then GoTo No_connection 'if no response after 30 seconds, display error
'no timeout so try again
On Error GoTo Retry
Counters.Wait (1)
temp = getPageText
Exit Function
No_connection:
MsgBox "Error: RSS feed timed out. Please check the connection or contact your local VBA expert."
'kill the timers
Call KillOnTime
'set the function to nothing so WeatherUpdate will recogize it as an error in the rss feed format checking
getPageText = ""
End Function
Function charAt(str As String, index As Integer)
charAt = CChar(Mid(str, index, 1))
End Function
Function simil(str1 As String, str2 As String) 'this function returns the percent similar two strings are. this is used to determine if the rss feed has had a format change
'total number of similar characters
Dim total As Long
'str1 should be the shortest, switch them if they are not
If Len(str1) >= Len(str2) Then
Dim temp As String
temp = str1
str1 = str2
str2 = temp
'iterate through the str1 and compare characters
Dim i As Integer
For i = 1 To Len(str1)
If charAt(str1, i) = charAt(str1, i) Then
total = total + 1
End If
Next i
'return percent similar as a percent! aka already multiplied by 100
simil = total / Len(str2)
End Function
Sub weatherFind() 'this sub locates the weather slide and assigns weatherImage and weatherText to their respective location
Dim i As Integer
Dim j As Integer
'2D loop to go through each slide and each image on the slide
For i = 1 To ActivePresentation.Slides.Count
For j = 1 To ActivePresentation.Slides(i).Shapes.Count
If StrComp(ActivePresentation.Slides(i).Shapes(j).Name, "weather_curr") = 0 Then
Set weatherCurrent = ActivePresentation.Slides(i).Shapes(j)
End If
If StrComp(ActivePresentation.Slides(i).Shapes(j).Name, "weather_fore") = 0 Then
Set weatherForecast = ActivePresentation.Slides(i).Shapes(j)
End If
If StrComp(ActivePresentation.Slides(i).Shapes(j).Name, "weather_img") = 0 Then
Set weatherImage = ActivePresentation.Slides(i).Shapes(j)
End If
Next j
Next i
'trigger the weather update now and every hour
Call WeatherUpdate
End Sub
Sub WeatherUpdate()
'setup variables to represent the textboxes actual fields for ease of use
Dim curr As String
Dim fore As String
Dim img As String
curr = ""
fore = ""
img = ""
'get rss feed. getPageText returns the content in XML code as one massive string
Dim webcontent As String
webcontent = getPageText("http://www.rssweather.com/zipcode/24523/rss.php")
'verify rss feed is still using the same format CHECK LENGTH TOO
Dim iFile As Integer
Dim examplecontent As String
iFile = FreeFile
Open ActivePresentation.Path & "\Example RSS Feed.txt" For Input As iFile
examplecontent = Input(LOF(iFile), iFile)
Close iFile
'Debug.Print examplecontent
'Debug.Print simil(examplecontent, webcontent)
'start scraping out the XML code and keep the text we want by using XML features
curr = curr & Split(Split(webcontent, "<title>")(2), "F")(0) & "ºF, " & Split(Split(webcontent, "<span class=" & Chr(34) & "sky" & Chr(34) & ">")(1), "<")(0) ' this grabs the text between <title> and </title> to use as current conditions title
img = Split(Split(Split(webcontent, "<img src=" & Chr(34))(1), Chr(34))(0), "fcicons/")(1) 'this complicated splitting grabs the image name out of a webaddress so we know what icon/weather symbol they are trying to use so we can pick the same
webcontent = Right(webcontent, Len(webcontent) - Len(Split(webcontent, "<dd id=" & Chr(34))(0)) - 8) 'this shortens and simplifies the overall webcontent string by cutting out the beginning we took curr and img from
curr = curr & vbCrLf & "Humidity: " & Split(Split(webcontent, ">")(1), "<")(0) 'grab humidity value and pack it nicely into "Humidity: [value]"
curr = curr & vbCrLf & "Windspeed: " & Split(Split(webcontent, ">")(5), "<")(0) 'grab windspeed value
curr = curr & vbCrLf & "Wind Direction: " & Split(Split(webcontent, ">")(9), "(")(0) 'grab winddir value
'curr is now filled with what is needed. cut out the XML crap to skip to the next area
webcontent = Split(webcontent, "</guid>")(1)
'next, all forecast entries follow the same format. we will have to store them in a string array and refer to each area by index
Dim forecontent() As String
forecontent = Split(webcontent, "<item>")
'fill out the forecast for day+1 (index 3)
'start the timer to run again in an hour
'Call StartOnTime
End Sub
И вот доказательство того, что файл действительно существует:
игра в прятки с примером RSS Feed.txt
Спасибо за ваша помощь! :)