PowerPoint에서 원을 연주해보세요
기사에 영감을 받아 적당히 원이 튀는 것을 만들어 보았다.
그렇게 움직이고 있는 것만으로, 법칙이라든지 적당한 것은 용서를.
접촉 판정
이번 접촉 판정에 사용하고 있는 것은 MSOffice 2010 이후부터 탑재되고 있는 「도형의 결합」기능이다(2010에서는 리본에 표시되어 있지 않지만, 기능 자체는 존재하고 있다).
Office 2013 이상이라면
(도형 선택) 그리기 도구 > 서식 > 도형 삽입
에 존재한다.
보다 상세한 부분은 선두 기사 를 참조.
코드
PowerPoint2010 이상에서 작동해야 합니다(2013 32bit/2016 64bit에서 작동 확인).
PowerPoint에서 표준 모듈과 클래스 모듈을 삽입하고 다음 코드를 붙여 넣습니다.
클래스 모듈의 이름은 Ball
로 한다.
BallBoundSample
프로 시저를 시작하면 위의 이미지와 같은 동작을 수행해야합니다.
표준 모듈
표준 모듈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
sldShowWin.Activate
Else
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)
'動かしてみる
Do
'スライド外になったら抜ける
If Not InSlideArea(myBall.BaseShape, TgtPres) Then Exit Do
Call myBall.NextStep(0.2)
Call myBall.Clash(tgtGround)
Call Sleep
DoEvents '描写・途中で止めたい場合用
Loop
'後始末
'Stop
tgtSld.Shapes.Range.Delete
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
NotInSlideArea:
Let InSlideArea = False
Exit Function
End Function
클래스 모듈: Ball
Ball.clsOption 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
'不完全なロジック
'大きくめり込んだとき、貫通したとき復帰不可
'分解能を上げる(NextStepの引数を小さくする)ことで仮対応
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
기타
2017/01/15 추가
선두 기사 님의 기사가 추가되었습니다.
선을 따라 구슬의 운동을 그리는 ④
Reference
이 문제에 관하여(PowerPoint에서 원을 연주해보세요), 우리는 이곳에서 더 많은 자료를 발견하고 링크를 클릭하여 보았다
https://qiita.com/nukie_53/items/f9273223004898b8c166
텍스트를 자유롭게 공유하거나 복사할 수 있습니다.하지만 이 문서의 URL은 참조 URL로 남겨 두십시오.
우수한 개발자 콘텐츠 발견에 전념
(Collection and Share based on the CC Protocol.)
PowerPoint2010 이상에서 작동해야 합니다(2013 32bit/2016 64bit에서 작동 확인).
PowerPoint에서 표준 모듈과 클래스 모듈을 삽입하고 다음 코드를 붙여 넣습니다.
클래스 모듈의 이름은
Ball
로 한다.BallBoundSample
프로 시저를 시작하면 위의 이미지와 같은 동작을 수행해야합니다.표준 모듈
표준 모듈
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
sldShowWin.Activate
Else
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)
'動かしてみる
Do
'スライド外になったら抜ける
If Not InSlideArea(myBall.BaseShape, TgtPres) Then Exit Do
Call myBall.NextStep(0.2)
Call myBall.Clash(tgtGround)
Call Sleep
DoEvents '描写・途中で止めたい場合用
Loop
'後始末
'Stop
tgtSld.Shapes.Range.Delete
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
NotInSlideArea:
Let InSlideArea = False
Exit Function
End Function
클래스 모듈: Ball
Ball.cls
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
'不完全なロジック
'大きくめり込んだとき、貫通したとき復帰不可
'分解能を上げる(NextStepの引数を小さくする)ことで仮対応
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
기타
2017/01/15 추가
선두 기사 님의 기사가 추가되었습니다.
선을 따라 구슬의 운동을 그리는 ④
Reference
이 문제에 관하여(PowerPoint에서 원을 연주해보세요), 우리는 이곳에서 더 많은 자료를 발견하고 링크를 클릭하여 보았다
https://qiita.com/nukie_53/items/f9273223004898b8c166
텍스트를 자유롭게 공유하거나 복사할 수 있습니다.하지만 이 문서의 URL은 참조 URL로 남겨 두십시오.
우수한 개발자 콘텐츠 발견에 전념
(Collection and Share based on the CC Protocol.)
Reference
이 문제에 관하여(PowerPoint에서 원을 연주해보세요), 우리는 이곳에서 더 많은 자료를 발견하고 링크를 클릭하여 보았다 https://qiita.com/nukie_53/items/f9273223004898b8c166텍스트를 자유롭게 공유하거나 복사할 수 있습니다.하지만 이 문서의 URL은 참조 URL로 남겨 두십시오.
우수한 개발자 콘텐츠 발견에 전념 (Collection and Share based on the CC Protocol.)