[게임] 윷놀이 (6가지 스킨)

2022년 임인년을 맞아 파워포인트로 윷놀이 게임을 만들어 보았습니다.

 

첫화면에서 6가지 스킨을 선택하면 윷놀이 게임을 시작합니다.

게임에 앞서 왼쪽 아래 Roulette Style에서 회전 룰렛의 스타일을 선택할 수 있습니다.

 

나올 확률이 같은 룰렛 회전판

나올 확률이 다른 룰렛 회전판

 

스킨들

1번 스킨

 

2번 스킨

 

3번 스킨

 

4번 스킨

 

5번 스킨

 

6번 스킨

 

실행 화면

 

 

왼쪽 윷을 클릭하면

룰렛 회전판이 뜨고 돌다가 자동으로 멈춥니다.

이 때 나온 윷모양을 확인하고 클릭해서 닫고

오른쪽 팀별 말을 하나 클릭해서 드래그해서 윷판의 위치에 말을 표시합니다.

말은 다시 클릭해서 옮길 수 있습니다.

윷놀이 규칙에 따라 말을 움직여서 먼저 들어온 팀이 이기게 됩니다.

다시 시작할 때는 Reset 을 누르면 됩니다.

말을 놓을 때 오른쪽 영역에 놓으면 자동으로 원위치로 돌아갑니다.

 

룰렛 회전 소스:

'by konahn(at)naver.com(http://konahn.tistory.com)

Option Explicit

#If VBA7 Then
    Public Declare PtrSafe Function WaitMessage Lib "user32" () As Long
#Else
    Public Declare Function WaitMessage Lib "user32" () As Long
#End If

Public ROption As Integer   'ROption 룰렛 회전판 옵션(default=0)

Function waitTimer(tick As Double)
    
    Dim oldTimer As Double
    oldTimer = Timer
    Do While Timer <= oldTimer + tick
        DoEvents
        WaitMessage
    Loop
    
End Function

Function PlayMedia(oSld As Slide, str As String)
    Dim shp As Shape, oShp As Shape
    Dim mPlayer As Player
    Dim i As Integer
    
    Set shp = oSld.Shapes(str)
    'For Each oShp In oSld.Shapes
    '    If oShp.Type = msoMedia Then
    '        SlideShowWindows(1).View.Player(oShp.Id).Stop
    '    End If
    'Next oShp
    With SlideShowWindows(1).View.Player(shp.Id)
        'If .State <> ppPlaying Then
        '.Stop
        .Play
    End With
End Function

'Sub test()
'    Dim shp As Shape
'    Set shp = ActivePresentation.Slides(1).Shapes("Box_1_1")
'    Call onClick(shp)
'End Sub
'Sub test2()
'    Dim shp As Shape
'    Set shp = ActivePresentation.Slides(1).Shapes("Dice")
'    Call doRoulette(shp)
'End Sub

Sub doRoulette(shp As Shape)
    Dim sld As Slide, oSld As Object
    Dim oShp As Shape
    Dim eft As Effect
    Dim SW As Single, SH As Single
    
    Call getROption
    If ROption = 0 Then ROption = 4    'Default Custom Layout
    
    Randomize
    With ActivePresentation.PageSetup
        SW = .SlideWidth: SH = .SlideHeight
    End With
    Set sld = shp.Parent
    If shpExist(sld, "Triangle") Then sld.Shapes("Triangle").Delete
    If shpExist(sld, "Roulette") Then sld.Shapes("Roulette").Delete
    If shpExist(sld, "Rectangle") Then sld.Shapes("Rectangle").Delete
    
    '배경 박스
    Set oShp = sld.Parent.SlideMaster.CustomLayouts(ROption).Shapes("Rectangle")
    oShp.Copy
    With sld.Shapes.Paste(1)
        .Left = 0:        .Top = 0
    End With
    
    Set oShp = sld.Parent.SlideMaster.CustomLayouts(ROption).Shapes("Roulette")
    Set oSld = oShp.Parent
    '룰렛도형의 마지막 두번째 회전 효과 변경
    Set eft = oSld.TimeLine.MainSequence.Item(oSld.TimeLine.MainSequence.Count - 1)
    eft.Timing.Duration = 0.5 + 1 * Rnd   '지속 시간
    eft.EffectParameters.Amount = -1 * (30 + 360 * Rnd) '회전 각도
    '룰렛도형의 마지막 회전 효과 변경
    Set eft = oSld.TimeLine.MainSequence.Item(oSld.TimeLine.MainSequence.Count)
    eft.Timing.Duration = 3 + 2 * Rnd   '지속 시간
    eft.EffectParameters.Amount = 720 + 720 * Rnd  '회전 각도
    oShp.Copy
    sld.Shapes.Paste (1)

    Set oShp = sld.Parent.SlideMaster.CustomLayouts(ROption).Shapes("Triangle")
    oShp.Copy
    sld.Shapes.Paste (1)
    
    'Call PlayMedia(sld, "Spin")
End Sub

'Sub test3()
'    Dim shp As Shape
'    Set shp = ActivePresentation.Slides(1).Shapes("Load")
'    Call loadBingo(shp)
'End Sub

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

Sub removeRoulette(oShp As Shape)
    If oShp.Name = "Triangle" Then
        oShp.Parent.Shapes("Roulette").Delete
        oShp.Parent.Shapes("Rectangle").Delete
        oShp.Parent.Shapes("Triangle").Delete
    ElseIf oShp.Name = "Rectangle" Then
        oShp.Parent.Shapes("Triangle").Delete
        oShp.Parent.Shapes("Roulette").Delete
        oShp.Parent.Shapes("Rectangle").Delete
    Else
        oShp.Parent.Shapes("Triangle").Delete
        oShp.Parent.Shapes("Rectangle").Delete
        oShp.Parent.Shapes("Roulette").Delete
    End If
End Sub

Sub Reset(rshp As Shape)

    Dim shp As Shape, fu As Shape
    Dim sld As Slide
    Dim s As Long
    
    'Set sld = ActivePresentation.Slides(1)
    Set sld = rshp.Parent
    Set fu = sld.Shapes("FFlag_Under")
    For Each shp In sld.Shapes
        If shp.Name Like "Flag*" Then
            Call putFlag(shp, fu)
        End If
    Next shp
    'Flag zOrder 정렬
    Call ArrangeFlags(sld)
End Sub

Private Sub ResetTest()
    ArrangeFlags ActiveWindow.View.Slide
End Sub

Function ArrangeFlags(oSld As Slide)
    Dim arr() As String, tmp As String
    Dim s As Long, t As Long
    Dim shp As Shape
    
    'collect Flag names
    For Each shp In oSld.Shapes
        If shp.Name Like "Flag*" Then
            s = s + 1
            ReDim Preserve arr(1 To s)
            arr(s) = shp.Name
        End If
    Next shp
    
    'sort Flag array
    For s = 1 To UBound(arr) - 1
        For t = s + 1 To UBound(arr)
            If arr(s) > arr(t) Then
                tmp = arr(s)
                arr(s) = arr(t)
                arr(t) = tmp
            End If
        Next t
    Next s
    
    'Flag zOrder 정렬
    For s = 1 To UBound(arr)
        'Debug.Print arr(s), oSld.Shapes(arr(s)).ZOrderPosition, oSld.Shapes.Count - s
        While oSld.Shapes(arr(s)).ZOrderPosition < oSld.Shapes(oSld.Shapes.Count).ZOrderPosition - s
            oSld.Shapes(arr(s)).ZOrder msoBringForward
        Wend
    Next s
        
End Function

Function putFlag(fShp As Shape, uShp As Shape)
    Dim m As Single
    
    m = 10  '좌우상하 여백
    fShp.Left = uShp.Left + m + (Mid(fShp.Name, 6, 1) - 1) * (uShp.Width - 2 * m) / 2 + ((uShp.Width - 2 * m) / 2 - fShp.Width) / 2
    fShp.Top = m + (uShp.Height - 2 * m) / 5 * (Asc(Mid(fShp.Name, 5, 1)) - Asc("A")) + ((uShp.Height - 2 * m) / 5 - fShp.Height) / 2
    
End Function

Sub ROptionClick(shp As Shape)
    
    Dim sld As Slide
    Dim oShp As Shape
    Set sld = shp.Parent
    
    shp.PictureFormat.ColorType = msoPictureAutomatic
    For Each oShp In sld.Shapes
        If oShp.Name Like "ROption#" Then
            If Not oShp Is shp Then oShp.PictureFormat.ColorType = msoPictureGrayscale
        End If
    Next oShp
    ROption = Int(Mid(shp.Name, 8)) 'SlideMaster Custom Layout Index
End Sub

Function getROption()
    Dim sld As Slide
    Dim oShp As Shape
    Set sld = ActivePresentation.Slides(1)
 
    For Each oShp In sld.Shapes
        If oShp.Name Like "ROption#" Then
            If oShp.PictureFormat.ColorType = msoPictureAutomatic Then
                ROption = Int(Mid(oShp.Name, 8))
                Exit For
            End If
        End If
    Next oShp
    
End Function

'Sub addActionToButtons()
'
'    Dim sld As Slide
'    Dim shp As Shape
'    Dim i As Integer
'
'    Set sld = ActiveWindow.Selection.SlideRange(1)
'
'    For Each shp In sld.Shapes
'        If shp.Name Like "Box_*" Then
'
'            With shp.ActionSettings(ppMouseClick)
'                .Action = ppActionRunMacro
'                .Run = "onClick"
'            End With
'            i = i + 1
'        End If
'    Next shp
'
'    MsgBox i & " 개의 도형에 적용완료"
'End Sub

'Sub addActionToChildren()
'
'    Dim sld As CustomLayout
'    Dim shp As Shape
'    Dim i As Integer
'
'    'Set sld = ActiveWindow.Selection.SlideRange(1)
'    Set sld = ActivePresentation.SlideMaster.CustomLayouts(4)
'
'
'    For Each shp In sld.Shapes("Roulette").GroupItems
'        If shp.Name Like "Arc_*" Or shp.Name Like "TextBox_*" Then
'            With shp.ActionSettings(ppMouseClick)
'                .Action = ppActionRunMacro
'                .Run = "removeRoulette"
'            End With
'            i = i + 1
'        End If
'    Next
'
'    MsgBox i & " 개의 도형에 적용완료"
'End Sub

Function removeTrash(tSld As Slide)
    If shpExist(tSld, "Triangle") Then tSld.Shapes("Triangle").Delete
    If shpExist(tSld, "Roulette") Then tSld.Shapes("Roulette").Delete
    If shpExist(tSld, "Rectangle") Then tSld.Shapes("Rectangle").Delete
End Function
'
'Sub OnSlideShowTerminate(SSW As SlideShowWindow)
'    Dim sld As Slide
'
'    For Each sld In ActivePresentation.Slides
'        Call removeTrash(sld)
'    Next sld
'
'End Sub

 

개체 드래그 소스:

#If VBA7 Then
    Public Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As Long
    Public Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
    Public Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDc As Long) As Long
    Public Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDc As Long, ByVal nIndex As Long) As Long
    Public Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Public Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal IpTimerFunc As LongPtr) As LongPtr
    Public Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As LongPtr
    Public TimerID As LongPtr
#Else
    Public Declare Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As Long
    Public Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
    Public Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDc As Long) As Long
    Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDc As Long, ByVal nIndex As Long) As Long
    Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Public Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal IpTimerFunc As Long) As Long
    Public Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
    Public TimerID As Long
#End If

Public Const LOGPIXELSX = 88
Public Const LOGPIXELSY = 90
Public Const SM_CXSCREEN = 0
Public Const SM_CYSCREEN = 1
Public Type PointAPI
   x As Long
   y As Long
End Type
Public Cur As PointAPI
Public Picked As Shape
Public Air As Boolean

Private Function Delta(lngVal As Long)
    Dim hDc As Long, ppi As Long
    hDc = GetDC(0)
    ppi = GetDeviceCaps(hDc, LOGPIXELSX)
    ReleaseDC 0, hDc
    Delta = lngVal * 72 / ppi / (ActivePresentation.SlideShowWindow.View.Zoom / 100)
End Function

Sub Pick(shp As Shape)
    Set Picked = shp
    TimerON
    shp.Parent.Shapes("Screen").Visible = True
    '맨 위 Screen도형 다음으로
    shp.ZOrder msoBringToFront
    shp.ZOrder msoSendBackward
End Sub

Sub Drop(shp As Shape)
    Dim fu As Shape
    TimerOFF

    Set fu = shp.Parent.Shapes("FFlag_Under")
    '깃발 도형이면 원위치
    If Picked.Name Like "Flag*" And Picked.Left >= fu.Left Then
        Call putFlag(Picked, fu)
    End If
    
    Set Picked = Nothing
    shp.Parent.Shapes("Screen").Visible = False
End Sub

Sub Proc()
    On Error Resume Next
    GetCursorPos Cur
    Dim bX As Long, bY As Long
    bX = (Delta(GetSystemMetrics(SM_CXSCREEN)) - ActivePresentation.PageSetup.SlideWidth) / 2
    bY = (Delta(GetSystemMetrics(SM_CYSCREEN)) - ActivePresentation.PageSetup.SlideHeight) / 2
    
    Picked.Left = Delta(Cur.x) - Picked.Width / 2 - bX
    Picked.Top = Delta(Cur.y) - Picked.Height / 2 - bY

End Sub

Public Function TimerON()
    If TimerID = 0 Then
        TimerID = SetTimer(0&, 0&, 10&, AddressOf Proc)
    End If
End Function

Public Function TimerOFF()
    KillTimer 0&, TimerID
    TimerID = 0
End Function

Sub OnSlideShowTerminate(SSW As SlideShowWindow)
    Dim sld As Slide
    Set sld = ActiveWindow.View.Slide
    
    'Set sld = ActivePresentation.Slides(1)
    KillTimer 0&, TimerID
    TimerID = 0
    Set Picked = Nothing
    '룰렛도형 삭제
    Call removeTrash(sld)
    '깃발 원위치
    Call Reset(sld.Shapes("Reset"))
End Sub

'깃발 도형을 추가한 경우 최초 1회 실행할 것!
Sub A_RunFirst()
    
    Dim shp As Shape
    Dim sld As Slide
    On Error GoTo Oops
    
    '//선택된 도형들에 'Pick' 매크로를 걸어줌
    For Each shp In ActiveWindow.Selection.ShapeRange
        With shp.ActionSettings(ppMouseClick)
            .Action = ppActionRunMacro
            .Run = "Pick"
        End With
    Next shp
    
    Set sld = ActiveWindow.Selection.SlideRange(1)
    'Screen 도형을 맨 앞으로보내고, 감추기, Drop 매크로 지정
    With sld.Shapes("Screen")
        .ActionSettings(ppMouseClick).Action = ppActionRunMacro
        .ActionSettings(ppMouseClick).Run = "Drop"
        .ZOrder msoBringToFront
        .Visible = msoFalse
    End With
    
Oops:
    If Err Then MsgBox Err.Description
End Sub

'// not used
Sub B_RandomLocation()
    Dim shp As Shape
    Dim sld As Slide
    Dim SW As Single, SH As Single
    Const Margin As Single = 50
    Randomize
    With ActivePresentation.PageSetup
        SW = .SlideWidth: SH = .SlideHeight
    End With
    Set sld = ActiveWindow.Selection.SlideRange(1)
    '// 'Pick' 매크로가 걸린 도형의 위치를 섞어줌
    For Each shp In sld.Shapes
        If shp.ActionSettings(ppMouseClick).Run = "Pick" Then
            shp.Left = Rnd * SW
            If shp.Left < Margin Then shp.Left = Margin
            If shp.Left + shp.Width > SW - Margin Then shp.Left = SW - Margin - shp.Width
            shp.Top = Rnd * SH
            If shp.Top < Margin Then shp.Top = Margin
            If shp.Top + shp.Height > SH - Margin Then shp.Top = SH - Margin - shp.Height
        End If
    Next shp
    
End Sub

 

 

파일 첨부합니다.

(참고: 윷놀이 배경판과 말모양은 인터넷에서 받은 그림을 벡터로 Tracing한 것들이 포함되어 있습니다.)

 

yut1.pptm

1.84MB

 

 

※ 주의) '서울한강 장체 EB' 폰트가 없는 경우 아래 사이트에서 폰트를 설치하셔야 합니다.

https://www.seoul.go.kr/seoul/font.do

 

365와 2021에서 테스트하였습니다.

 

스킨 슬라이드 추가/수정 방법:

기존 스킨 슬라이드 복제 후 윷놀이 배경 그림만  교체하면 됩니다.

슬라이드를 추가한 경우 1슬라이드의 요약/확대를 변경해야 합니다.

(요약확대는 2019나 35구독버전에서만 지원)

 

말 도형/그림 변경 방법:

말 도형은 FlagA1, FlagB2, FlagF3 이런 형식이어야 합니다.

만들어진 말 도형은 선택하고 Alt-F8누르고 A_RunFirst 를 한번 실행해서 Pick 매크로를 지정해주세요.

(도형 클릭 드래그 소스는 파겜마의 ShortFox님의 코드를 참고했습니다.)

 

룰렛 회전판 변경 방법:

슬라이드마스터의 4번과 5번에 기존 룰렛이 있는데 참고하여

변경하되 룰렛 생성기를 이용하면 편함.

애니메이션도 기존 룰렛의 애니메이션복사해서 애니메이션 붙여넣기로 나타나기, 역회전, 회전 3가지 애니메이션이 들어 있어야 함. 회전 각도는 랜덤하게 변경됨.

1슬라이드 왼쪽 아래 Roulette Style에 룰렛 그림을 추가하고 도형이름은 ROption6 으로 변경(6은 슬라이드 마스터의 레이아웃 순서)