VBA Withを使ったコードをWith無しのコードに変換するマクロ ～ スタックの応用 ～

今回は、Withを使ったコードをWith無しのコードに変換するマクロを作ってみる。
何の役に立つんだというツッコミはなしで。

目次

マクロの概要

変換のターゲットとするコードはこちら。

Sub hoge()
    Dim R As Range
    Set R = Selection
    With R
        .HorizontalAlignment = xlCenter
        .Value = "ABC"
        .Interior.Color = vbYellow
        With .Font
            .Color = vbRed
            .Bold = True
        End With
        With .Borders
            .LineStyle = xlContinuous
            .Color = vbBlue
        End With
    End With
End Sub

上記のコードを、マクロを使って以下のように変換する。

Sub hoge()
    Dim R As Range
    Set R = Selection
    R.HorizontalAlignment = xlCenter
    R.Value = "ABC"
    R.Interior.Color = vbYellow
    R.Font.Color = vbRed
    R.Font.Bold = True
    R.Borders.LineStyle = xlContinuous
    R.Borders.Color = vbBlue
End Sub

実現方法を検討する

さて、どう実現するのか。
まず、コードはクリップボードから読み込み、イミディエイトウインドウに出力することにしよう。
VBAでクリップボードを扱うには、「Microsoft Forms 2.0 Object Library」を参照設定する必要がある。
あるいは、ユーザーフォームを挿入すると自動で参照設定される。

とりあえず、クリップボードにコピーしたコードをそのままイミディエイトウインドウに出力するコードを書いてみた。
ポイントは改行でSplitして配列Arrに格納しているところ。

Sub とりあえず入出力()
    Dim CB As New DataObject
    CB.GetFromClipboard
    Dim Arr() As String: Arr = Split(CB.GetText, vbCrLf)
    
    Dim s
    For Each s In Arr
        Debug.Print s
    Next
End Sub

次にWithで始まる文はそのまま出力せず、オブジェクト名を保持するように変更する。
そして、ドットで始まる文の先頭にオブジェクト名を付けていけばよい。

その通りに作ってみた。

Sub Withを外す()
    Dim CB As New DataObject
    CB.GetFromClipboard
    Dim Arr() As String: Arr = Split(CB.GetText, vbCrLf)
    
    Dim s
    For Each s In Arr
        If Left(Trim(s), 4) = "With" Then
            ObjectName = Right(Trim(s), Len(Trim(s)) - 5)
        ElseIf Left(Trim(s), 1) = "." Then
            Debug.Print ObjectName & Trim(s)
        ElseIf Trim(s) = "End With" Then
            '何もしない
        Else
            Debug.Print s
        End If
    Next
End Sub

これで単体のWithならうまくいく。
ためしに以下をコピーして実行してみると、

Sub hoge()
    Dim R As Range
    Set R = Selection
    With R
        .HorizontalAlignment = xlCenter
        .Value = "ABC"
        .Interior.Color = vbYellow
    End With
End Sub

このように、Withが外れて出力される。

Trimしているためインデントが消えているが、とりあえずできている。
しかし、冒頭のターゲットコードに対して実行してみるとうまくいかない。

入れ子になったWithの扱い方

Withが入れ子になっているコードにも対応させるべく、状態遷移図を使って考えてみよう。
まずWith文の外側をNoWithと定義する。

以下は、WithやEnd Withが実行されるたびにどのように状態が変化するのかを図示したものである。
図中の「With R」は、「With Rの内部にいる状態」を表す。

1	With R	進む
2	With .Font	進む
3	End With	戻る
4	With .Borders	進む
5	End With	戻る
6	End With	戻る

このように、行って戻ってくるような構造の場合、スタックを使って処理することができる。
スタックとは、下から上にデータを積み上げていく構造で、常に一番上のデータだけを取り出すことができる。
図示すると次のとおり。

1	With R	積む
2	With .Font	積む
3	End With	降ろす
4	With .Borders	積む
5	End With	降ろす
6	End With	降ろす

VBAでスタックを実装

以前VBAでスタッククラスを作成したので、そちらを使いまわすことにした。
クラスモジュールを挿入し、オブジェクト名をStackとして以下のコードを張り付ける。

Private Items() As Variant

Property Get Count() As Integer
    Count = UBound(Items)
End Property

Property Get Top() As Variant
    Top = Items(UBound(Items))
End Property

Public Function Pop() As Variant
    If UBound(Items) > 0 Then
        Pop = Items(UBound(Items))
        ReDim Preserve Items(UBound(Items) - 1)
    Else
        Pop = Empty
    End If
End Function

Public Sub Push(ByRef x As Variant)
    ReDim Preserve Items(UBound(Items) + 1)
    Items(UBound(Items)) = x
End Sub

Private Sub Class_Initialize()
    ReDim Items(0)
End Sub

スタックに積む操作をPush、降ろす操作をPopという。また、Top命令で一番上のデータを参照することができる。

実際にサンプルを書いて見た。

Sub StackTest()
    Dim ObjectStack As New Stack
    ObjectStack.Push "R"
    Debug.Print ObjectStack.Top & ".Test1"
    ObjectStack.Push "R.Font"
    Debug.Print ObjectStack.Top & ".Test2"
    ObjectStack.Pop
    Debug.Print ObjectStack.Top & ".Test3"
    ObjectStack.Push "R.Borders"
    Debug.Print ObjectStack.Top & ".Test4"
    ObjectStack.Pop
    Debug.Print ObjectStack.Top & ".Test5"
    ObjectStack.Pop
End Sub

実行するとこのように、スタックの先頭データと".TextX"が結合されて出力される。

R.Test1
R.Font.Test2
R.Test3
R.Borders.Test4
R.Test5

スタックを使ったWithを外すコード

前項で紹介したスタックを使ってWithを外すコードを作成する。
With文が出てきたらスタックにオブジェクト名をPushし、End Withが出てきたらPopすれば良い。

完成したコードがこちら。

Sub UnWith()
    Dim CB As New DataObject
    CB.GetFromClipboard
    Dim Arr() As String: Arr = Split(CB.GetText, vbCrLf)
    Dim ObjectStack As New Stack
    
    '先に配列内の値をすべてトリムしておく
    Dim i
    For i = LBound(Arr) To UBound(Arr)
        Arr(i) = Trim(Arr(i))
    Next
    
    Dim s, ObjectName
    For Each s In Arr
        If Left(s, 4) = "With" Then
            ObjectName = Right(s, Len(s) - 5)
            If Left(ObjectName, 1) = "." Then
                ObjectStack.Push ObjectStack.Top & ObjectName
            Else
                ObjectStack.Push ObjectName
            End If
        ElseIf Left(s, 1) = "." Then
            Debug.Print ObjectStack.Top & s
        ElseIf s = "End With" Then
            ObjectStack.Pop
        Else
            Debug.Print s
        End If
    Next
End Sub

実行結果はこの通り

課題

インデントが消えてしまうのが難点だが、以前に自動でインデントを揃えるマクロを紹介したのでそれと組み合わせれば綺麗に作れそうだ。
thom.hateblo.jp

また、今回作成したUnWithマクロの課題として、ドットが文の中ほどにあるものは対応していない。
たとえば、選択されている四角いシェイプの面積を求める以下のマクロをコピーして実行すると、

Sub 四角いシェイプの面積()
    Dim S As Shape
    Set S = Selection.ShapeRange(1)
    With S
        A = .Height * .Width
    End With
    Debug.Print A
End Sub

以下のように出力される。

Sub 四角いシェイプの面積()
Dim S As Shape
Set S = Selection.ShapeRange(1)
A = .Height * .Width
Debug.Print A
End Sub

ドットの左にスペースまたは丸括弧が来るときは、親オブジェクトを挿入するなどの対処が取れそうだけれど、スペースと丸括弧以外は無いのだろうか。やるならもっと汎用的で確実な方法を採りたい。

そもそも単純変換してしまうと文字列中にあるドットにまで親オブジェクト名を挿入してしまう。

色々考慮する点はありそうだが、ステートメントの判定が複雑になりすぎる。
今は関数でごちゃごちゃやっているところも、別途ステートメントオブジェクトを作りたくなる。

今回とは逆の、With無しのコードをWith化するマクロも作ってみたいが、UnWithより難しそうなので一旦保留中である。

色々考えているうちに面倒くさくなってきたので今日はここまで。