図形を方程式で動かすVBAクラス
図形を決められた方程式で動かします。
もちろん、実用として何かに使うといった物ではなく、純粋にVBAやクラスの勉強素材になります。
クラスモジュールのVBA
クラスモジュール名：clsSpinAround
標準モジュールでのNewと一致させれば何でも構いません。
標準モジュールでの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
標準モジュール名は何でも構いません。
シートに「スタート」と「ストップ」を登録したボタンを2つ作ると動かしやすいと思います。
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の勉強が出来れば良いでしょうと言うくらいのものになります。
使っている主なテクニックは以下になります。
・クラスのインスタンスを配列で管理
・クラスのプロパティ（Let,Set,Get）
・多値を設定するプロパティ
・Evaluateでの計算
・図形の作成と移動
・図形の複写と削除
適当に数値を変更して動かし見ながら、VBAの細部についてはブレークポイントを設定したりして読み解いてください。
同じテーマ「VBAクラス入門」の記事
VBAクラスの作り方：列名のプロパティを自動作成する
VBAクラスの作り方：独自Rangeっぽいものを作ってみた
クラスとイベントとマルチプロセス並列処理
クラスとCallByNameとポリモーフィズム(多態性)
オートフィルターを退避回復するVBAクラス
オートフィルター退避回復クラスを複数シート対応させるVBAクラス
コレクション（Collection）の並べ替え（Sort）に対応するクラス
VBAクラスのAttributeについて（既定メンバーとFor Each）
VBAクラスを使ったイベント作成（Event,RaiseEvent,WithEvents）
VBAで音楽再生するクラスを作成
図形を方程式で動かすVBAクラス
新着記事NEW ・・・新着記事一覧を見る
TRIMRANGE関数（セル範囲をトリム：端の空白セルを除外）｜エクセル入門(2024-08-30)
正規表現関数（REGEXTEST,REGEXREPLACE,REGEXEXTRACT）｜エクセル入門(2024-07-02)
エクセルが起動しない、Excelが立ち上がらない｜エクセル雑感(2024-04-11)
ブール型（Boolean）のis変数・フラグについて｜VBA技術解説(2024-04-05)
テキストの内容によって図形を削除する｜VBA技術解説(2024-04-02)
ExcelマクロVBA入門目次｜エクセルの神髄(2024-03-20)
VBA10大躓きポイント（初心者が躓きやすいポイント）｜VBA技術解説(2024-03-05)
テンキーのスクリーンキーボード作成｜ユーザーフォーム入門(2024-02-26)
無効な前方参照か、コンパイルされていない種類への参照です。｜エクセル雑感(2024-02-17)
初級脱出10問パック｜VBA練習問題(2024-01-24)
アクセスランキング ・・・ ランキング一覧を見る
1.最終行の取得（End,Rows.Count）｜VBA入門
2.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
3.変数宣言のDimとデータ型｜VBA入門
4.繰り返し処理（For Next)｜VBA入門
5.RangeとCellsの使い方｜VBA入門
6.ブックを閉じる・保存（Close,Save,SaveAs）｜VBA入門
7.セルのクリア（Clear,ClearContents）｜VBA入門
8.メッセージボックス(MsgBox関数)｜VBA入門
9.条件分岐（Select Case）｜VBA入門
10.ブック・シートの選択（Select,Activate）｜VBA入門
このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。