図形を方程式で動かすVBAクラス

最終更新日：2020-02-27

図形を方程式で動かすVBAクラス

図形を決められた方程式で動かします。
もちろん、実用として何かに使うといった物ではなく、純粋にVBAやクラスの勉強素材になります。

以下では、小さい●を円の方程式や8の字の方程式で動かしています。

クラスモジュールのVBA

クラスモジュール名：clsSpinAround
標準モジュールでのNewと一致させれば何でも構いません。


  
    
      Option Explicit


Private pSheet As Worksheet

Private pName As String

Private pPosition As Double

Private pRadius As Double

Private pStep As String

Private pLocus As Double

Private pXFormula As String

Private pYFormula As String


Private pShape As Shape

Private pDupFlg As Boolean

Private pAngle As Double


Public Property Set Sheet(ByVal aSheet As Worksheet)

　　Set pSheet = aSheet

End Property

Public Property Get Sheet()

　　Set Sheet = pSheet

End Property


Public Property Let ShapeName(ByVal aPosition As Variant, _

　　　　　　　　　　　　　　　ByVal aRadius As Variant, _

　　　　　　　　　　　　　　　ByVal aStep As Variant, _

　　　　　　　　　　　　　　　ByVal aLocus As Variant, _

　　　　　　　　　　　　　　　ByVal aName As Variant)

　　pPosition = aPosition

　　pRadius = aRadius

　　pStep = aStep

　　pLocus = aLocus

　　pName = aName

End Property


Public Sub Formula(ByVal x As String, ByVal y As String)

　　pXFormula = x

　　pYFormula = y

End Sub


Private Sub Class_Initialize()

　　pDupFlg = 0

　　pRadius = 0

　　pAngle = 0

End Sub


Private Sub Class_Terminate()

　　Dim tmp As Shape

　　For Each tmp In pSheet.Shapes

　　　　If tmp.Name Like pName & "*" Then

　　　　　　tmp.Delete

　　　　End If

　　Next

End Sub


Public Sub StepAngle()

　　Dim θ As Double, x As Double, y As Double

　　Dim strFormula As String

　　

　　If pShape Is Nothing Then

　　　　Call CreateShape

　　End If

　　

　　θ = WorksheetFunction.Radians(pAngle)

      　　x = Evaluate(createFormula(pXFormula, pRadius, θ))

　　y = Evaluate(createFormula(pYFormula, pRadius, θ))

　　Call ShapePosition(pShape, x, y)

　　

　　If pDupFlg Then

　　　　Call delDupliocate(pShape)

　　Else

　　　　Call addDupliocate(pShape, pAngle)

　　End If

　　pAngle = pAngle + pStep

　　

　　If pAngle > 360 Then

　　　　pAngle = 0

　　　　pDupFlg = Not pDupFlg

　　End If

　　

　　DoEvents

End Sub


Public Sub CreateShape()

      　　Set pShape = pSheet.Shapes.AddShape(msoShapeOval, _

　　　　　　　　　　0, _

　　　　　　　　　　0, _

　　　　　　　　　　Application.CentimetersToPoints(0.1), _

　　　　　　　　　　Application.CentimetersToPoints(0.1))

　　pShape.Name = pName

End Sub


Private Sub ShapePosition(ByVal sp As Shape, x As Double, y As Double)

　　sp.Left = x + pPosition

　　sp.Top = y + pPosition

End Sub


Private Function addDupliocate(ByVal sp As Shape, i As Double) As Shape

　　Dim tmp As Shape

　　If i * 10 Mod pLocus = 0 Then

      　　　　Set tmp = sp.Duplicate

　　　　tmp.Name = sp.Name & "_tmp"

　　　　tmp.Left = sp.Left

　　　　tmp.Top = sp.Top

　　　　Set addDupliocate = tmp

　　End If

End Function


Private Function delDupliocate(ByVal sp As Shape) As Double

　　Dim tmp As Shape

　　For Each tmp In pSheet.Shapes

　　　　If tmp.Name = sp.Name & "_tmp" Then

　　　　　　If tmp.Top >= sp.Top - 1 And _

　　　　　　　 tmp.Left >= sp.Left - 1 And _

　　　　　　　 tmp.Top <= sp.Top + 1 And _

　　　　　　　 tmp.Left <= sp.Left + 1 Then

　　　　　　　　tmp.Delete

　　　　　　　　delDupliocate = True

　　　　　　　　Exit Function

　　　　　　End If

　　　　End If

　　Next

　　delDupliocate = False

End Function


Private Function createFormula(ByVal aFormula As String, _

　　　　　　　　　　　　　　　 ByVal aRadius As Double, _

　　　　　　　　　　　　　　　 ByVal aθ As Double) As String

　　Dim sFormula As String

　　sFormula = Replace(aFormula, "{r}", aRadius)

　　createFormula = Replace(sFormula, "{θ}", aθ)

      End Function

標準モジュールのVBA

標準モジュール名は何でも構いません。


  
    
      Option Explicit


Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)


Private isStop As Boolean

Private clsAry() As clsSpinAround


Sub スタート()

　　ReDim clsAry(2)

　　Dim ix As Long

　　For ix = LBound(clsAry) To UBound(clsAry)

　　　　Set clsAry(ix) = New clsSpinAround

　　　　Set clsAry(ix).Sheet = ActiveSheet

　　　　Select Case ix

　　　　　　Case 0

　　　　　　　　clsAry(ix).ShapeName(200, 132, 2, 50) = "点" & ix

　　　　　　　　Call clsAry(ix).Formula("{r} * Cos({θ})", _

　　　　　　　　　　　　　　　　　　　　"{r} * Sin({θ})")

　　　　　　Case 1

　　　　　　　　clsAry(ix).ShapeName(200, 100, 1, 50) = "点" & ix

　　　　　　　　Call clsAry(ix).Formula("{r} * Sin({θ})", _

　　　　　　　　　　　　　　　　　　　　"{r} * Sin(2 * {θ})")

　　　　　　Case 2

　　　　　　　　clsAry(ix).ShapeName(200, 100, 1, 50) = "点" & ix

　　　　　　　　Call clsAry(ix).Formula("{r} * Sin(2 * {θ})", _

　　　　　　　　　　　　　　　　　　　　"{r} * Sin({θ})")

　　　　End Select

　　Next

　　

　　Application.Cursor = xlWait

　　Sleep 100 '開始時をスムーズにすめため

　　isStop = False

　　Call OnTimeProc

End Sub


Sub ストップ()

　　isStop = True

　　Erase clsAry

　　Application.Cursor = xlDefault

End Sub


Sub OnTimeProc()

　　If isStop Then

　　　　Erase clsAry

　　　　Exit Sub

　　End If

　　

　　On Error Resume Next

　　Dim i As Long

　　For i = LBound(clsAry) To UBound(clsAry)

　　　　clsAry(i).StepAngle

　　Next

　　If Err Then Exit Sub

　　

　　Sleep 10 '適当に入れたほうが滑らかに動く

      　　Application.OnTime Now(), "OnTimeProc"

      End Sub

シートに「スタート」と「ストップ」を登録したボタンを2つ作ると動かしやすいと思います。

図形を方程式で動かすVBAの解説

最初に書きましたが、このVBAは全く実用性はなく、純粋にVBAの学習素材としてお考え下さい。
多少なりとも楽しみながらVBAの勉強が出来れば良いでしょうと言うくらいのものになります。

目的があって動かすものではないので細かい解説は省略します。
使っている主なテクニックは以下になります。

・Application.OnTimeの使い方
・クラスのインスタンスを配列で管理
・クラスのプロパティ（Let,Set,Get）
・多値を設定するプロパティ
・Evaluateでの計算
・図形の作成と移動
・図形の複写と削除

このあたりを注意してVBAを読んでみてください。
適当に数値を変更して動かし見ながら、VBAの細部についてはブレークポイントを設定したりして読み解いてください。

同じテーマ「VBAクラス入門」の記事

VBAクラスの作り方：列名のプロパティを自動作成する
 VBAクラスの作り方：独自Rangeっぽいものを作ってみた
 クラスとイベントとマルチプロセス並列処理
 クラスとCallByNameとポリモーフィズム(多態性)
オートフィルターを退避回復するVBAクラス
 オートフィルター退避回復クラスを複数シート対応させるVBAクラス
 コレクション（Collection）の並べ替え（Sort）に対応するクラス
 VBAクラスのAttributeについて（既定メンバーとFor Each）
VBAクラスを使ったイベント作成（Event,RaiseEvent,WithEvents）
VBAで音楽再生するクラスを作成
図形を方程式で動かすVBAクラス

アクセスランキング・・・ランキング一覧を見る

1.最終行の取得（End,Rows.Count）｜VBA入門
2.RangeとCellsの使い方｜VBA入門
3.変数宣言のDimとデータ型｜VBA入門
4.繰り返し処理（For Next)｜VBA入門
5.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
6.マクロって何？VBAって何？｜VBA入門
7.並べ替え（Sort）｜VBA入門
8.Excelショートカットキー一覧｜Excelリファレンス
9.エクセルVBAでのシート指定方法｜VBA技術解説
10.Range以外の指定方法（Cells,Rows,Columns）｜VBA入門

ホーム
マクロVBA応用編
VBAクラス入門
図形を方程式で動かすVBAクラス

このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。

記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。

VBA技術解説
図形を方程式で動かすVBAクラス