Powerpoint VBAを使おう!

Powerpoint VBAやExcelのVBAで遊んでいます。Word VBAも始めました。

難しいなぁ(;´▽`A``

一日,斜面を玉を転がしてみてるんですが,うまくいきません。

いい加減行き当たりばったりをやめればいいんですが,きちんと考えようという頭が出てこない。

( ´Д`)=3 フゥ

今こんな感じになってしまいました。

f:id:chemiphys:20170122144001g:plain

明らかな間違いがどこかに入っているのでしょう,職業的にはお恥ずかしい限りですが,

まぁミスを含んでいて,加速しまくって飛んで行ってしまうコードを一応載せます。

( ´ー`)フゥー... 勢いよく飛んでいくのでそれは・・面白いかもしれない。

標準モジュール

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``

今は飽きずにごちゃごちゃ書いてますけど(゚▽゚*)