t-hom’s diary

主にVBAネタを扱っているブログです。

VBA 重なっているシェイプをグループ化するマクロ

今回の記事は重なりあうシェイプを自動判定してグループ化するマクロ。
といっても以前にクラスモジュールを使用してシェイプ同士が重なっているかどうかの判定までは作ってるので今回は手入れしてちゃんとグルーピング部分まで完成させたのでコードの紹介のみ。
thom.hateblo.jp

クラスモジュール

クラスモジュールを挿入し、オブジェクト名をShapeWrapperとしておく。
その名のとおり、Shapeを内包して今回のマクロ用に便利に扱う為のもの。

Private InnerShape As Shape

Public Property Get Name() As String
    Name = InnerShape.Name
End Property

Public Sub SetShape(s As Shape)
    Set InnerShape = s
End Sub

Public Property Get Top() As Single
    Top = InnerShape.Top
End Property

Public Property Get Left() As Single
    Left = InnerShape.Left
End Property

Public Property Get Bottom() As Single
    Bottom = InnerShape.Top + InnerShape.Height
End Property

Public Property Get Right() As Single
    Right = InnerShape.Left + InnerShape.Width
End Property

Public Property Get Nodes(Number As Integer) As Node
    Select Case Number
        Case 1
            Nodes.x = Me.Left
            Nodes.y = Me.Top
        Case 2
            Nodes.x = Me.Right
            Nodes.y = Me.Top
        Case 3
            Nodes.x = Me.Right
            Nodes.y = Me.Bottom
        Case 4
            Nodes.x = Me.Left
            Nodes.y = Me.Bottom
        Case Else
            Err.Raise 1000, , "1~4を指定してください。"
    End Select
End Property

Public Function IsOverlapped(SW As ShapeWrapper) As Boolean
    Dim i As Integer
    For i = 1 To 4 Step 1
        IsOverlapped = _
            (SW.Nodes(i).x > Me.Left And _
            SW.Nodes(i).x < Me.Right And _
            SW.Nodes(i).y > Me.Top And _
            SW.Nodes(i).y < Me.Bottom) _
            Or _
            (Me.Nodes(i).x > SW.Left And _
            Me.Nodes(i).x < SW.Right And _
            Me.Nodes(i).y > SW.Top And _
            Me.Nodes(i).y < SW.Bottom)
        If IsOverlapped Then Exit Function
    Next
End Function

肝となるのはIsOverlappedメソッド。これはShapeWrapper(つまり自己と同じ型のオブジェクト)を引数にとり、自分と重なっているかどうかを判定するメソッド。詳しくは冒頭で紹介した記事を参照。

標準モジュール

標準モジュールを挿入し、オブジェクト名を「Grouping」とする。ただまあ標準モジュールの命名は任意。

Public Type Node
    x As Single
    y As Single
End Type

Private Function WrappedShapes() As Collection
    'シェイプをShapeWrapperで包んでコレクションに追加
    Dim c As New Collection, s As Shape, SW1 As ShapeWrapper
    For Each s In ActiveSheet.Shapes
        Set SW1 = New ShapeWrapper
        SW1.SetShape s
        c.Add SW1, SW1.Name
    Next

    'コレクションの各シェイプ同士の重なり判定
    Dim c2 As Collection: Set c2 = New Collection
    
    Dim SW2 As ShapeWrapper
    For Each SW1 In c
        Dim arr() As Variant
        ReDim arr(0)
        arr(0) = SW1.Name
        c.Remove SW1.Name
        For Each SW2 In c
            If Not (SW1 Is SW2) Then
                If SW1.IsOverlapped(SW2) Then
                    ReDim Preserve arr(UBound(arr) + 1)
                    arr(UBound(arr)) = SW2.Name
                    c.Remove SW2.Name
                End If
            End If
        Next
        c2.Add arr
    Next
    Set WrappedShapes = c2
End Function

Private Sub RecUngroupShape(sh As Shape)
    Dim memberShape As Shape
    If sh.Type = msoGroup Then
        For Each memberShape In sh.Ungroup
            Call RecUngroupShape(memberShape)
        Next
    End If
End Sub

Public Sub GroupOverlappingShape()
    Dim SW() As Variant
    Dim c As Collection: Set c = WrappedShapes
    For i = 1 To c.Count
        SW = c(i)
        ActiveSheet.Shapes.Range(SW).Group
    Next
End Sub

Public Sub UngroupAllShapes()
    Dim sh As Shape
    For Each sh In ActiveSheet.Shapes
        Call RecUngroupShape(sh)
    Next
End Sub

色々プロシージャがあるけれどマクロとして単体実行できるのはPublicになっている最後の2つのみ。
GroupOverlappingShapeを実行すると、アクティブなシート上で重なっているシェイプがすべてグループ化される。
UngroupAllShapesを実行するとアクティブなシート上のすべてのシェイプグループが解除される。

こんな感じで、赤枠と画像の重ね合わせはグループ化しておくと便利。
f:id:t-hom:20180602120054p:plain

RecUngroupShapeとUngroupAllShapesはひとつ前の記事で紹介しており、今回の処理に必須ではないがGroupingモジュールの仲間としては相応しと思ったのでついで。

以上

VBA オートシェイプのグループを再帰的にグループ解除する。

今回は多重的にグループ化されたシェイプを全てグループ解除するマクロを紹介する。
f:id:t-hom:20180602054150p:plain

グループ化されたもの同士がさらにグループ化されていると、一度解除しても以下のようにまだ子グループが残る。
f:id:t-hom:20180602054313p:plain

もう一度解除するとようやくすべてのシェイプが分解される。
f:id:t-hom:20180602054615p:plain

これをマクロでやるには、プロシージャの再帰呼び出しを利用する。再帰とは、プロシージャ内で自分自身のプロシージャを呼び出すこと。

メインの再帰部分はこちら。
※単体では使えない。

Sub RecUngroupShape(sh As Shape)
    Dim memberShape As Shape
    If sh.Type = msoGroup Then
        For Each memberShape In sh.Ungroup
            Call RecUngroupShape(memberShape)
        Next
    End If
End Sub

RecUngroupShapeはシェイプを受け取るとグループかどうかを判定し、グループだったらUngroupメソッドを実行する。
UngroupメソッドはShapeRangeを返す。
ShapeRangeをFor Eachで回すとmemberShape変数に各シェイプが入る。
このmemberShape変数を引数としてさらに自分自身を呼び出す。

このRecUngroupShapeを呼び出すためのマクロがこちら。

Sub hoge()
    Dim sh As Shape
    For Each sh In ActiveSheet.Shapes
        Call RecUngroupShape(sh)
    Next
End Sub

今回はActiveSheetの全シェイプをグループ解除してみた。
もちろんも、特定のシェイプグループを渡すことも可能。

再帰についてよくわからなければ、以下の記事で仕組みを説明してるのでどうぞ。
thom.hateblo.jp

最近そういえば、再帰プロシージャはRec~という接頭辞をよく付ける。
どこかで見て気に入ってるからだけどRecursive(再帰的)の略で、プログラマーにはRecが浸透してるイメージがあるけど、省略せずにRecursiveと書いたほうが良いか悩む。

VBA Excelのウィンドウを最前面に出してから、元の重ね順に戻す方法

今回はExcelのウィンドウを1秒ほど最前面に出してから、元の重ね順に戻すマクロを紹介。
マクロというか、ほとんどAPI処理になってしまった。

何がしたかったかというと、以前作成したスクリーンショット自動貼り付けマクロ(以下)において、貼り付けがうまくいったか確認するために一瞬Excelを最前面に表示させたかった。
thom.hateblo.jp

SetForegroundWindowを使えば楽勝だと思ってたんだけれど、手元の環境で上手く動かない。
プロセスのアタッチ・デタッチとか色々やってみたけどダメ。Excelアイコンが明滅するだけで切り替わらないケースが出てきた。

そこでSetForegroundWindowは諦めてSetWindowPosによる最前面表示を使ってみたところ、イメージした操作ができたので紹介する。

まず宣言部のコード。

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetForegroundWindow Lib "user32" () As Long

Private Declare Function SetWindowPos Lib "user32" ( _
    ByVal hwnd As Long, _
    ByVal hWndInsertAfter As Long, _
    ByVal X As Long, _
    ByVal Y As Long, _
    ByVal cx As Long, _
    ByVal cy As Long, _
    ByVal uFlags As Long _
    ) As Long
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2

Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Const GW_HWNDPREV = 3

Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, ByRef lpdwProcessId As Long) As Long

API関数を5つも使用するハメに。。

それからプロシージャを2つ貼り付けて完了。

Private Sub PopUpWindow()
    '最前面ウィンドウのハンドルをfgw変数に保管
    Dim fgw As Long: fgw = GetForegroundWindow
    
    'Excelよりひとつ手前にあるウインドウのハンドルをbaseWindow変数に保管
    Dim baseWindow As Long: baseWindow = PrevWindow
    
    'Excelを最前面に設定(常に最前面に設定して強制的に最前面に移動させてから、「常に」を外す)
    Call SetWindowPos(Application.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
    Call SetWindowPos(Application.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
    
    DoEvents
    Sleep 1000
    
    'ExcelをbaseWindowの下に戻す
    Call SetWindowPos(Application.hwnd, baseWindow, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
    
    'fgwを最前面に戻す
    Call SetWindowPos(fgw, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
    Call SetWindowPos(fgw, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
End Sub

Private Property Get PrevWindow() As Long
    'return用変数retにExcelのウィンドウハンドルを格納
    Dim ret As Long: ret = Application.hwnd
    
    'Excelは複数のウィンドウで構成されるので、
    '別プロセスになるまで手前へ手前へとretにハンドルを格納しつづける。
    '例えばExcelのひとつ手前にメモ帳が表示されていても、
    '単にGetWindow(Application.hwnd, GW_HWNDPREV)と書くだけではまだExcelの内部ウィンドウがヒットしてしまうので、
    '別プロセスが現れるまでループさせる必要がある。
    Do While GetWindowThreadProcessId(Application.hwnd, 0) = GetWindowThreadProcessId(ret, 0)
        ret = GetWindow(ret, GW_HWNDPREV)
    Loop

    PrevWindow = ret
End Property

ウィンドウハンドルとはウィンドウを識別するためのIDで、実体は整数である。

PopUpWindowを呼び出すと、約1秒間Excelが最前面になり、それから元の位置に戻る。
PopUpWindowはPublicにして他モジュールから呼べるようにしても良い。

APIを使ったので紹介がてらコメントを書いているけれど、手元のコードにはほとんどコメントは入れてない。
 本来コードがやってることをコメントでそのまま書くのは冗長なので。
 ただしPrevWindowの長いコメントは意図を補完しているので残しておこうと思う。

以上

VBA 税法条文のカッコ書き部分にオリジナルの書式を適用する。

TwitterVBA検索してたら面白そうなネタがあったので乗っかり。

税法のカッコ書きの部分にオリジナルの書式を適用するマクロが作りたい様子。

ふむふむと思って調べてみた。

十 同族会社 会社(投資法人を含む。以下この号において同じ。)の株主等(その会社が自己の株式(投資信託及び投資法人に関する法律(昭和二十六年法律第百九十八号)第二条第十四項(定義)に規定する投資口を含む。以下同じ。)又は出資を有する場合のその会社を除く。)の三人以下並びにこれらと政令で定める特殊の関係のある個人及び法人がその会社の発行済株式又は出資(その会社が有する自己の株式又は出資を除く。)の総数又は総額の百分の五十を超える数又は金額の株式又は出資を有する場合その他政令で定める場合におけるその会社をいう。

…お前はLISPかっ。

カッコのネスト深すぎだろう。

ということで、こんな風にネストレベルごとに色分けできるマクロを作ってみた。
f:id:t-hom:20180529191650p:plain

作り方

クラスモジュール

クラスモジュールを挿入し、プロパティウィンドウからオブジェクト名をColorfulStringObjectに変更する。

ColorfulStringObjectのコードはこちら。

Private Type ColorText
    TextPart As String
    ColorPart As XlRgbColor
End Type
Private colorTextArray() As ColorText

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

Sub AddText(txt As String, Optional col As XlRgbColor = rgbBlack)
    colorTextArray(UBound(colorTextArray)).ColorPart = col
    colorTextArray(UBound(colorTextArray)).TextPart = txt
    ReDim Preserve colorTextArray(UBound(colorTextArray) + 1)
End Sub

Function GetText()
    Dim ret As String
    Dim i As Long
    For i = 0 To UBound(colorTextArray) - 1
        ret = ret & colorTextArray(i).TextPart
    Next
    GetText = ret
End Function

Sub WriteToCell(r As Range)
    r.Value = GetText
    Dim location As Long: location = 1
    For i = 0 To UBound(colorTextArray) - 1
        r.Characters(location, Len(colorTextArray(i).TextPart)) _
            .Font.color = colorTextArray(i).ColorPart
        location = location + Len(colorTextArray(i).TextPart)
    Next
End Sub

標準モジュール

標準モジュールに次のコードを張り付ける。

Function RandomColor() As Long
    Dim r As Byte, g As Byte, b As Byte
    r = WorksheetFunction.RandBetween(0, 255)
    g = WorksheetFunction.RandBetween(0, 255)
    b = WorksheetFunction.RandBetween(0, 255)
    RandomColor = RGB(r, g, b)
End Function

↑カラー設計が面倒なので今回はランダムな色を扱えるように適当な色を返す関数を準備した。

次に、同じ標準モジュールに次のコードを張り付ける。

Sub DrawTheTextOfLawWithColor()
    Const MAX_NEST_DEPTH = 10
    
    '適当に10色追加。実行の度にパレットが変わるので、
    '安定させたくば個別にコレクションに色をAddすべし。
    Dim colorPalette As Collection: Set colorPalette = New Collection
    Dim i As Long
    For i = 1 To MAX_NEST_DEPTH
        colorPalette.Add RandomColor
    Next
    
    '条文はB2セルに書く前提。サンプルなのでゴリゴリハードコーディング。
    Dim targetText As String
    targetText = ThisWorkbook.Worksheets("Sheet1").Range("b2").Value
    
    Dim colorfulString As ColorfulStringObject
    Set colorfulString = New ColorfulStringObject
    Dim j As Long
    
    Dim nestDepth As Long: nestDepth = 1
    
    For j = 1 To Len(targetText)
        Dim ch As String: ch = Mid(targetText, j, 1)
        Dim token As String
        Select Case ch
        Case "("
            colorfulString.AddText token, colorPalette(nestDepth)
            token = ""
            colorfulString.AddText ch
            nestDepth = nestDepth + 1
        Case ")"
            colorfulString.AddText token, colorPalette(nestDepth)
            token = ""
            colorfulString.AddText ch
            nestDepth = nestDepth - 1
        Case Else
            token = token & ch
        End Select
    Next
    colorfulString.AddText token, colorPalette(nestDepth)
    
    colorfulString.WriteToCell ThisWorkbook.Worksheets("Sheet1").Range("B3")
End Sub

Sheet1のB2から条文を読み取って、Sheet1のB3に色付きで出力させるマクロ完成。
何色になるかは神のみぞ知る。

解説 (5/30追記)

ColorfulStringObjectについて

基本的に他人が作ったクラスは使い方さえ分かれば内部動作に気を配る必要はなく、ソースコードを詳細に読む必要もない。
ということで、ColorfulStringObjectは使い方に絞って説明する。

ColorfulStringObjectは3つのメソッドを持つオブジェクトである。
f:id:t-hom:20180530012406p:plain

このうち基本的にはAddTextとWriteToCellを使用する。
サンプルコードはこちら。

Sub HowToUse()
    'オブジェクト使用のための準備
    Dim cso As ColorfulStringObject
    Set cso = New ColorfulStringObject
    
    'オブジェクトにテキストを蓄積
    cso.AddText "ABC", vbRed
    cso.AddText "DEF", vbGreen
    cso.AddText "GHI", vbBlue
    
    'セルに出力
    cso.WriteToCell Range("A1")
End Sub

AddTextメソッドの引数にテキストと色情報を渡すと、次のように内部データ領域に蓄積され、WriteToCellでセルに出力される。
f:id:t-hom:20180530014713p:plain
※AddTextで色を省略すると黒色になります。

標準モジュールのDrawTheTextOfLawWithColorについて

まずはカラーパレットを用意するコードから。

    Dim colorPalette As Collection: Set colorPalette = New Collection
    Dim i As Long
    For i = 1 To MAX_NEST_DEPTH
        colorPalette.Add RandomColor
    Next

今回はMAX_NEST_DEPTHを10と定義したので、ランダムで10色作成してコレクションに入れた。
完成したコレクションのイメージはこんな感じ↓
f:id:t-hom:20180530015635p:plain

次に、色付けするテキストをtargetText変数に入れる。

    Dim targetText As String
    targetText = ThisWorkbook.Worksheets("Sheet1").Range("b2").Value

次に、ColorfulStringObjectの準備。

    Dim colorfulString As ColorfulStringObject
    Set colorfulString = New ColorfulStringObject

次にネストの深さを示す変数nestDepthを1にしておく。

    Dim nestDepth As Long: nestDepth = 1

このnestDepthは"("が見つかると増え、")"が見つかると減る仕組み。
たとえばtargetTextが“あああ(いいい(うう)ええ)お”だとすると、それぞれの文字読み込み時点のnestDepthは次のようになる。
f:id:t-hom:20180530020925p:plain

nestDepthの値は、最初に作ったカラーパレットコレクションのインデックスと対応して色を決めている。
f:id:t-hom:20180530020641p:plain

今説明したことを行うコードがこちら。

    For j = 1 To Len(targetText)
        Dim ch As String: ch = Mid(targetText, j, 1)
        Dim token As String
        Select Case ch
        Case "("
            colorfulString.AddText token, colorPalette(nestDepth)
            token = ""
            colorfulString.AddText ch
            nestDepth = nestDepth + 1
        Case ")"
            colorfulString.AddText token, colorPalette(nestDepth)
            token = ""
            colorfulString.AddText ch
            nestDepth = nestDepth - 1
        Case Else
            token = token & ch
        End Select
    Next
    colorfulString.AddText token, colorPalette(nestDepth)

これをざくっと日本語に置き換えるとこんな感じ↓

    For j = 1 To targetTextの文字数まで
        変数chに1文字いれる。
        Select Case ch
        Case "("
            colofulStringにtokenを追加し、
            tokenをクリアしてから、
            colofulStringに"("を追加する。
            そして、nestDepthを増やす。
        Case ")"
            colofulStringにtokenを追加し、
            tokenをクリアしてから、
            colofulStringに")"を追加する。
            そして、nestDepthを減らす。
        Case Else
            変数tokenに文字を継ぎ足す。
        End Select
    Next
    ループ終了後にcolofulStringに未追加のtokenを追加する。

※For文の中に変数宣言があるけどこれは気にしない。宣言は1回しか処理されないので外に書いても中に書いても同じ。

あとは、セルに出力するだけ。

    colorfulString.WriteToCell ThisWorkbook.Worksheets("Sheet1").Range("B3")

以上。

参考:過去に書いたColorfulStringObjectの記事

thom.hateblo.jp

VBA SubとFunctionとPropertyの使い分け

VBAには3種類のプロシージャがある。SubとFunctionとPropertyだ。
しかしその守備範囲はキッチリ線引きされているわけではなく、使い分けに困る場面がある。

今回はその使い分けのヒントとなる考え方を紹介する。

なお、3種類と書いたがProperty にはLet・Set・Getがあるので実際には5種類になる。
このうちLetとSetはいずれも値を設定するという目的が同じなのでひとまとめに扱うことにする。

私がプロシージャを使い分ける際に考えていることを以下2つの表にまとめた。
f:id:t-hom:20180527212534p:plain

表が2つあるのは、何のためのプロシージャか(What)と、どのようなプロシージャか(How)の2つの観点で考える為。

What表の解説

単純な手続き

単純な手続きとは、いわゆる「マクロ」など、単純に手続きとしてのプロシージャを指す。

純粋な関数

純粋な関数とは、手続きの外で状態の変更を引き起こさず、ユーザーとの対話用ダイアログが表示されず、与えられた引数によってのみ戻り値が決まる普通の関数のこと。
たとえばLeft関数やFormat関数などが純粋関数である。

逆に「純粋でない」とは、セルの値を変更したり、参照渡しされた引数の中身を変更してしまったりといった状態の変更を引き起こすものや、現在時刻の取得など、システムの状態を取得するもの、ユーザーにメッセージを表示させたり選択肢を表示させたりといった副作用を伴う処理を含むことをいう。

状態の取得

状態とはプロシージャの外で設定されたあらゆる値を指す。
例えばVBAのNow関数はシステムから日時を取得するという意味で状態の取得にあたる。
実際、VBAのNow関数はProperty Getプロシージャで作られている。

状態の設定

状態の取得と逆にプロシージャの外に働きかけて値を変更することを指す。

How表の解説

重い処理

DBへのアクセス、Webからのデータ取得、広いセル範囲への個別アクセスなどある程度負荷が想定される処理を指す。

軽い処理

プロシージャ自体が単純で短く、連続で実行されてもそれほど負荷がかからない処理を指す。

破壊的処理

状態の変更を引き起こす処理を指す。
What表に書いた「状態の変更」は、まさに状態の変更を目的としたものであるが、ここでいう破壊的処理は主目的かどうかを問わず何らかの状態の変更が行われてしまう処理を指す。
たとえばWhat表に書いた「単純な手続き」は多くの場合はセルへの書き込み等の破壊的処理を含むことになる。

これは耳慣れない言葉だと思うが、私はRubyの学習でこの言葉を知った。
破壊的という言葉の響きは何か悪いものを連想させるかもしれないが、全くそういった意味は無い。
大抵の状態変更は意図された正当なものであるが、一律「破壊的」と呼ばれる。

非破壊的処理

プロシージャ外部の状態変更を引き起こさない処理を指す。単純に状態の参照だけならそれは非破壊的処理である。
代表的なものにプロパティの参照や関数がある。

対話的処理

ユーザーに対してダイアログやフォームを表示させる処理をいう。
MsgBoxやInputBoxはFunctionで作られているが対話的処理の代表である。
個人的にはFunctionは純粋な関数に使用されてほしいが、Subで値の取得をするというのも微妙だしProperty Getに対話的処理を入れるなどもってのほかだと考えているので、値を返す対話的処理の場合は妥協してFunctionを使う。

プロシージャで複数の戻り値を扱えないことに対する代替手段

FunctionやProperty Getは単一の戻り値しか返せない。
そこで代替手段として引数を参照渡しにしておき、戻り値の代わりとするテクニックがよく用いられる。
これはこれで否定しないけれど、もしその複数の値が互いに関連するものだった場合は以下のいずれかの手段を採った方がデータの扱いが楽だ。

  • クラスモジュールでオブジェクト設計し、そのオブジェクトを返す。
  • コレクションに格納して返す。
  • 配列に格納して返す。

これらの方法では複数データを単一の戻り値として扱えるのでFunctionやProperty Getを使った非破壊的な処理が実現できる。
つまり複数値を扱いたいがために、表で紹介した原則を曲げるという必要がなくなる。

おわりに

今回紹介したように、プロシージャの使い分けに関して私は一応の指針を持っている。
ただ実際にはそれでもよく迷う。たとえば「状態の取得でかつ、重たい処理」をFunctionとProperty Getのどちらで実装しようか等。
連続で何度も呼び出されるならパフォーマンスに影響しかねないのでHowを優先してFunctionで作る。めったに参照されないならそこまでパフォーマンスに影響ないのでWhatを優先してProperty Getで作るなど。

また、表で×にしたものは、やめておいたほうが良いという私の意見であるが、やろうと思えばできてしまうし、どうしても×のものを選択した方が良いというケースもあるかもしれない。

プログラムが正常に動作する以上、絶対にダメということは無い。最終的にはケースバイケース。自分の頭で悩み・決断を繰り返すうちにコーディングスタイルが磨かれるはず。

VBA Publicなプロシージャをマクロの実行メニューから隠す方法

ユーザーに実行させたくないマクロを「マクロの実行」メニューから隠す方法として最も簡便なのはプロシージャをPrivateにしてしまうことだ。
しかしマクロがある程度大きくなると、複数のモジュールにプロシージャを分散させたい場合がある。

他モジュールから呼び出すためには、Publicにする必要があるが、単にPublicにするとマクロの実行メニューにも見えてしまう。

今回はこのジレンマを解消する方法を紹介する。

まず、引数があるプロシージャはたとえPublicでもマクロの実行メニューに表示されない。
引数を使わない場合はどうすれば良いかというと、Optionalで適当なダミー引数を設定してしまえば良い。

標準モジュールを作って以下のコードを挿入する。

Public Sub HiddenProcedure(Optional void = Empty)
    MsgBox "このプロシージャはマクロの実行メニューには表示とされません。"
End Sub

Public Sub Main()
    Call HiddenProcedure
End Sub

HiddenProcedureプロシージャは引数があるので単体では実行できなくなり、Mainからだと普通に呼び出せる。
また、Publicなので他プロシージャからの呼び出しも可能。

以前はdummyという名称の仮引数を作って実際に1とか0とかの実引数を渡していたんだけど、単にOptionalで良いことに気付いたので今回記事にした。
今回のvoidはC言語のキーワードから英単語を拝借した。

Cでは引数をとらない場合にキーワードvoidを指定する。

#include <stdio.h>
int main(void){
    printf("Hello, World!\n");
    return 0;
}

初期値は何でも良いので最初は0とか""とかにしていたけれど、VBAのキーワードEmptyが最も意図をよく表していることを発見して置き換えた。

ちなみにSubの代わりにFunctionを用いれば引数をつけなくてもマクロメニューから隠すことはできる。
しかしFunctionの主目的は値を返すことだから、私の場合、値を返さない純粋な手続きの場合はSubで作る。

追記

Twitterでimihitoさんに情報もらったので追記。
モジュールの先頭に「Option Private Module」を記述するとそのモジュールのマクロは見えなくなるとのこと。
実際やってみると、マクロメニューからは隠れ、他モジュールからの呼び出しは成功した。素晴らしい!

Static変数を利用してステータスバーに文字をスクロールさせる。

今回はExcelのステータスバーに電光掲示板のように文字をスクロールさせるマクロを紹介。
もともと作りたかった案件とは違うが、そちらが失敗して副産物として単体で何か使えそうな気がしたので簡単にメモ。

矢印の方向に文字が流れる。
f:id:t-hom:20180527132653p:plain

コード

※Mainプロシージャを起動すると無限ループになるので止め方をご存知の方のみ実行してください。

#If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
#End If

Sub Main()
    Do
        Application.StatusBar = RotateString("ただいまマクロを実行しています。しばらくお待ちください。", " ")
        DoEvents
        Sleep 100
    Loop
End Sub

Private Function RotateString(cap As String, pad As String)
    Dim paddedString As String
    paddedString = String(Len(cap), pad) & cap & String(Len(cap), pad)
    Static i As Long
    If Len(cap) * 2 > i Then
        i = i + 1
    Else
        i = 1
    End If
    RotateString = Mid(paddedString, i, Len(cap))
End Function

解説

RotateString関数のStatic変数 i がポイント。
Staticで宣言した変数はプロシージャが終了しても値が保持されるので、このように呼び出すたびに違う値を返す関数を作るのに便利だ。

Staticを使いこなすコツは、「明示的に初期化しない」こと。

たとえば以下の箇所は、宣言された後、値が代入される前にIf文の判定でiを参照している。

    Static i As Long
    If Len(cap) * 2 > i Then
        i = i + 1
    Else
        i = 1
    End If

Long型で宣言したなら初期値は0なので、初回の呼び出し時にiは0である。
2度目の呼び出し時には、iは前回の呼び出しの終了時点の値をキープしている。

もし以下のように0で初期化する処理を挟んでしまうと何度呼び出しても0が入ってしまい、Staticにした意味がなくなる。

    Static i As Long
    i = 0
    If Len(cap) * 2 > i Then
        i = i + 1
    Else
        i = 1
    End If

明示的に代入する前に参照させるのがStaticを使いこなすコツだ。
これは慣れるまでなんとなく気持ち悪いかもしれないが、そういうものだと割り切るしかない。

関数のおおまかな処理

(1) まず、引き渡された文字列に、それと同じ長さの詰め物を両サイドに敷き詰める。
詰め物 & "サンプル" & 詰め物
      ↓こうなる
"□□□□サンプル□□□□"

(2) iが文字列の長さの2倍未満なら、iを増分させる。
初回は0なので、iが1になる。

(3) iの値の位置から元の文字列と同じ長さを切り出す。
"□□□□"となる。

2回目の実行ではiが増えているので、"□□□サ"、3回目は"□□サン"という風に、切り出す位置を変えているだけ。

以上

当ブログは、amazon.co.jpを宣伝しリンクすることによってサイトが紹介料を獲得できる手段を提供することを目的に設定されたアフィリエイト宣伝プログラムである、 Amazonアソシエイト・プログラムの参加者です。