VBA 参照設定でライブラリを探すのが面倒なので、ライブラリを検索できる参照設定ダイアログを自作してみた

VBAの参照設定ダイアログは、大量のライブラリを目視で探していく必要があり、使い勝手が悪い。

そこで、ライブラリ名(厳密にはDescription)で検索できるような参照設定ダイアログを自分で作ってみた。

先日の記事では、とりあえずレジストリからTypeLibraryを読み込んで、根こそぎ参照設定するというところまで紹介した。
thom.hateblo.jp

今回は実際に参照設定ダイアログの作成まで対応したので紹介する。

まず完成イメージはこちら。

はじめ、リストボックス(上段)には、全てのライブラリが表示されている。
まず左上のコンボボックスから参照設定を追加したいブックを選択し、その隣のテキストボックスでライブラリを検索する。
すると、検索にヒットしたアイテムのみがリストボックス(上段)に残る。

リストボックス(上段)のアイテムをダブルクリックすると下段のリストボックスに追加され、OKボタンで参照設定が完了する。

作成方法

毎回レジストリからTypeLibrary情報を読み込んでいては遅いので、レジストリから読み込んだタイプライブラリの一覧は、このマクロを追加するブックのシート1にキャッシュする仕様にした。

まずはシート1のオブジェクト名をshTypeLibに変更しておく。

※やり方は過去記事参照
thom.hateblo.jp

そして、標準モジュール「Module1」を追加し、次のコードを張り付ける。

Option Explicit
Sub 初期設定()
    shTypeLib.Cells.Clear
    Call Ref
    Call SheetSort
End Sub

Sub Ref()
    Dim レジストリ As Object: Set レジストリ = _
        CreateObject("WbemScripting.SWbemLocator") _
            .ConnectServer(, "root\default") _
                .Get("StdRegProv")

    Const HKCR = &H80000000
    Dim TypeLibの子, TypeLibの孫, 子, 孫, 値, 値2
    Dim arr() As String
    ReDim arr(1 To 2, 1 To 1)
    Dim i As Long
    i = 1
    レジストリ.EnumKey HKCR, "TypeLib", TypeLibの子
    For Each 子 In TypeLibの子
        レジストリ.EnumKey HKCR, "TypeLib\" & 子, TypeLibの孫
        If Not IsNull(TypeLibの孫) Then
            For Each 孫 In TypeLibの孫
                レジストリ.GetStringValue HKCR, "TypeLib\" & 子 & "\" & 孫 & "\0\win32", , 値
                レジストリ.GetStringValue HKCR, "TypeLib\" & 子 & "\" & 孫, , 値2
                If (Not IsNull(値2)) And (Not IsNull(値)) Then
                    shTypeLib.Cells(i, 1) = 値2
                    shTypeLib.Cells(i, 2) = 値
                    i = i + 1
                End If
            Next
        End If
    Next
End Sub

Sub SheetSort()
    With shTypeLib.Sort
        With .SortFields
            .Clear
            .Add Key:=shTypeLib.Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        End With
        .SetRange shTypeLib.Cells(1, 1).CurrentRegion
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

次にUserForm1を追加し、各コントロールの名称を次のようにする。

ListBox1, ListBox2ともに、プロパティのColumnCountは2を設定しておく。
ComboBox1のプロパティStyleは、2に設定しておく。

UserFormに記入するコードは次のとおり。

Option Explicit
Private Sub UserForm_Initialize()
    TextBox1.Text = vbNullString
    Call ListReset
    Dim w As Workbook
    For Each w In Workbooks
        If Not w Is ThisWorkbook Then
            ComboBox1.AddItem w.Name
        End If
    Next
End Sub

Private Sub ListReset()
    ListBox1.Clear
    Dim arr() As Variant
    arr = ReadData
    Dim i As Long
    For i = LBound(arr, 1) To UBound(arr, 1)
        Me.ListBox1.AddItem arr(i, 1)
        Me.ListBox1.List(ListBox1.ListCount - 1, 1) = arr(i, 2)
    Next
End Sub

Function ReadData() As Variant
    If shTypeLib.Cells(1, 1) = "" Then
        MsgBox "データがありません。", vbExclamation, "確認"
        MsgBox "初期設定を実施します。", vbInformation, "確認"
        Module1.初期設定
    End If
    ReadData = shTypeLib.Cells(1, 1).CurrentRegion.Value
End Function

Private Sub cmdクリア_Click()
    UserForm_Initialize
End Sub

Private Sub cmd検索_Click()
    Call ListReset
    Dim i As Long
    Do While i < ListBox1.ListCount
        If InStr(1, ListBox1.List(i, 0), TextBox1.Text, vbTextCompare) = 0 Then
            ListBox1.RemoveItem (i)
        Else
            i = i + 1
        End If
    Loop
End Sub

Private Sub cmd絞込み_Click()
    Dim i As Long
    Do While i < ListBox1.ListCount
        If InStr(1, ListBox1.List(i, 0), TextBox1.Text, vbTextCompare) = 0 Then
            ListBox1.RemoveItem (i)
        Else
            i = i + 1
        End If
    Loop
End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    With ListBox1
        ListBox2.AddItem .List(.ListIndex, 0)
        ListBox2.List(ListBox2.ListCount - 1, 1) = .List(.ListIndex, 1)
    End With
End Sub

Private Sub ListBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    On Error Resume Next '未選択でWクリックした場合のエラーを無視
        ListBox2.RemoveItem ListBox2.ListIndex
    On Error GoTo 0
End Sub

Private Sub cmdOK_Click()
    With ListBox2
        If .ListCount > 0 Then
            If ComboBox1.Text <> "" Then
                Dim i As Long, cnt As Long
                For i = 0 To .ListCount - 1
                    On Error Resume Next '参照不可エラーは面倒なのでスキップ
                    Workbooks(ComboBox1.Text).VBProject.References.AddFromFile .List(i, 1)
                    If Err.Number = 0 Then cnt = cnt + 1
                    On Error GoTo 0
                Next
                MsgBox "ワークブック「" & Workbooks(ComboBox1.Text).Name & "」に" _
                    & cnt & "件の参照を追加しました。", vbInformation, "完了"
                Unload Me
            Else
                MsgBox "左上のコンボボックスで対象のブックを選択してください。", vbInformation, "エラー"
            End If
        End If
    End With
End Sub

Private Sub cmd初期設定_Click()
    MsgBox "初期設定では、レジストリからタイプライブラリの情報を読み込みます。", vbInformation, "初期設定について"
    MsgBox "初回起動時や、ソフトウェアのインストールを行った場合に実施してください。", vbInformation, "初期設定について"
    MsgBox "この操作は数秒～数十秒かかります。", vbInformation, "初期設定について"
    If vbYes = MsgBox("続行しますか。", vbInformation + vbYesNo, "確認") Then
        Call Module1.初期設定
        Call UserForm_Initialize
        MsgBox "完了しました。", vbInformation, "完了"
    Else
        MsgBox "キャンセルしました。", vbInformation, "中止"
    End If
End Sub

これでフォームを起動すれば、検索機能つきの参照設定ダイアログが使用できる。
初回起動時はシート1(shTypeLib)が空っぽなので、初期設定が実行される。
以降はそのブックを保存してしまえば初期設定する必要はない。

なお、このマクロを実行する前提として、セキュリティ設定でVBAプロジェクトオブジェクトモデルへのアクセスを信頼するにチェックをつけておく必要があるので注意。

最終的にはアドオン化してVBエディタのメニューにフォームを開くコマンドを追加したいけれど、それはまた面倒なので気が向いたらにしようと思う。

以上