Hidden Picture

Hidden Picture

Description: This is an automatic hidden picture game generator

made with PowerPoint 2010 and VBA.

You only have to add pictures in a new slide.

That's all.

You don't have to copy any box shapes on it.

VBA will do it for you.

Just add pictures or questions.

Needs Macro enabled.  Be sure to finish the slideshow by clicking 'X' button on the right bottom .

여러개의 박스뒤에  가려진 그림(답)을 찾아내는 게임입니다.

또한 사용자가 새로운 슬라이드에 그림이나 문제를 추가하면 무한대로 추가할 수 있습니다.

 

 

 

answer 버튼: 박스를 제거하고 전체 그림 정답을 보여줍니다. Jump버튼: 슬라이드를 건너뛸 때 사용합니다. Hint 버튼: 박스를 흐리게 해서 힌트를 줍니다. 2,3,4,5,6,7 버튼 : 단계를 나타내며 2=> 2*2=4, 7 => 7*7 =49개의 박스가 생깁니다. 7단계로 갈수록 박스가 많아집니다. Next버튼: 다음 슬라이드 X버튼: 종료버튼

 

 

보이지 않는 박스개체가 많이 생기므로 슬라이드쇼를 끝낼 때는 반드시 X를 눌러서 종료해주세요.

그렇지 않으면 혹시 그 상태에서 저장하게 되면 보이지 않는 개체가 많이 생겨 

파워포인트 에러(읽기전용입니다. 저장하시겠습니까? 하지만 저장이 되지 않는 메모리 오버플로우 에러)

 

 

장점이 사진이나 문제를 마음대로 추가할 수 있습니다.

첨부한 파일은  온라인 무료 이미지를 추가해서 만든 샘플입니다.

 

플레이 하는 방법과 사진을 추가하는 방법을 영상으로 추가합니다.

 

 

 

** 저작권 주의 표시 ** 포함된 사진은 인터넷( https://pixabay.com ) 에서 가져온 자료로 절대 재배포할 수 없으며

개인적인 용도나 교육적인 용도로만 사용되어야 합니다. **

주의) 파워포인트 2010이상에서 파일을 여시고 매크로 사용을 허용하셔야 합니다.

제작환경

Microsoft(R) PowerPoint 2010

 

Hidden_Picture_Sample_R.zip

다운로드

(ppsm파일을 편집하려면 쉬프트 누른 채로 파일을 우클릭하고 '편집'을 선택하면 일반 pptm처럼 편집할 수 있습니다.)

참고) VBA 모듈에 필요 없는 코드도 더러 들어 있습니다.

 

샘플1: 아래와 같은 영어어휘 리버스(rebus)퀴즈(연상되는 단어찾기) 샘플도 하나 올립니다.

         슬라이드내에 애니메이션을 삽입한 예제입니다.

012

</p><p></p><p>

 

 

 

허접한 코드이지만 저작권은 저에게 있습니다. 

Copyright ⓒ konahn 2016

' Hidden Picture Revealing Game

' by konahn@daum.net

' 2016.09.

'

Public Const MAXBOX = 49    'maximum count of boxes 7*7

Public box(1 To MAXBOX) As Shape

Public boxCount As Integer  'count of boxes, 2 to 7

Public Declare Function sndPlaySound32 _

    Lib "winmm.dll" _

    Alias "sndPlaySoundA" ( _

        ByVal lpszSoundName As String, _

        ByVal uFlags As Long) As Long

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

 

Sub ChangeLevel(Shp As Shape)

    boxCount = Shp.TextFrame.TextRange.Text

    If boxCount < 2 Or boxCount > 7 Then boxCount = 3

End Sub

 

Sub draw_box()

    Dim MAXX As Integer

    Dim MAXY As Integer

    Dim MAX As Integer

    

    Dim myWidth As Long

    Dim myHeight As Long

    Dim myShape As Shape

    Dim i, x, y As Integer

    Dim curSlide As Integer

            

    If boxCount = 0 Then

        boxCount = 3

    End If

    

    MAXX = boxCount

    MAXY = boxCount

    MAX = MAXX * MAXY

    

    With ActivePresentation

        myWidth = .PageSetup.SlideWidth

        myHeight = .PageSetup.SlideHeight - 50  ' except bottom margin

    End With

    

    boxWidth = myWidth / MAXX

    boxHeight = myHeight / MAXY

    'MsgBox boxWidth & "," & BoxHeight

    

    curSlide = ActivePresentation.SlideShowWindow.View.CurrentShowPosition + 1

    For i = 1 To MAX

    

        With ActivePresentation.Slides(curSlide).Shapes

            x = Int((i - 1) Mod MAXX) * boxWidth

            y = Int((i - 1) \ MAXY) * boxHeight

            

            Set box(i) = .AddShape(msoShapeRectangle, x, y, boxWidth, boxHeight)

            

        End With

 

        With box(i)

 

            .Name = "myBox" & i

            .Line.ForeColor.RGB = RGB(50, 20, 20)

            .Line.Visible = msoTrue

            .Fill.ForeColor.RGB = RGB(200 * Rnd, 120 * Rnd, 120 * Rnd)

            .TextFrame.TextRange.Font.Color.RGB = RGB(255, 255, 255)

            .TextFrame.TextRange.Characters.Text = i ' & ":" & x & "," & y

            .TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignCenter

            .TextFrame2.VerticalAnchor = msoAnchorMiddle

            .TextFrame2.TextRange.Font.Size = 50

            .TextFrame2.TextRange.Font.Name = "Arial"

            .TextFrame2.TextRange.Font.Bold = msoTrue

            .TextFrame2.TextRange.Font.Shadow.Visible = msoTrue

            .ActionSettings(ppMouseClick).Action = ppActionRunMacro

            .ActionSettings(ppMouseClick).Run = "on_Click"

            

        End With

 

    Next

    

End Sub

 

 

Sub draw_button()

    Dim curS As Integer

    Dim myS As Shape

    Dim newS As ShapeRange

    

    curS = ActivePresentation.SlideShowWindow.View.CurrentShowPosition

    

    'copy buttons from slides(1) & paste on to the next slide

    With ActivePresentation.Slides(curS + 1)

    For Each myS In ActivePresentation.Slides(1).Shapes

        If Left(myS.Name, 9) = "mybutton_" Then

            myS.Copy            ' copy buttons from slides(1)

            'MsgBox myS.Top & "->" & .Shapes(myS.Name).Top

            With .Shapes.Paste       ' paste buttons on the next slide

                .Left = myS.Left

                .Top = myS.Top

            End With

            DoEvents

         End If

    Next myS

    End With

    

    'if not slides(1), erase current buttons

    If curS <> 1 Then

        For Each myS In ActivePresentation.Slides(curS).Shapes

            If Left(myS.Name, 9) = "mybutton_" Then

                'MsgBox (myS.Name)

                myS.Visible = msoFalse       ' erase buttons in current slide

            End If

        Next myS

    End If

    

End Sub

 

 

Sub remove_all(theShape As Shape)

    Dim i As Integer

    Dim myS As Shape

    

    'For Each myS In ActivePresentation.Slides(2).Shapes

    For Each myS In theShape.Parent.Shapes

        If Left(myS.Name, 5) = "myBox" Then

            myS.Visible = msoFalse

            'myS.Delete

        End If

    Next myS

            

End Sub

 

Sub move2next()

    draw_box        'draw boxes MAX times

    draw_button     'copy/paste control buttons on the bottom

    ActivePresentation.SlideShowWindow.View.Next

    

End Sub

 

Sub myExit()

    Dim i, j As Integer

    Dim myS As Shape

    Dim curS As Integer

       

    'erase boxes and buttons in all slides

    For i = 2 To ActivePresentation.Slides.Count

        With ActivePresentation.Slides(i)

            'MsgBox i & "'s shapes: " & .Shapes.Count

        For j = .Shapes.Count To 1 Step -1

            Set myS = .Shapes(j)

            If Left(myS.Name, 5) = "myBox" Or Left(myS.Name, 9) = "mybutton_" Then

                myS.Delete      'myS.Visible ' = msoFalse       ' erase boxes or buttons in slides

            End If

        Next j

        End With

    Next i

    'erase buttons

    'curS = ActivePresentation.SlideShowWindow.View.CurrentShowPosition

    'If curS <> 1 Then

    '    For Each myS In ActivePresentation.Slides(curS).Shapes

    '        If Left(myS.Name, 9) = "mybutton_" Then

    '            myS.Visible = msoFalse       ' erase buttons in current slide

    '        End If

    '    Next myS

    'End If

 

    ActivePresentation.SlideShowWindow.View.Exit

End Sub

 

Sub remove_invisible()

    Dim i As Integer

    Dim j As Integer

    Dim myShape As Shape

    Dim myCount As Integer

    

    For i = 2 To ActivePresentation.Slides.Count

        For j = ActivePresentation.Slides(i).Shapes.Count To 1 Step -1

            Set myShape = ActivePresentation.Slides(i).Shapes(j)

            If myShape.Visible = msoFalse Then

                myShape.Delete ' erase shapes

                myCount = myCount + 1

            End If

        

        Next j

    Next i

    MsgBox myCount & " shapes were deleted."

End Sub

 

Sub on_Click(theShape As Shape)

    Dim curDir As String

 

    curDir = ActivePresentation.Path

    'MsgBox curDir

    theShape.ActionSettings(ppMouseClick).SoundEffect.ImportFromFile (curDir & "\door.wav")

    theShape.ActionSettings(ppMouseClick).SoundEffect.Play

    'MsgBox "click: " & theShape.name

    'ActivePresentation.Slides(2).Shapes(shapeName).Visible = msoFalse

    theShape.Visible = msoFalse

End Sub

 

Sub jump()

    Dim slideNo As String

    Dim maxSlide As Integer

    

    maxSlide = ActivePresentation.Slides.Count

    slideNo = InputBox("Enter the target slide number (2 ~ " & maxSlide & ")", "Jump to Slide")

    If slideNo < 2 Or slideNo > maxSlide Then

        MsgBox "ERROR: Slide number out of range."

        Exit Sub

    End If

    ActivePresentation.SlideShowWindow.View.GotoSlide (slideNo - 1)

    move2next

End Sub

 

Sub hint(theShape As Shape)

    'Dim onoff As Boolean

    Dim myS As Shape

    'change alpha value of each shape

    For Each myS In theShape.Parent.Shapes

        If Left(myS.Name, 5) = "myBox" Then

            myS.Fill.Transparency = 0.05

        End If

    Next myS

    

    MsgBox "Click to finish showing hint..."

    

    For Each myS In theShape.Parent.Shapes

        If Left(myS.Name, 5) = "myBox" Then

            myS.Fill.Transparency = 0

        End If

    Next myS

    

    'Sleep 500  'wait for

    

    'For Each myS In theShape.Parent.Shapes

    '    If Left(myS.name, 5) = "myBox" Then

    '        myS.Visible = msoTrue

    '    End If

    'Next myS

    

End Sub

 

Sub play_sound(myFilename As String)

    'play sound

    myFilename = "door.wav"

    'sndPlaySound32 myFilename

End Sub

 

Sub NameShape(myS As Shape)

'give a name to the clicked shaped. Give them easier names rather than difficult "corner rounded rectangle 2"

 

    Dim Name$

    On Error GoTo AbortNameShape

    Name$ = myS.Name

    Name$ = InputBox$("Give this shape a name", "Shape Name", Name$)

    If Name$ <> "" Then

        myS.Name = Name$

    End If

     

    Exit Sub

     

AbortNameShape:

    MsgBox Err.Description

     

End Sub

 

 

 

 

---

 

2020년 10월 수정본입니다.

슬라이드를 숨김처리하면 사각형을 자동으로 지우고 뒤의 내용을 점진적으로 보여줍니다.

Answer를 누르면 슬라이드 노트의 정답을 보여줍니다.

각 슬라이드에 애니메이션을 추가해도 작동합니다.

글꼴과 디자인을 조금 수정하였습니다.

 

2020년 10월 최신 샘플 파일입니다.

글꼴(Agency FB, Arial round MT, 양진체)은 포함되어 있습니다.

HiddenPicture_Coco_Sample.zip

다운로드

한번에 한칸씩만 보여주는 Hard 레벨과 이전과 같이 계속 누적되는 Easy레벨이 섞인 버전입니다.

HiddenPicture_Coco_HardEasy.zip

2.79MB