실시간 RSS 뉴스와 날씨 슬라이드쇼

실시간으로 RSS 자료를 읽어오는 샘플입니다.

특히 날시 자료와 JTBC, NewsWire 등의 뉴스RSS 자료를 가져오는 예제입니다.

RSS 데이터는 XML 라이브러리를 이용합니다.

첫번째 NewsWire 버전인데 캡쳐 영상으로 보겠습니다.

weathernewsRSS1.pptm

날씨는 BBC 자료입니다.

두번째는 JTBC RSS 뉴스자료를 계속 갱신하는 예제입니다.

NewsWire 보다 디자인이 화려해졌습니다.

마찬가지로 캡쳐 영상 보시겠습니다.

3페이지 정도에 걸쳐서 실시간 뉴스를 보여줍니다.

병원이나, 각종 건물 안내실, 대기실 등에서 TV화면에 틀어주는 화면으로 어떨까 싶습니다.

물론 좀더 컨텐츠를 보강할 필요가 있겠습니다.

두번재 파일의 매크로 소스입니다.

'/// 모듈 1 *******************************************************
 
'도구-참조에서 Microsoft XML 6/5/4 or 3.0 Library 에 반드시 체크할 것!
 
Const MAIN As Integer = 2   '메인 슬라이드 번호
 
Sub getWeather()
    
    Dim URL As String
    Dim xDoc As MSXML2.DOMDocument
    Dim xEntry As MSXML2.IXMLDOMNodeList
    Dim xChild As MSXML2.IXMLDOMNode
    Dim sld As Slide, shp As Shape
    Dim i As Long, j As Long, p As Long
    Dim temp() As String, temp_min As String, temp_max As String
    Dim sunrise As String, sunset As String, wday As String
    
    URL = "https://weather-broker-cdn.api.bbci.co.uk/en/forecast/rss/3day/1835848"   ' BBC 날씨예보
    Set xDoc = New MSXML2.DOMDocument
    xDoc.async = False
    'xDoc.validateOnParse = False
    xDoc.Load URL
    
    Set xChild = xDoc.SelectSingleNode("//rss/channel/image/url")
    
    For p = 0 To 3
        Set sld = ActivePresentation.Slides(MAIN + p)
        Set shp = sld.Shapes("w_icon")
        On Error Resume Next
        shp.Fill.UserPicture xChild.Text    '이미지 없을 경우 에러
        On Error GoTo 0
        
        Set xEntry = xDoc.SelectNodes("//rss/channel/item")
        i = 0
        For Each xChild In xEntry
            '<item>
            '  <title>Saturday: Sunny, Minimum Temperature: -8째C (18째F) Maximum Temperature: 2째C (36째F)</title>
            '  <link>https://www.bbc.co.uk/weather/1835848?day=1</link>
            '  <description>Maximum Temperature: 2째C (36째F), Minimum Temperature: -8째C (18째F), Wind Direction: Westerly, Wind Speed: 9mph, Visibility: Good, Pressure: 1025mb, Humidity: 46%, UV Risk: 3, Pollution: -- , Sunrise: 07:21 KST, Sunset: 18:12 KST</description>
            '  <pubDate>Fri, 15 Feb 2019 12:04:17 GMT</pubDate>
            '  <guid isPermaLink="false">https://www.bbc.co.uk/weather/1835848-1-2019-02-15T09:00:00.000+0000</guid>
            '  <dc:date>2019-02-15T12:04:17Z</dc:date>
            '  <georss:point>37.566 126.9784</georss:point>
            '</item>
            i = i + 1
        
            wday = "(" & UCase(Left(xChild.SelectSingleNode("title").Text, 3)) & ") "
            '최저기온, 최고기온, 일출, 일몰
            temp = Split(xChild.SelectSingleNode("description").Text, ", ")
            temp_min = "": temp_max = "": sunrise = "": sunset = ""
            For j = 0 To UBound(temp)
                If InStr(temp(j), "Minimum Temperature: ") > 0 Then temp_min = Split(temp(j), " ")(2)
                If InStr(temp(j), "Maximum Temperature: ") > 0 Then temp_max = Split(temp(j), " ")(2)
                If InStr(temp(j), "Sunrise: ") > 0 Then sunrise = Split(temp(j), " ")(1)
                If InStr(temp(j), "Sunset: ") > 0 Then sunset = Split(temp(j), " ")(1)
            Next j
    
            With sld.Shapes("w_day" & i).TextFrame.TextRange
                .Text = wday & temp_min & " / " & temp_max
                .Font.Color.RGB = rgbOrange
                .Characters(7, Len(temp_min) + 2).Font.Color.RGB = rgbWhite
            End With
            If i = 1 Then
                With sld.Shapes("w_sun").TextFrame.TextRange
                    .Text = ""
                    If Len(sunrise) Then .Text = "일출: " & sunrise
                    If Len(sunset) Then .Text = .Text & vbNewLine & "일몰: " & sunset
                    .Font.Color.RGB = rgbWhite
                End With
            End If
            
        Next xChild
    Next p
    
    Set xDoc = Nothing
End Sub
 
Sub getNews()
    
    Dim URL As String
    Dim xDoc As MSXML2.DOMDocument
    Dim xEntry As MSXML2.IXMLDOMNodeList
    Dim xChild As MSXML2.IXMLDOMNode
    Dim sld As Slide, shp As Shape
    Dim i As Long, j As Long, p As Long
    Dim temp1 As String, temp2 As String, temp3 As String
    
    URL = "http://fs.jtbc.joins.com//RSS/newsflash.xml"   'newsrank.xml"   ' jtbc
    Set xDoc = New MSXML2.DOMDocument
    If xDoc Is Nothing Then Exit Sub
    
    xDoc.async = False
    'xDoc.validateOnParse = False
    xDoc.Load URL
    
    For p = 0 To 3
        Set sld = ActivePresentation.Slides(MAIN + p)
        '날짜, 시간
        Set xChild = xDoc.SelectSingleNode("//rss/channel/pubDate")
        Set shp = sld.Shapes("n_date")
        shp.TextFrame.TextRange = xChild.Text
    Next p
    
    Set xEntry = xDoc.SelectNodes("//rss/channel/item")
    i = 0: p = 0
    For Each xChild In xEntry
        '<item>
        '<title>[이 시각 뉴스룸] 트럼프, 2차 회담 성공 낙관…"서두를 것 없다"</title>
        '<link>
        'http://news.jtbc.joins.com/article/article.aspx?news_id=NB11770656
        '</link>
        '<description>
        '1. 트럼프, 2차 회담 성공 낙관&hellip;"서두를 것 없다"[앵커]트럼프 미국 대통령이 2차 북미정상회담은 "매우 성공적일 것"이며, "서두를 게 없다"고 낙관했습니다. 북미 양측의 회담 준비팀은 곧 하노이에서 실
        '</description>
        '<pubDate>2019.02.16</pubDate>
        '</item>
        Set sld = ActivePresentation.Slides(MAIN + p)
        
        i = i + 1
        Set shp = sld.Shapes("n_news_" & i)
        
        '제목
        temp1 = xChild.SelectSingleNode("title").Text
        '링크
        temp2 = xChild.SelectSingleNode("link").Text
        '설명
        temp3 = xChild.SelectSingleNode("description").Text
        
        With shp.TextFrame.TextRange
            .Text = temp1
            .Font.Color.RGB = rgbWhite
            If InStr(temp1, "[") > 0 Then _
                .Characters(1, InStrRev(temp1, "] ")).Font.Color.RGB = rgbOrange
        End With
        
        With shp.ActionSettings(ppMouseClick)
            .Action = ppActionHyperlink
            .Hyperlink.Address = temp2
            .Hyperlink.ScreenTip = temp3
        End With
            
        If i Mod 5 = 0 Then
            i = 0
            p = p + 1
            'If p > 3 Then Exit For
        End If
    Next xChild
 
    
    Set xDoc = Nothing
End Sub
 
 
'///// Module 2 ******************************************************
 
Const MAIN As Long = 2
Sub OnSlideShowPageChange(SSW As SlideShowWindow)
 
    If SSW.View.Slide.SlideIndex = 1 Then
              
        Call getWeather
        
        Call getNews
        
        SSW.View.PointerType = ppSlideShowPointerAlwaysHidden
        
        'SSW.View.GotoSlide MAIN, msoTrue
        
    ElseIf SSW.View.Slide.SlideIndex = MAIN + 4 Then
    
        SSW.View.GotoSlide 1, msoTrue       '처음으로 돌아가기
        
    End If
    
End Sub
 
 

파일 첨부합니다.

weathernewsJTBC_RSS1.pptm