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

ExcelマクロVBAの問題点と解決策、VBAの技術的解説
最終更新日:2020-02-27

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


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


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

マクロ VBA クラス

クラスモジュールの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クラス


新着記事NEW ・・・新着記事一覧を見る

ユーザーに絶対に停止させたくない場合のVBA設定|VBA技術解説(4月1日)
CharactersプロパティとCharactersオブジェクト|VBA技術解説(3月31日)
指数近似/対数近似/累乗近似(掲載順位とCTR)|エクセル関数超技(3月31日)
練習問題32(連続数値部分を取り出し記号で連結)|VBA練習問題(3月24日)
連続数値部分を取り出し記号で連結|エクセル関数超技(3月24日)
数式バーの高さを数式の行数で自動設定|VBAサンプル集(3月21日)
LET関数(数式で変数を使う)|エクセル入門(3月21日)
スピルに対応したXSPLITユーザー定義関数(文字区切り)|VBAサンプル集(3月15日)
XMATCH関数(範囲から値を検索し一致する相対位置)|エクセル入門(3月14日)
XLOOKUP関数(範囲を検索し一致する対応項目を返す)|エクセル入門(3月14日)


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

1.最終行の取得(End,Rows.Count)|VBA入門
2.RangeとCellsの使い方|VBA入門
3.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
4.マクロって何?VBAって何?|VBA入門
5.Range以外の指定方法(Cells,Rows,Columns)|VBA入門
6.変数宣言のDimとデータ型|VBA入門
7.ひらがな⇔カタカナの変換|エクセル基本操作
8.繰り返し処理(For Next)|VBA入門
9.徹底解説(VLOOKUP,MATCH,INDEX,OFFSET)|エクセル関数超技
10.セルに文字を入れるとは(Range,Value)|VBA入門




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


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



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