문장에 빈칸 도형 일괄 추가 매크로

 

위처럼 빈칸채우기 문제에서 문장의 특정부분을 빈칸으로 가려놓고 누르면 정답을 보여주게

빈칸 도형을 일괄로 자동 추가해주는 매크로입니다.

 

노란색 둥근 네모도형에 사라지는 애니메이션효과를 주고 트리거를 자기자신으로 지정하면 됩니다.

하나를 만들고 계속 복사하면 효과가 그대로 유지됩니다.

그런데 이런 버튼 만드는 과정을 좀더 편하게 미리 문장에 [ 빈칸 ] 만 추가해 놓으면 그 위치에 자동으로 빈칸도형을 일괄 생성해주는 것입니다.

 

일단 텍스트박스에서 빈칸이 들어갈 부분에 [ 빈칸 ]을 좌우에 추가하고 텍스트박스를 선택하거나

슬라이드 1개 또는 여러개의 슬라이드를 선택하고 Alt-F8 매크로를 실행합니다. 

 

AddBlank  매크로는 빈칸도형을 추가하고 뒤에 숨은 답은 진한 노란색으로 바꿔주고

DelBlanks 는 현재 선택된 텍스트박스나 슬라이드들에서 모든 빈칸 도형을 삭제해줍니다.

눌렀을 때 셔터효과음도 추가됩니다. 

빈칸 도형 추가 결과입니다.

한 슬라이드만 선택되거나 한개의 텍스트박스만 선택되어 있으면 해당 개체내의 문장에 빈칸 도형을 추가합니다.

 

아래는 실행화면입니다.

 

매크로 소스입니다.

'//텍스트박스에 모든 [괄호]안에 빈칸도형을 생성하고 클릭시 사라지는 효과를 자동 추가
Option Explicit

Sub AddBlank()
    Dim sld As Slide
    Dim shp As Shape
    
    On Error Resume Next
    If ActiveWindow.Selection.SlideRange Is Nothing Then _
        MsgBox "먼저 슬라이드를 선택하세요.": Exit Sub
    

    If ActiveWindow.Selection.ShapeRange Is Nothing Then
        For Each sld In ActiveWindow.Selection.SlideRange
            For Each shp In sld.Shapes
                AddBlankAnim shp
            Next shp
        Next sld
    Else
        For Each shp In ActiveWindow.Selection.ShapeRange
            AddBlankAnim shp
        Next shp
  
    End If
    On Error GoTo 0



End Sub

Function AddBlankAnim(oShp As Shape)

    Dim oSld As Slide
    Dim str As String
    Dim i As Integer, k As Integer, b1 As Long, b2 As Long
    Dim x$, y$, w$, h$, lineSpace$
    Dim blank As Shape, spkr As Shape
    Dim eft As Effect
    Dim margin As Single    '// 빈칸 도형의 여백

    Set oSld = oShp.Parent

    If oShp.HasTextFrame Then
            
        With oShp.TextFrame.TextRange
            str = .Characters.Text
            
            For i = 1 To Len(str)
                '// 문자 "["가 있는 경우 "]"까지의 문자 위치를 알아냄
                If .Characters(i) = "[" Then
                    b1 = i + 1
                    'Debug.Print .Characters(b1, Len(str) - b1).Text
                    b2 = InStr(.Characters(b1, Len(str) - b1).Text, "]")
                    If b2 > 0 Then
                        '// 문자열 시작위치부터 마지막 위치까지 계산
                        b2 = b2 - 1
                        '//  Debug.Print b1, b2, .Characters(b1, b2).Text
                        '// 빈칸속 정답 색깔 변경
                        .Characters(b1, b2).Font.Bold = msoTrue
                        .Characters(b1, b2).Font.Color.RGB = rgbOrange
                        
                        b2 = b1 + b2 - 1
                        x = .Characters(b1).BoundLeft
                        margin = (.Characters(b1).ParagraphFormat.SpaceWithin - 1) * 15
                        lineSpace = (.Characters(b1).ParagraphFormat.SpaceWithin - 1) * .Characters(b1).Font.Size
                        y = .Characters(b1).BoundTop + margin + lineSpace / 2
                        w = .Characters(b2).BoundLeft + .Characters(b2).BoundWidth - x
                        h = .Characters(b2).BoundHeight - (margin * 2.5)
                            '- IIf(.Characters(b2).BoundTop >= .Lines(.Lines.Count).BoundTop, 0, lineSpace / 2)
                        '//ActiveWindow.Selection.ShapeRange(1).TextFrame.TextRange.Characters(11).Font.Size
                        
                        '//도형 추가
                        Set blank = oSld.Shapes.AddShape(msoShapeRoundedRectangle, x, y, w, h)
                        k = k + 1
                        With blank
                            .Name = "Blank_" & oShp.Name & "_" & k
                            .Fill.ForeColor.RGB = rgbOrange
                            .Line.Visible = msoFalse
                            .Adjustments(1) = 0.1
                        End With
                        
                        '//Trigger 애니메이션 추가
                        Set eft = oSld.TimeLine.InteractiveSequences.Add().AddTriggerEffect( _
                            blank, msoAnimEffectGrowAndTurn, msoAnimTriggerOnShapeClick, blank)
                        eft.Exit = msoTrue  'disappear
                        eft.Timing.Duration = 0.25
                        
                        '//사운드 복사 후 효과 추가
                        'eft.EffectInformation.SoundEffect.ImportFromFile _
                            ActivePresentation.Path & Chr(92) & "shutter.wav"
                        If Not ShpExist(oSld, "Shutter") Then
                            ActivePresentation.Designs(1).SlideMaster.CustomLayouts(3).Shapes("Shutter").Copy
                            oSld.Shapes.Paste
                            'Set spkr = oSld.Shapes.AddMediaObject2( _
                                ActivePresentation.Path & Chr(92) & "shutter.wav", msoFalse, msoTrue)
                        End If
                        Set spkr = oSld.Shapes("Shutter")
                        Set eft = oSld.TimeLine.InteractiveSequences.Add().AddTriggerEffect( _
                            spkr, msoAnimEffectMediaPlay, msoAnimTriggerOnShapeClick, blank)
                        eft.Timing.TriggerType = msoAnimTriggerWithPrevious
                            
                    End If
                End If
            Next i
        End With
        
    End If  '//if hasTextFrame

    
End Function

Function setTrigger(oShp As Shape, tShp As Shape)
    Dim sld As Slide
    Dim eft As Effect
    Dim iSeq As Sequence
    Dim i As Integer
    
    Set sld = oShp.Parent
    For Each iSeq In sld.TimeLine.InteractiveSequences
        For i = 1 To iSeq.Count
            With iSeq.Item(i)
                If .Shape = oShp Then
                    Debug.Print ">>", .Index, .Shape.Name, .Timing.TriggerShape
                    .Timing.TriggerShape = tShp
                End If
            End With
        Next i
    Next iSeq

End Function

Function ShpExist(oSld As Slide, shpName As String) As Boolean
    Dim shp As Shape
    ShpExist = False
    For Each shp In oSld.Shapes
        If shp.Name = shpName Then ShpExist = True: Exit Function
    Next shp
End Function

Sub delBlanks()

    Dim sld As Slide
    Dim i As Long, k As Long
    
    On Error Resume Next
    If ActiveWindow.Selection.SlideRange Is Nothing Then _
        MsgBox "먼저 슬라이드를 선택하세요.": Exit Sub
    On Error GoTo 0
    
    For Each sld In ActiveWindow.Selection.SlideRange
        
        For i = sld.Shapes.Count To 1 Step -1
            
            If sld.Shapes(i).Name Like "Blank_*" Or sld.Shapes(i).Name Like "Shutter*" Then _
                k = k + 1: sld.Shapes(i).Delete
        
        Next i
    
    Next sld
    
    If k Then MsgBox k & "개의 빈칸 도형 삭제 완료", vbInformation + vbOKOnly
    
End Sub

 

AddBlank1.pptm

0.09MB

shutter.wav

0.01MB

(셔터효과음은 pptm내에 포함되어 있지만 삭제된 경우를 위해 첨부합니다.)

 

테이블(표)의 셀 내부에 빈칸이 있는 경우

AddBlank2.pptm

0.09MB

(빈 칸이 두줄이상으로 이어지는 경우는 반영하지 못했습니다.)