難しいなぁ(;´▽｀A``
一日，斜面を玉を転がしてみてるんですが，うまくいきません。
いい加減行き当たりばったりをやめればいいんですが，きちんと考えようという頭が出てこない。
( ´Д｀)=3 ﾌｩ
今こんな感じになってしまいました。
明らかな間違いがどこかに入っているのでしょう，職業的にはお恥ずかしい限りですが，
まぁミスを含んでいて，加速しまくって飛んで行ってしまうコードを一応載せます。
( ´ー｀)ﾌｩｰ．．． 勢いよく飛んでいくのでそれは・・面白いかもしれない。
標準モジュール
Option Explicit Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr) Public Const Rate As Currency = 1 Const SID = 1 Const PI = 3.1415 Sub Test() Dim TSlide As Slide: Set TSlide = ActivePresentation.Slides(SID) Dim shpBall As Shape Dim shpSlope As Shape: Set shpSlope = TSlide.Shapes("slope") ActivePresentation.SlideShowSettings.Run Dim y0 As Long: y0 = 30 Set shpBall = TSlide.Shapes.AddShape(msoShapeOval, 40, 20, 40, 40) shpBall.Fill.ForeColor.RGB = vbYellow shpBall.Line.ForeColor.RGB = vbBlack shpBall.Line.Weight = 2 Dim Ball As ShpCls: Set Ball = New ShpCls Ball.SetShp shpBall Dim A0 As Currency: A0 = 2 Dim AAngle0 As Currency: AAngle0 = PI / 2 Ball.SetA A0, AAngle0 Dim Check As CorrCls: Set Check = New CorrCls Do Check.当たり判定 Ball, shpSlope, True, A0, AAngle0 Ball.Move shpBall.TextFrame.TextRange = " " DoEvents Sleep 10 If Ball.X > 960 Then Exit Do If Ball.Y > 540 Then Exit Do Loop Ball.Delete End Sub Sub Draw(pSlide As Slide, 直径 As Long, 色 As Long, pX As Long, pY As Long) shpBall = pSlide.Shapes.AddShape(msoShapeOval, pX, pY, 直径, 直径) shpBall.Fill.ForeColor.RGB = 色 shpBall.Line.ForeColor.RGB = RGB(0, 0, 0) shpBall.Line.Weight = 2 End Sub
ShpCls.cls
Option Explicit Const PI = 3.1415 Private pShp As Shape Private pV As Currency Private pVAngle As Currency Private pA As Currency Private pAAngle As Currency Public Sub SetShp(図形 As Shape) Set pShp = 図形 End Sub Property Get Shp() As Shape Set Shp = pShp End Property Property Get X() As Currency X = pShp.Left + pShp.Width / 2 End Property Property Let X(X座標 As Currency) pShp.Left = X座標 - pShp.Width / 2 End Property Property Get Y() As Currency Y = pShp.Top + pShp.Height / 2 End Property Property Let Y(Y座標 As Currency) pShp.Top = Y座標 - pShp.Height / 2 End Property Property Get Left() As Currency Left = pShp.Left End Property Property Let Left(pLeft As Currency) pShp.Left = pLeft End Property Property Get Right() As Currency Right = pShp.Left + pShp.Width End Property Property Let Right(pRight As Currency) pShp.Left = pRight - pShp.Width End Property Property Get Top() As Currency Top = pShp.Top End Property Property Let Top(pTop As Currency) pShp.Top = pTop End Property Property Get Bottom() As Currency Bottom = pShp.Top + pShp.Height End Property Property Let Bottom(pBottom As Currency) pShp.Top = pBottom - pShp.Height End Property Property Get Width() As Currency Width = pShp.Width End Property Property Let Width(pWidth As Currency) pShp.Width = pWidth End Property Property Get Height() As Currency Height = pShp.Height End Property Property Let Height(pHeight As Currency) pShp.Height = pHeight End Property Public Sub Delete() pShp.Delete End Sub Property Get 速度角度() As Currency 速度角度 = pVAngle End Property Property Get 速度大きさ() As Currency 速度大きさ = pV End Property Property Get 加速度角度() As Currency 加速度角度 = pAAngle End Property Property Get 加速度大きさ() As Currency 加速度大きさ = pA End Property Property Get スライド() As Slide Set スライド = ActivePresentation.Slides(pShp.Parent.SlideIndex) End Property Public Sub SetV(速度 As Currency, 速度角度 As Currency) pV = 速度 pVAngle = 速度角度 End Sub Public Sub SetA(加速度 As Currency, 加速度角度 As Currency) pA = 加速度 pAAngle = 加速度角度 End Sub Public Sub Move() Me.X = Me.X + pV * Cos(pVAngle) Me.Y = Me.Y + pV * Sin(pVAngle) pV = Sqr((pV * Cos(pVAngle) + pA * Cos(pAAngle)) ^ 2 + (pV * Sin(pVAngle) + pA * Sin(pAAngle)) ^ 2) pVAngle = Angle(pV * Cos(pVAngle) + pA * Cos(pAAngle), pV * Sin(pVAngle) + pA * Sin(pAAngle)) 'Debug.Print pV; " "; pVAngle / 3.14 * 180; " "; pA; " "; pAAngle / 3.14 * 180 'Stop End Sub Function Angle(X As Currency, Y As Currency) Dim pHosei As Currency If Abs(X) < 0.001 Then If Y > 0 Then Angle = PI / 2 ElseIf Y < 0 Then Angle = -PI / 2 Else Angle = PI / 2 '(;´▽｀A`` End If Else If X > 0 Then If Y >= 0 Then pHosei = 0 Else pHosei = 2 * PI Else If Y >= 0 Then pHosei = PI Else pHosei = PI End If Angle = Atn(Y / X) End If Angle = Angle + pHosei End Function
CorrCls.cls
Option Explicit Const PI As Currency = 3.1415 Private pAngle As Currency Private pAngleCol As Currency Private pDist As Currency Private pDistCol As Currency Private pDistAngle As Currency Private pblnColl As Boolean Property Get bln当たり() As Boolean bln当たり = pblnColl End Property Property Get 角度() As Currency 角度 = pAngle End Property Property Get 距離() As Currency 距離 = pDist End Property Property Get 重なり距離() As Currency 重なり距離 = pDistCol End Property Public Sub 当たり判定(pShpCls As ShpCls, tShp As Shape, blnMove As Boolean, pA0 As Currency, pAAngle0 As Currency) Dim pSlide As Slide: Set pSlide = pShpCls.スライド Dim lngShpNo As Long: lngShpNo = pSlide.Shapes.Count pSlide.Shapes.Range(Array(pShpCls.Shp.Name, tShp.Name)).Duplicate.MergeShapes msoMergeIntersect Dim sS As ShpCls: Set sS = pShpCls Dim tS As ShpCls: Set tS = New ShpCls: tS.SetShp tShp pAngle = Angle(tS.X - sS.X, tS.Y - sS.Y) pDist = Sqr((tS.X - sS.X) ^ 2 + (tS.Y - sS.Y) ^ 2) If pSlide.Shapes.Count = lngShpNo Then pShpCls.SetA pA0, pAAngle0 pblnColl = False Exit Sub End If pblnColl = True Dim dS As ShpCls: Set dS = New ShpCls: dS.SetShp pSlide.Shapes(pSlide.Shapes.Count) dS.X = dS.X - 12: dS.Y = dS.Y - 12 'Duplicateのずれの訂正 pDistCol = Sqr((dS.X - sS.X) ^ 2 + (dS.Y - sS.Y) ^ 2) pDistAngle = Angle(dS.X - sS.X, dS.Y - sS.Y) sS.SetV sS.速度大きさ, pDistAngle - PI / 2 sS.SetA pA0 * Cos(pDistAngle - PI / 2), pDistAngle - PI / 2 With pSlide.Shapes.AddLine(sS.X, sS.Y, sS.X + sS.速度大きさ * Cos(pDistAngle - PI / 2), sS.Y + sS.速度大きさ * Sin(pDistAngle - PI / 2)) .Line.ForeColor.RGB = vbRed .Line.EndArrowheadStyle = msoArrowheadTriangle End With If blnMove = True Then sS.X = sS.X + (sS.Width / 2 - pDistCol) * Cos(pDistAngle + PI) sS.Y = sS.Y + (sS.Width / 2 - pDistCol) * Sin(pDistAngle + PI) End If dS.Delete End Sub Function Angle(X As Currency, Y As Currency) Dim pHosei As Currency If Abs(X) < 0.01 Then If Y > 0 Then Angle = PI / 2 ElseIf Y < 0 Then Angle = -PI / 2 Else Angle = 0 '(;´▽｀A`` End If Else If X > 0 Then If Y >= 0 Then pHosei = 0 Else pHosei = 2 * PI Else If Y >= 0 Then pHosei = PI Else pHosei = PI End If Angle = Atn(Y / X) End If Angle = Angle + pHosei End Function
ファイルが添付できないというのはストレスですね。。
ただ，有料サービスに手を出した後，飽きたらどうするのかというのが気になって，リーズナブルな価格で提供されているとはいえ二の足を踏んでしまいます(;´▽｀A``
今は飽きずにごちゃごちゃ書いてますけど(ﾟ▽ﾟ*)
