ppt 사다리타기 2

지난 포스트에 이어

참가인원과 간단한 상품/벌칙이 입력 가능한 

제대로 작동하는 ppt 사다리 타기 버전 2입니다.

A working version of Ladder game(SADARI)

1)choose how many people will join,

2)set the penalties or prizes

3)and Press 'GO"

4)On the ladder slide, click on the numbers on top.

슬라이드 1,2,3,4는 지우지 마시고 살려두세요.

슬라이드 5에 사다리 슬라이드가 생성됩니다.

PowerPoinT 2010 에서 작성되었습니다.

매크로 사용을 허용해주어야  합니다.

F5 등을 눌러 슬라이드를 시작합니다.

먼저 참가 인원을 선택합니다.

최소 3명에서 최대 8명까지로 했습니다.

그 다음 상이나 벌칙을 입력합니다.

그냥 넘어가도 됩니다.

글자수가 많으면 넘치기 때문에 간단하게 입력하세요.

입력 후 GO 버튼으로 사다리 화면으로 진행합니다.

슬라이드 #5에 사다리 화면이 생성됩니다.

랜덤으로 사다리가 생성이 됩니다.

랜덤 숫자는 소스를 이해한다면 소스에서 세부적인 조정을 할 수 있습니다.

가로로 연속되는 경우는 제외하는 것이 소스에서는 힘든 부분이었습니다.

사다리 번호를 클릭하면 사다리가 나타납니다.

한번더 누르면 사다리가 사라집니다.

다른 번호를 누르면 그줄의 사다리가 나타납니다.

(내부적으로는 선의 속성만 점선에서 굵은 실선으로  바뀌는 것이죠)

사다리가 있는 슬라이드 5페이지만 복사해서 다른 곳에 복사할 수 있습니다. 

(물론 VBA 스크립트도 포함해서 복사가 필요하죠)

' SADARI(Ladder), a game to choose the victim

' Developed and tested under MS Office™ 2010

' by konahn@naver.com 2016

'

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

Public MAXCOL As Integer

Public clickedLine As Integer

'Const MAXCOL = 6

Const MIN = 3           ' min count of people

Const MAX = 8           ' max count of people

Const DEFAULT_SLIDE = 5 ' the default slide to show the ladder on

Const MAXROW = 11       ' max horizontal lines( MAXROW should be more than twice bigger than MAXRND)

Const MAXRND = 4        ' max horizontal lines( each line can have different count of horizontal lines)

Const MARGIN = 100      ' boundary margin

Dim txtFile As String

Dim SDR() As Integer

Sub SetLadderCount(myShape As Shape)

    Dim i, count As Integer

    

    count = Mid(myShape.Name, 3, 1)

    If count < MIN Or count > MAX Then

        MsgBox "Total ladder line should be between " & MIN & " and " & MAX, vbCritical

    Else

        MAXCOL = count

        'set extra buttons invisible

        With ActivePresentation.Slides(2)

            For i = 1 To MAX

                If i <= count Then

                    .Shapes("pay" & i).Visible = msoTrue

                ElseIf i > count Then

                    .Shapes("pay" & i).Visible = msoFalse

                End If

            Next i

        End With

        'go to next slide

        ActivePresentation.SlideShowWindow.View.GotoSlide (2)

    End If

    

End Sub

Sub SetPay(myShape As Shape)

    Dim answer As String

    

    answer = InputBox("Enter the penalty or Prize for #" & myShape.Name)

    If answer <> "" Then

        myShape.TextFrame.TextRange.Characters.Text = answer

    End If

    Return

End Sub

Sub sample_SDR()

'initialize sadari(ladder)

    SDR(1, 1) = 1

    SDR(1, 6) = 1

    SDR(1, 9) = 1

    'SDR(2, 1) = 1 '??

    SDR(2, 3) = 1

    SDR(2, 5) = 1

    SDR(2, 8) = 1

    SDR(3, 4) = 1

    SDR(3, 7) = 1

    SDR(3, 10) = 1

    SDR(4, 2) = 1

    SDR(4, 6) = 1

    SDR(4, 8) = 1

    SDR(5, 3) = 1

    SDR(5, 5) = 1

    SDR(5, 7) = 1

End Sub

Sub go()

    ReDim SDR(0 To MAXCOL, 0 To MAXROW)

    Dim i, j, r As Integer

    Dim w, h As Integer

    Dim lineNo, linePay, myLineV, myLineH As Shape

    Dim length As Integer

    Dim pay As String

    Dim temp(), prevRnd() As Integer 'temporary array for random number

    

    Randomize

        

    'initialize sadari(ladder)

    For i = 1 To MAXCOL - 1

        

        ' initialize temp() array

        ReDim temp(MAXROW - 1)

        For r = 0 To MAXROW - 1     '0 .. 9

            temp(r) = r + 1         '1 .. 10

        Next r

        ' shrink temp() array to exclude previously chosen numbers

        If i > 1 Then

            j = 1

            For r = 1 To MAXROW - 1

                If SDR(i - 1, r) = 0 Then

                    ReDim Preserve temp(j)

                    temp(j) = r

                    j = j + 1

                End If

            Next r

        End If

        

        ReDim prevRnd(MAXRND - 1)

        ' choose 4(MAXRND) integers between 1 & 10(MAXROW)

        For j = 0 To MAXRND - 1 - Int(Rnd * 2)      ' to MAXRND or less

             

            r = Int(Rnd * UBound(temp)) + 1         ' get a random index

            prevRnd(j) = temp(r)                    ' save it to prevRnd()

            SDR(i, temp(r)) = 1                     ' Set SDR array to ON, which means it has a horizontal line on the right

            temp(r) = temp(UBound(temp))            ' switch the chosen array and the last one

            ReDim Preserve temp(UBound(temp) - 1)   ' and remove the last array(the chosen one)

                                                    ' so that we can choose one among not chosen numbers

        Next j

                 

                 

        'MsgBox prevRnd(0) & "," & prevRnd(1) & "," & prevRnd(2) & "," & prevRnd(3)

    

    Next i

    

    'Exit Sub

    

    ' delete Slides after #5, if any.

    If ActivePresentation.Slides.count >= DEFAULT_SLIDE Then

        For i = ActivePresentation.Slides.count To DEFAULT_SLIDE Step -1

                ActivePresentation.Slides(i).Delete

        Next

    End If

    ' And copy slide #3 to #5

    ActivePresentation.Slides(3).Copy

    ActivePresentation.Slides.Paste (DEFAULT_SLIDE)

    

    'ActivePresentation.SlideShowWindow.View.GotoSlide (DEFAULT_SLIDE)

    

    

    'get line width & height

    lineW = (ActivePresentation.PageSetup.SlideWidth - 2 * MARGIN) / (MAXCOL - 1)

    lineH = (ActivePresentation.PageSetup.SlideHeight - 2 * MARGIN) / (MAXROW)

    

    

    'draw lines

    For i = 1 To MAXCOL

        

        'top title, person no

        Set lineNo = ActivePresentation.Slides(DEFAULT_SLIDE).Shapes.AddTextbox(msoTextOrientationHorizontal, _

            MARGIN + (i - 1) * lineW - 20, 20, 50, 40)

        With lineNo

            .Name = "lineNo" & i

            .TextFrame.TextRange.Characters.Text = i

            .TextFrame.TextRange.Font.Color.RGB = RGB(250, 250, 250)    'RGB(150, 250, 150)

            .TextFrame2.TextRange.Font.Size = 50

            .TextFrame2.TextRange.Font.Bold = msoTrue

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

            .ActionSettings(ppMouseClick).Action = ppActionRunMacro

            .ActionSettings(ppMouseClick).Run = "on_Click"

        End With

        

        For j = 0 To MAXROW

           With ActivePresentation.Slides(DEFAULT_SLIDE)

           

           

                'draw vertical lines

                Set myLineV = .Shapes.AddLine(MARGIN + (i - 1) * lineW, MARGIN + j * lineH, _

                    MARGIN + (i - 1) * lineW, MARGIN + (j + 1) * lineH)

                'set line property

                With myLineV

                    .Name = "lineV" & i & j

                    .Line.ForeColor.RGB = RGB(150, 150, 230)

                    .Line.DashStyle = msoLineRoundDot

                    .Line.DashStyle = msoLineSysDot

                    .Line.Style = msoLineSingle

                    .Line.Weight = 3

                End With

                

                'draw horizontal lines

                If SDR(i, j) = 1 Then

                    Set myLineH = .Shapes.AddLine(MARGIN + (i - 1) * lineW, MARGIN + j * lineH, _

                    MARGIN + (i) * lineW, MARGIN + j * lineH)

                    'set line property

                    With myLineH

                        .Name = "lineH" & i & j

                        .Line.ForeColor.RGB = RGB(150, 150, 230)

                        .Line.DashStyle = msoLineRoundDot

                        .Line.DashStyle = msoLineSysDot

                        .Line.Style = msoLineSingle

                        .Line.Weight = 3

                    End With

                End If

                

           End With

           

        Next j

        

         'bottom title, prize or penalty

        Set linePay = ActivePresentation.Slides(DEFAULT_SLIDE).Shapes.AddTextbox(msoTextOrientationHorizontal, _

            MARGIN + (i - 1) * lineW - 20, MARGIN + lineH * (MAXROW + 1), 100, 60)

        With linePay

            .Name = "linePay" & i

            pay = ActivePresentation.Slides(2).Shapes("pay" & i).TextFrame.TextRange        '.Characters.Text

            .TextFrame.TextRange.Font.Color.RGB = RGB(47, 125, 253)

            '.TextFrame2.WordWrap = msoFalse

            .TextFrame2.TextRange.Font.Size = 50

            .TextFrame2.TextRange.Font.Bold = msoTrue

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

            .TextFrame2.AutoSize = msoAutoSizeTextToFitShape    'make the text fit the textbox, but doesn't apply instantly

            .TextFrame.TextRange = pay

            'MsgBox .TextFrame2.TextRange.BoundHeight & "," & .Height

        End With

    Next i

    

    'This is a Workaround To make the text shrink automatically, give the slideshow some time

    'SlideShowWindows(1).View.Exit

    'MsgBox "Click to go!!"

    'ActivePresentation.SlideShowSettings.Run

    If Application.SlideShowWindows.count > 0 Then ActivePresentation.SlideShowWindow.View.GotoSlide (DEFAULT_SLIDE)

End Sub

'when the line no is clicked, draw/show one of the ladder line

Sub on_click(myShape As Shape)

    Dim no As Integer

    Dim curLine, j As Integer

    Dim lineV, lineH As Shape

    

    no = Mid(myShape.Name, 7, 1)    'LineNo1,2,3,4~

    curLine = no

    

    CURRENT_SLIDE = ActivePresentation.SlideShowWindow.View.CurrentShowPosition

    With ActivePresentation.Slides(CURRENT_SLIDE)             'DEFAULT_SLIDE)

    'erase all lines, set the line styles back to original

    For Each lineV In .Shapes

        If Left(lineV.Name, 5) = "lineV" Or Left(lineV.Name, 5) = "lineH" Then

           lineV.Line.ForeColor.RGB = RGB(150, 150, 230)

           lineV.Line.DashStyle = msoLineRoundDot

           lineV.Line.DashStyle = msoLineSysDot

           lineV.Line.Style = msoLineSingle

           lineV.Line.Weight = 3

        End If

    Next lineV

    

    

    ' if clicked again,just return(erase all)

    'MsgBox no & "," & clickedLine

    If Int(no) = clickedLine Then

        clickedLine = 0

        Exit Sub

    End If

    

    'draw(set) a ladder line for the #no line

    For j = 0 To MAXROW

        ' if there's a hozontal line on the right

        'On Error Resume Next

        If SDR(curLine, j) = 1 Then

            Set lineH = .Shapes("lineH" & curLine & j)

            lineH.Line.ForeColor.RGB = RGB(230, 150, 150)

            lineH.Line.DashStyle = msoLineSolid

            lineH.Line.Style = msoLineSingle

            lineH.Line.Weight = 5

            curLine = curLine + 1   ' move to the right

        

        ' if there's a hozontal line on the left

        ElseIf curLine > 1 Then

            If SDR(curLine - 1, j) = 1 Then

                curLine = curLine - 1   ' move to the left

                Set lineH = .Shapes("lineH" & curLine & j)

                lineH.Line.ForeColor.RGB = RGB(230, 150, 150)

                lineH.Line.DashStyle = msoLineSolid

                lineH.Line.Style = msoLineSingle

                lineH.Line.Weight = 5

            End If

        End If

        ' draw vertical line

        Set lineV = .Shapes("lineV" & curLine & j)

        lineV.Line.ForeColor.RGB = RGB(230, 150, 150)

        lineV.Line.DashStyle = msoLineSolid

        lineV.Line.Style = msoLineSingle

        lineV.Line.Weight = 5

'add some interval here

        'Delay (0.3)

    Next j

    End With

    clickedLine = Int(no)

    

    

End Sub

Private Sub Delay(Seconds As Single)

    Dim TimeNow As Long

    TimeNow = Timer

    Do While Timer < TimeNow + Seconds

        DoEvents

    Loop

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

다음에는 랜덤함수를 이용하는 과정을 다뤄보기로  하겠습니다.

사실 사다리 동작보다 중복을 제외한 랜덤숫자를 추출해 내는 것이 더 복잡하고 생각이 필요합니다.

Sadari.pptm

 

첨부파일을 다운받아 이용하세요.

파워포인트 2010에서 제작했습니다.

*** 수 정 ***

미 벌칙과 참가자를 적은 환경설정을 불러오는 약간 수정된 버전입니다.

오래전에 만들었던 거라 수정하기가 껄끄럽네요.

소스가 부끄럽습니다.

(64비트 호환성을 위해 API선언도 수정하였습니다. 2019.10.29.)

Sadari2.zip

copyright (c) konahn 2016