Qiita Teams that are logged in
You are not logged in to any team

Log in to Qiita Team
OrganizationAdvent CalendarQiitadon (β)
Qiita JobsQiita ZineQiita Blog
Help us understand the problem. What is going on with this article?


More than 3 years have passed since last update.

Powerpoint VBAで当たり判定を考える。





今回接触判定に使用しているのはMSOffice 2010以降から搭載されている「図形の結合」機能である(2010ではリボンに表示されていないが、機能自体は存在している)。

Office 2013以降なら
(図形を選択) 描画ツール > 書式 > 図形の挿入



PowerPoint2010以降で動作するはずです(2013 32bit/2016 64bitで動作確認)。




Option Explicit

Private Declare PtrSafe Sub _
    Sleep Lib "kernel32" ( _
    Optional ByVal dwMilliseconds As Long = 1)

Public Type OfficeXY
    X As Single
    Y As Single
End Type

Sub BallBoundSample()
        Dim TgtPres As PowerPoint.Presentation
        Set TgtPres = PowerPoint.ActivePresentation

        TgtPres.SlideShowSettings.ShowType = ppShowTypeWindow2

        Dim sldShowWin As PowerPoint.SlideShowWindow
        If TgtPres.Windows.Count = 0 Then
            Set sldShowWin = TgtPres.SlideShowWindow
            Set sldShowWin = TgtPres.SlideShowSettings.Run
        End If

        Dim tgtSld As Slide
        Set tgtSld = sldShowWin.View.Slide

        Dim tgtGround As PowerPoint.Shape
        Set tgtGround = MakeGround(tgtSld)

        Dim myBall As Ball
        Set myBall = MakeBall(tgtSld)

            If Not InSlideArea(myBall.BaseShape, TgtPres) Then Exit Do
            Call myBall.NextStep(0.2)
            Call myBall.Clash(tgtGround)
            Call Sleep
            DoEvents    '描写・途中で止めたい場合用


End Sub

Private Function MakeGround(ByVal iTgtSld As Slide) As Shape
    Dim shps As PowerPoint.Shapes
    Set shps = iTgtSld.Shapes

    Dim oShp As Shape

    With iTgtSld.Parent.SlideMaster
        Set oShp = shps.AddShape(msoShapeRectangle, -.Width, .Height / 2, .Width * 3, 1)
    End With    'iTgtSld.Parent.SlideMaster
    Call oShp.IncrementRotation(15)
    Set MakeGround = oShp
End Function

Private Function MakeBall(ByVal iTgtSld As Slide) As Ball
    Const Size! = 50!

    Dim shpTop As Single: shpTop = 0!
    Dim shpLft As Single: shpLft = 0!
    Dim shpWid As Single: shpWid = Size
    Dim shpHit As Single: shpHit = Size

    Dim shps As PowerPoint.Shapes
    Set shps = iTgtSld.Shapes

    Dim tmpBall As PowerPoint.Shape
    Set tmpBall = shps.AddShape(msoShapeOval, shpLft, shpTop, shpWid, shpHit)
    Set MakeBall = GetBallClass(tmpBall)
End Function

Private Function GetBallClass(ByVal BaseShape As Shape) As Ball
    Dim tmpCls As Ball
    Set tmpCls = New Ball
    Call tmpCls.Init(BaseShape)
    Set GetBallClass = tmpCls
End Function

Private Function InSlideArea(ByVal ChkShp As Shape, ByVal TgtPres As Presentation) As Boolean
    With TgtPres.SlideMaster
        If ChkShp.Top + ChkShp.Height < 0 Then GoTo NotInSlideArea
        If ChkShp.Left > .Width Then GoTo NotInSlideArea

        If ChkShp.Left + ChkShp.Width < 0 Then GoTo NotInSlideArea
        If ChkShp.Top > .Height Then GoTo NotInSlideArea
    End With
    Let InSlideArea = True
Exit Function
    Let InSlideArea = False
Exit Function
End Function


Option Explicit

Private clsShp As PowerPoint.Shape
Private clsVelocity As OfficeXY
Private clsAcceleration As OfficeXY

Private Const Ratio! = 0.9!

Public Property Get BaseShape() As PowerPoint.Shape
    Set BaseShape = clsShp
End Property

Public Property Get Velocity() As OfficeXY
    Let Velocity = clsVelocity
End Property

Public Property Get Acceleration() As OfficeXY
    Let Acceleration = clsAcceleration
End Property

Private Sub Class_Initialize()
    clsVelocity.X = 0!
    clsVelocity.Y = 0!
    clsAcceleration.X = 0!
    clsAcceleration.Y = 9.81!
End Sub

Friend Sub Init(ByVal BaseShape As PowerPoint.Shape)
    Set clsShp = BaseShape
End Sub

Public Sub NextStep(Optional ByVal Step As Single = 1)
    With clsShp
        .Left = VBA.CSng(.Left + (clsVelocity.X * Step))
        .Top = VBA.CSng(.Top + (clsVelocity.Y * Step))
    End With    'clsShp

    With clsVelocity
        .X = VBA.CSng((.X + clsAcceleration.X * Step))
        .Y = VBA.CSng((.Y + clsAcceleration.Y * Step))
    End With    'clsVelocity

    clsShp.TextFrame2.TextRange.Text = " "
End Sub

Public Function Clash(ByVal iTgtShp As PowerPoint.Shape) As Boolean
    Dim sldShps As PowerPoint.Shapes
    Set sldShps = clsShp.Parent.Shapes

    Dim currentShpCnt As Long
    currentShpCnt = sldShps.Count

    Dim shpIndxs(1) As Long
    shpIndxs(0) = clsShp.ZOrderPosition
    shpIndxs(1) = iTgtShp.ZOrderPosition

    Dim dupShpRng As PowerPoint.ShapeRange
    Set dupShpRng = sldShps.Range(shpIndxs).Duplicate

    Dim dupOvalIndex As Long
    dupOvalIndex = IIf(shpIndxs(0) < shpIndxs(1), 1, 2)

    Dim currentCoords As OfficeXY
    With dupShpRng.Item(dupOvalIndex)
        currentCoords.X = .Left + (.Width / 2)
        currentCoords.Y = .Top + (.Height / 2)
    End With    'dupShpRng.Item(1)

    Call dupShpRng.MergeShapes(msoMergeIntersect)
    If currentShpCnt + 1 <> sldShps.Count Then Exit Function
    Clash = True

    Dim intersectShp As PowerPoint.Shape
    Set intersectShp = sldShps.Item(currentShpCnt + 1)

    Dim normalVector As OfficeXY
    normalVector.X = currentCoords.X - (intersectShp.Left + (intersectShp.Width / 2))
    normalVector.Y = currentCoords.Y - (intersectShp.Top + (intersectShp.Height / 2))

    Dim normalVec As Double
    normalVec = VectorNorm(normalVector)

    Dim basVector As Double
    basVector = VectorNorm(clsVelocity)

    With clsVelocity
        .X = VBA.CSng(basVector * (normalVector.X / normalVec) * Ratio)
        .Y = VBA.CSng(basVector * (normalVector.Y / normalVec) * Ratio)
    End With

    Call intersectShp.Delete
End Function

Private Function VectorNorm(BaseVector As OfficeXY) As Double
    Let VectorNorm = VBA.Sqr(BaseVector.X * BaseVector.X + BaseVector.Y * BaseVector.Y)
End Function





Help us understand the problem. What is going on with this article?
Why not register and get more from Qiita?
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away
Excel・PowerPoint の VBA、Windows PowerShell がメインの人です。 Word・Outlook の VBA も多少は読めます。 データベース関連や、管理用途の PowerShell は経験なし。 PowerShell の延長で、C# も雰囲気は読める感じです。


No comments
Sign up for free and join this conversation.
Sign Up
If you already have a Qiita account Login
Help us understand the problem. What is going on with this article?