Bing Wallpaper 슬라이드 쇼 생성

 

https://bing.gifposter.com/list/new/desc/classic.html

New Bing Images - Bing Wallpaper Gallery

 

위 사이트의 배경화면으로 슬라이드쇼를 생성하는 예시입니다.

 

1. HTML 파싱으로 배경화면 이미지를 다운로드 받고

 

2. 각 슬라이드에 마우스를 좌우나 상하 끝으로 가져갈 때 이동 아이콘이 나타나도록 합니다.

 

 

 

파워포인트에서는 좌우에 아이콘이 나타나게 하려면 번거롭지만 아이콘 반응을 직접 만들어줘야 합니다.

​

아래 주황색 네모 영역에 마우스 오버시에 네비게이션 아이콘이 나타나게 하고

마우스가 해당 영역을 벗어날 때는 아이콘이 사라지게 하는 방식입니다.

 

​

 슬라이드 쇼에서 마우스를 좌우 모서리로 가져가면 이전이나 다음으로 이동 화살표 아이콘이 뜹니다.

마우스를 아래로 가져가면 Home 아이콘이 나타나고 누르면 처음으로 돌아갑니다.

마우스를 위로 가져가면 S 아이콘이 나타나고 누르면 해당 이미지의 원본 출처 하이퍼링크로 이동합니다.

 

 

아이콘 반응 관련 코드:

Option Explicit

Private Sub test()
    copyIcons ActivePresentation.Slides(2)
End Sub

'슬라이드 페이지가 바뀔 때
Sub onSlideShowPageChange(SSW As SlideShowWindow)
    Dim sld As Slide
    Set sld = SSW.View.Slide
    copyIcons sld
    hideIcons sld
End Sub

'슬라이드쇼 종료시
Sub onSlideShowTerminate(SSW As SlideShowWindow)
    Dim sld As Slide
    For Each sld In ActivePresentation.Slides
        hideIcons sld
    Next sld
End Sub

' 투명 박스에 마우스가 갈 때
Sub MouseOver(oShp As Shape)
    
    Dim sld As Slide, shp As Shape
    Dim temp() As String
    Dim Btn As String
    
    Set sld = oShp.Parent
    temp = Split(oShp.Name, "_")
    If UBound(temp) = 1 Then Btn = temp(1) Else Btn = ""
    
    For Each shp In sld.Shapes
        If shp.Name Like "Icon_*" Then
            If shp.Name = "Icon_" & Btn Then
                shp.Visible = msoTrue
            Else
                shp.Visible = msoFalse
            End If
        End If
    Next shp
 
End Sub

'아이콘과 투명 배경 복사
Function copyIcons(oSld As Slide)
    Dim shp As Shape
    For Each shp In ActivePresentation.Slides(1).Shapes
        If shp.Name Like "Box_*" Or shp.Name Like "Icon_*" Then
            If Not shpExist(oSld, shp.Name) Then
                shp.Copy
                DoEvents
                oSld.Shapes.Paste
                DoEvents
            End If
        End If
    Next shp
    addLink oSld
End Function

'이동 아이콘 감추기
Function hideIcons(oSld As Slide)
    Dim shp As Shape
    For Each shp In oSld.Shapes
        If shp.Name Like "Icon_*" Then shp.Visible = msoFalse
    Next shp
End Function

'슬라이드에 도형 존재 여부
Function shpExist(oSld As Slide, sName As String) As Boolean
    Dim shp As Shape
    For Each shp In oSld.Shapes
        If shp.Name Like sName Then
            shpExist = True: Exit For
        End If
    Next shp
End Function

'BingImg_의 하이퍼링크를 링크 아이콘의 하이퍼링크에 연결
Function addLink(oSld As Slide)
    Dim shp As Shape
    If shpExist(oSld, "Icon_Link") Then
        For Each shp In oSld.Shapes
            If shp.Name Like "BingImg_*" Then
                oSld.Shapes("Icon_Link").ActionSettings(ppMouseClick).Hyperlink.Address = _
                    shp.ActionSettings(ppMouseClick).Hyperlink.Address
            End If
        Next shp
    End If
End Function
'모든 아이콘과 투명 박스 삭제(1슬라이드 제외)
Private Sub RemoveIconsBoxes_Except1stSlide()
    Dim sld As Slide, i As Integer
    For Each sld In ActivePresentation.Slides
        If sld.SlideIndex > 1 Then
            For i = sld.Shapes.Count To 1 Step -1
                If sld.Shapes(i).Name Like "Icon_*" Or sld.Shapes(i).Name Like "Box_*" Then
                    sld.Shapes(i).Delete
                End If
            Next i
        End If
    Next sld
End Sub

'모든 슬라이드에 미리 아이콘과 투명 배경 복사
Sub CopyIconsBoxes(Optional nul As Boolean)
    Dim sld As Slide
    For Each sld In ActivePresentation.Slides
        If sld.SlideIndex > 1 Then
            copyIcons sld
        End If
    Next sld
End Sub

 

 

Bing 배경화면  HTML 파싱 및 이미지 삽입 슬라이드 관련 코드:

Option Explicit

Dim Http As Object
Dim Html As Object                  'MSHTML.HTMLDocument     'Object
Const MaxCount As Integer = 10      'MAX = 30

Sub DownloadBingWallpapers()
    Dim prs As Presentation
    Dim sld As Slide, shp As Shape
    Dim Url As String, sImg As String, sLink As String, sNo As String
    Dim ele As Object   'mshtml.IHTMLElement
    Dim SW!, SH!, Cnt As Integer
    
    If MsgBox("Bing WallPaper 사이트에서 " & MaxCount & "개의 배경화면을 다운로드받아 슬라이드를 추가할까요?", _
        vbOKCancel) <> vbOK Then Exit Sub
    
    If Html Is Nothing Then Set Html = CreateObject("Htmlfile")    'New mshtml.HTMLDocument
    Url = "https://bing.gifposter.com/list/new/desc/classic.html"
    Html.body.innerHTML = getResponse(Url)
    'Debug.Print Left(Html.body.innerHTML, 4000)
     
    Html.body.innerHTML = Html.getElementsByTagName("UL")(0).innerHTML
    'Debug.Print Left(Html.body.innerHTML, 4000)
    
    Set prs = ActivePresentation
    With prs.PageSetup
        SW = .SlideWidth: SH = .SlideHeight
    End With
    
    '<ul 태그 안의 모든 <li 태그 순환
    For Each ele In Html.getElementsByTagName("li")
        Cnt = Cnt + 1
        '이미지 주소
        sImg = Replace(ele.getElementsByTagName("img")(0).src, "_sm", "")
        '링크
        sLink = ele.getElementsByTagName("a")(0).href
        '고유번호
        sNo = Split(sLink, "-")(1)
        sLink = Replace(sLink, "about:/", "")
        sLink = "https://bing.gifposter.com/" & sLink
        'Debug.Print sImg, sLink
        'https://h2.gifposter.com/bingImages/MolokiniHawaii_1920x1080.jpg_sm
        '슬라이드 추가
        Set sld = prs.Slides.Add(prs.Slides.Count + 1, ppLayoutBlank)
        '온라인 이미지 삽입
        Set shp = sld.Shapes.AddPicture(sImg, msoFalse, msoTrue, 0, 0, SW, SH)
        shp.Name = "BingImg_" & sNo
        '이미지 대체 텍스트
        shp.AlternativeText = sImg
        '이미지에 하이퍼링크
        shp.ActionSettings(ppMouseClick).Hyperlink.Address = sLink
        
        sld.SlideShowTransition.EntryEffect = ppEffectFadeSmoothly
        sld.SlideShowTransition.Duration = 1
        If Cnt >= MaxCount Then Exit For
    Next ele
    
    If MsgBox("각 슬라이드에 아이콘을 미리복사할까요?", vbOKCancel) = vbOK Then
        Module1.CopyIconsBoxes
    End If
End Sub

Function getResponse(sUrl As String) As String
  
    If Http Is Nothing Then Set Http = CreateObject("MSXML2.ServerXMLHttp")
    With Http
        .Open "get", sUrl, False
        .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64)"
        .Send
        getResponse = .responseText
    End With
    
End Function

'화면전환 효과 일괄 적용
Private Sub ApplyTransition()
    Dim sld As Slide
    
    For Each sld In ActivePresentation.Slides
        sld.SlideShowTransition.EntryEffect = ppEffectFadeSmoothly  '3849
        sld.SlideShowTransition.Duration = 2
    Next sld
End Sub

 

10개 배경화면이 들어간 샘플입니다.

소스의 MaxCount 를 30으로 바꾸면 30개까지 다운로드 가능합니다.

 

 

SldieShowNavigation1.pptm

4.02MB

 

2024.08.10수정: 슬라이드 이동 후 마우스 커서를 화면 가운데로 보내줌

SldieShowNavigation2.pptm

6.54MB

 

첨부 파일 차단해제하고 파일을 열 때 매크로 허용해서 pptm파일을 열고

Alt+F8누르고 DownlodBingWallpaper 를 실행하면

Bing배경화면 사이트에서 10개의 이미지를 다운로드 받아 슬라이드를 생성하고

아이콘 반응을 자동으로 생성해줍니다.

 

 

폰트는 프리젠테이션 Light 가 사용되었습니다.

 

이미지의 출처는 https://bing.gifposter.com/ 이고 저작권은 각 사진에 링크된 저작권자에게 있습니다. 

 

관련: 지식인