십자낱말퀴즈 생성 도우미

낱말퀴즈 혹은 CrossWord Puzzle 만들 때 편리한 도우미입니다.

 

 

낱말퀴즈 정답을 표로 만들고 나서  
이 표를 복제해서 문제번호가 있는 표를 위에 만들어서 정답 표를 가리고 나서 
위에 있는 문제 표를 선택한 상태에서 매크로(Auto~)를 실행하면  
각 낱말 셀을 누르면 밑에 있던 정답 낱말이 보이는 낱말퀴즈를 생성해줍니다

 

 

Auto낱말퀴즈만들기 매크로를 실행하면 아래와 같은 메시지가 뜹니다.

 

 

실행 화면입니다.

 

다른 애니메이션 효과를 위한 매크로 함수 이용방법 영상입니다.

 

 

 

내부적으로는

테이블의 각 셀을 일반 도형으로 변환시키고 (Cell2Shape)

각 도형에 트리거를 일괄 적용하는(Trigger_add, Trigger_add1)

그리고 적용된 트리거를 일괄 변경(Trigger_Change)하는 하위 매크로기능이 사용되었습니다.

 

 

 

 Sub Auto낱말퀴즈만들기()
 
    Dim msg As String
    
    msg = "낱말퀴즈 정답 표를 만들고 나서 " & vbNewLine & _
            "이 표를 복제해서 문제번호가 있는 표를 위에 만드시고" & vbNewLine & _
            "위에 있는 문제 표를 선택한 상태에서 매크로를 실행하면" & vbNewLine & _
            "각 낱말 셀을 누르면 밑에 있던 정답낱말이 보이는 낱말퀴즈를 생성해줍니다." & vbNewLine & _
            vbNewLine & "계속할까요? "
    If MsgBox(msg, vbOKCancel + vbInformation) = vbCancel Then Exit Sub
    
    Call Cell2Shape
    
    Call Trigger_Add
    
 End Sub
 
 '표의 각 셀을 도형으로 변환/복제
 Sub Cell2Shape()
    
    Dim sld As Slide, shp As Shape, cshp As Shape, nshp As Shape
    Dim tbl As Table
    Dim r As Integer, c As Integer, tcnt&
    'Dim SelCell() As Boolean
    
    On Error GoTo Oops
    Set shp = ActiveWindow.Selection.ShapeRange(1)
    Set sld = shp.Parent
    Set tbl = shp.Table
    
    '선택된 셀들 기억
'    ReDim SelCell(1 To tbl.Rows.Count, 1 To tbl.Columns.Count)
'    For r = 1 To tbl.Rows.Count
'        For c = 1 To tbl.Columns.Count
'            If tbl.Cell(r, c).Selected Then
'                SelCell(r, c) = True
'            End If
'        Next c
'    Next r
    
    '기존 표도형을 백업
    tcnt = sld.Shapes.Count
    shp.Duplicate (1)
    While sld.Shapes.Count <= tcnt: DoEvents: Wend  
    With sld.Shapes(sld.Shapes.Count)
        .Name = shp.Name & "_Backup"
        .Visible = msoFalse
        .Left = shp.Left
        .Top = shp.Top
    End With
     
    '각 셀내용을 순환하면서 도형으로 복제
    For r = 1 To tbl.Rows.Count
        For c = 1 To tbl.Columns.Count
            If tbl.Cell(r, c).Shape.Fill.Visible = msoTrue Then
            'If tbl.Cell(r, c).Shape.TextFrame2.HasText Then
            'If SelCell(r, c) Then
                Set cshp = tbl.Cell(r, c).Shape
                'cshp.TextFrame2.TextRange.Copy
                'tcnt = sld.Shapes.Count
                'Set nshp = sld.Shapes.Paste(1)
                Set nshp = sld.Shapes.AddShape(msoShapeRectangle, cshp.Left, cshp.Top, cshp.Width, cshp.Height)
                
                nshp.Name = "Cell_" & r & "_" & c
                'nshp.Left = cshp.Left
                'nshp.Top = cshp.Top
                'nshp.Width = cshp.Width
                'nshp.Height = cshp.Height
                nshp.Fill.ForeColor.RGB = cshp.Fill.ForeColor.RGB
                nshp.Line.Visible = tbl.Cell(r, c).Borders.Item(1).Visible
                nshp.Line.ForeColor.RGB = tbl.Cell(r, c).Borders.Item(1).ForeColor.RGB
                nshp.Line.Weight = tbl.Cell(r, c).Borders.Item(1).Weight
                nshp.TextFrame2.AutoSize = msoAutoSizeNone
                nshp.TextFrame2.VerticalAnchor = cshp.TextFrame2.VerticalAnchor '세로정렬
                With nshp.TextFrame.TextRange
                    .Text = cshp.TextFrame.TextRange.Text
                    .Font.Size = cshp.TextFrame.TextRange.Font.Size
                    .Font.Color.RGB = cshp.TextFrame.TextRange.Font.Color.RGB
                    .Font.Name = cshp.TextFrame.TextRange.Font.Name
                    .Font.Bold = cshp.TextFrame.TextRange.Font.Bold '진하게 여부
                End With

                '기존 셀내용 삭제
                'cshp.TextFrame2.DeleteText
                nshp.Select msoFalse
            End If
        Next c
    Next r
    shp.Visible = msoFalse
    
Oops:
    If Err Then MsgBox Err.Description
    
End Sub

Sub Trigger_Add1()
    Dim i As Integer, no As Integer
    Dim shp As Shape
    Dim sld As Slide
    Dim eft As Effect
    Dim MAIN As Integer
    
    MAIN = ActiveWindow.Selection.SlideRange(1).SlideIndex '버튼이 있는 메인 슬라이드
    Set sld = ActivePresentation.Slides(MAIN)
    For Each shp In sld.Shapes
        '01, 02.. 버튼을 누를 때 사라지기 효과가 시작. But, 하이퍼링크를 먼저 실행하고 돌아올 때까지 유예
        If shp.Name Like "Cell_*" Then
            'Set eft = sld.TimeLine.InteractiveSequences.Add(). _
                AddTriggerEffect(shp, msoAnimEffectFade, msoAnimTriggerOnShapeClick, shp)
            'eft.Exit = True
            Set eft = sld.TimeLine.InteractiveSequences.Add(). _
                AddTriggerEffect(shp, msoAnimEffectGrowAndTurn, msoAnimTriggerOnShapeClick, shp)
            'eft.Timing.Duration = 1
            eft.Exit = True
            eft.Timing.TriggerType = msoAnimTriggerWithPrevious
            Set eft = sld.TimeLine.InteractiveSequences.Add(). _
                AddTriggerEffect(shp, msoAnimEffectFade, msoAnimTriggerOnShapeClick, shp)
            eft.Exit = True
            eft.Timing.Duration = 0.5
            'eft.Timing.Decelerate = 0.5
            eft.Timing.TriggerDelayTime = 0.5
            eft.Timing.TriggerType = msoAnimTriggerWithPrevious

            
        End If
    Next shp

End Sub

Sub Trigger_Add()
    Dim i As Integer, no As Integer
    Dim shp As Shape
    Dim sld As Slide
    Dim eft As Effect
    Dim MAIN As Integer
    
    MAIN = ActiveWindow.Selection.SlideRange(1).SlideIndex '버튼이 있는 메인 슬라이드
    Set sld = ActivePresentation.Slides(MAIN)
    For Each shp In sld.Shapes
        '01, 02.. 버튼을 누를 때 사라지기 효과가 시작. But, 하이퍼링크를 먼저 실행하고 돌아올 때까지 유예
        If shp.Name Like "Cell_*" Then
            Set eft = sld.TimeLine.InteractiveSequences.Add(). _
                AddTriggerEffect(shp, msoAnimEffectFade, msoAnimTriggerOnShapeClick, shp)
            'eft.EffectInformation.TextUnitEffect
            eft.Timing.Duration = 0.5
            eft.Exit = True
            
        End If
    Next shp

End Sub

Sub Trigger_Change()
    Dim i As Integer, no As Integer
    Dim shp As Shape
    Dim sld As Slide
    Dim seq As Sequence
    Dim eft As Effect
    Dim MAIN As Integer
    
    MAIN = ActiveWindow.Selection.SlideRange(1).SlideIndex '버튼이 있는 메인 슬라이드
    Set sld = ActivePresentation.Slides(MAIN)
    For Each seq In sld.TimeLine.InteractiveSequences
        '01, 02.. 버튼의 애니메이션 효과를 수정
        For Each eft In seq
            'Set eft = sld.TimeLine.InteractiveSequences(1).Item(1)
            If eft.Shape.Name Like "Cell_*" Then
                'eft.EffectType = msoAnimEffectFadedSwivel   '회전하면서 사라지기
                eft.EffectType = msoAnimEffectSpinner       '돌면서 축소
                'eft.EffectType = msoAnimEffectFade          '흐려지기
                'eft.EffectType = msoAnimEffectDissolve      '디졸브
                'eft.EffectType = msoAnimEffectFadedZoom    '축소
                eft.Timing.Duration = 0.5
                eft.Exit = True
            End If
        Next eft
    Next seq

End Sub

 

첨부파일은 매크로 허용해서 여세요.

 

낱말퀴즈1.pptm

0.10MB

 

 

아래 기능이 추가된 버전입니다.

- 문제 도형을 누르면 소리와 함께 아래의 정답 도형이 보입니다.

- 정답 도형을 누르면 다시 사라졌던 문제 번호(도형)가 보입니다.

- 표에 적힌 답 도형의 색상을 랜덤으로 일괄 변경합니다.

- 표에 적힌 답 글자를 일괄로 삭제합니다.

 

낱말퀴즈2.pptm

0.16MB

user.wav

0.00MB