コードの折り畳みでミジンコのおさらい - Infomentのブログ～Excel VBA奮闘記～

一昨日は、ソースコードを折りたたむマクロを作成してみた。
infoment.hatenablog.com

しかしこれだと、折り畳み時のラベルが全部同じになってしまう。
そこで、ラベルを引数として、以下の通り改修した。

Sub 折り畳み(Optional ラベル As String = "ソースコード")
    Dim col As Collection
    Set col = New Collection
        col.Add "<div onclick=""obj=document.getElementById('oritatami_part').style; obj.display=(obj.display=='none')?'block':'none';"">"
        col.Add "<a style=""cursor:pointer;"">◆" & ラベル & "（クリックで展開）◆</a>"
        col.Add "</div>"
        col.Add "<div id=""oritatami_part"" style=""display:none;clear:both;"">"
        col.Add ">|vb|"
    
    Dim CB As DataObject
    Set CB = New DataObject
        CB.GetFromClipboard
    Dim temp As String
        temp = CB.GetText
    Dim SplitSeq As Variant
        SplitSeq = Split(temp, vbNewLine)
    Dim i As Long
        For i = LBound(SplitSeq) To UBound(SplitSeq)
            col.Add SplitSeq(i)
        Next
        col.Add "||<"
        col.Add "</div>"
        
    Dim seq As Variant
    ReDim seq(1 To col.Count)
        For i = 1 To col.Count
            seq(i) = col.Item(i)
        Next
        
        CB.SetText Join(seq, vbNewLine)
        CB.PutInClipboard
End Sub

今まで、複数回にわたって取り組んだ場合、コードがバラバラに掲載されていて、作成した本人でさえ再現に困ることがあった。
そこで過去記事の中から特に「バラバラ度」が酷いものを、折を見てまとめてみようと思う。

例えば、複数のオートシェイプをミジンコのように動かすマクロがこちら。

◆ミジンコマクロ（クリックで展開）◆

一次関数の傾きと切片を求めるクラスモジュール（LinearFunctionClass）

Option Explicit
Public CoordinateSeq As Variant

Public Property Get dx() As Double
    dx = CoordinateSeq(2)(0) - CoordinateSeq(1)(0)
End Property

Public Property Get dy() As Double
    dy = CoordinateSeq(2)(1) - CoordinateSeq(1)(1)
End Property

Public Property Get Slope() As Double
    Slope = dy / dx
End Property

Public Property Get Intercept() As Double
    Intercept = CoordinateSeq(1)(1) - Slope * CoordinateSeq(1)(0)
End Property

Public Function y(x As Double) As Double
    y = Slope * x + Intercept
End Function

オートシェイプをランダムに動かすクラスモジュール（MovingShapeClass）

Option Explicit

Private Sub Class_Initialize()
    Dim iMax As Long
        iMax = 30
        
    Dim x_start_seq() As Double: ReDim x_start_seq(1 To ShapeCount)
    Dim y_start_seq() As Double: ReDim y_start_seq(1 To ShapeCount)
    Dim x_end_seq() As Double: ReDim x_end_seq(1 To ShapeCount)
    Dim y_end_seq() As Double: ReDim y_end_seq(1 To ShapeCount)
    
    Dim i As Long
        For i = 1 To ShapeCount
            x_start_seq(i) = x_start(i)
            y_start_seq(i) = y_start(i)
            x_end_seq(i) = x_end(i)
            y_end_seq(i) = y_end(i)
        Next
    
    Dim x As Double
    Dim j As Long
        For i = 1 To iMax - 1
            For j = 1 To ShapeCount
                x = (6 * myShape(j).Left + x_end_seq(j)) / 7
                myShape(j).Left = x
                myShape(j).Top = y(x, x_start_seq(j), y_start_seq(j), x_end_seq(j), y_end_seq(j))
            Next
            Application.Wait [now()+"0:00:00.01"]
        Next
End Sub

Public Property Get ShapeCount() As Long
    ShapeCount = ActiveSheet.Shapes.Count
End Property

Public Function myShape() As Variant
    Dim i As Long
    Dim s() As Variant
    ReDim s(1 To ShapeCount)
        For i = 1 To ShapeCount
            Set s(i) = ActiveSheet.Shapes(i)
        Next
        myShape = s
End Function

Public Function x_start(shape_index As Long) As Double
    x_start = myShape(shape_index).Left
End Function

Public Function y_start(shape_index As Long) As Double
    y_start = myShape(shape_index).Top
End Function

Public Function dx(shape_index As Long) As Double
    dx = Rnd * 200 - 100
    If x_start(shape_index) >= 200 Then dx = -50
End Function

Public Function dy(shape_index As Long) As Double
    dy = Rnd * 200 - 100
    If y_start(shape_index) >= 200 Then dy = -50
End Function

Public Function x_end(shape_index As Long) As Double
    x_end = x_start(shape_index) + dx(shape_index)
End Function

Public Function y_end(shape_index As Long) As Double
    y_end = y_start(shape_index) + dy(shape_index)
End Function

Public Function y(x As Double, x_start As Double, y_start As Double, x_end As Double, y_end As Double) As Double
    Dim LFC As LinearFunctionClass
    Set LFC = New LinearFunctionClass
    
    Dim myCoordinateSeq(1 To 2) As Variant
    myCoordinateSeq(1) = Array(x_start, y_start)
    myCoordinateSeq(2) = Array(x_end, y_end)
    
    LFC.CoordinateSeq = myCoordinateSeq
    y = LFC.y(x)
End Function

テスト用マクロ（標準モジュール）

Sub MoveTest()
    Dim MSC As MovingShapeClass
    Dim i As Long
    For i = 1 To 10
        Set MSC = New MovingShapeClass
    Next
    
    Dim Shape As Shape
        For Each Shape In ActiveSheet.Shapes
            Shape.Left = 150
            Shape.Top = 150
        Next
End Sub