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エディタのメニューにフォームを開くコマンドを追加したいけれど、それはまた面倒なので気が向いたらにしようと思う。
以上