thom氏のブログで面白い記事がありました。
・VBA 参照設定でライブラリを探すのが面倒なので、ライブラリを検索できる参照設定ダイアログを自作してみた – t-hom’s diary
http://thom.hateblo.jp/entry/2016/02/10/235414
VBEの参照設定ダイアログが使いづらいので自分で作ってしまおう、というお話しです。
そう、thom氏の言う通り、参照設定ダイアログは“使いづらい”です。イケてないです。
私も常々そう思っていました。
(ならもっと前から何か工夫しておこうよ・・・って話なのですが、それをやらないのが私です。)
thom氏の記事にはコードも載っていて、それを見るとUserFormに配置したListBox等のコントロールを使って、ライブラリの検索や参照を行うようです。
素晴らしい。
これは便利そう！
・・・ならばパクるしかない！！
UserFormを用意することすら面倒くさい
というわけで、私も似たような「自作参照ダイアログ」をやってみることにしたのですが、そこは不精な私、UserFormを用意してコントロールを配置することすら面倒くさい、そう感じてしまいます。
なので、下記のようにCommandBarComboBoxを使って必要最低限のUIのみで処理を実現することにしました。
・処理概要
- レジストリからTypeLib情報を取得し、XMLファイルに格納する。
- CommandBarを作成し、ComboBoxを追加する。
- XMLから読み込んだTypeLib情報をComboBoxに放り込む。
- ComboBoxで選択したライブラリを参照設定する。
アドインのコード
実際に書いたコードが下記になります。
ソートのためにRecordsetオブジェクトを使ったりしていますが、そう複雑なことはやっていません。
'ThisWorkbook
Option Explicit
Private Const XmlFileName As String = "TypeLibInfo.xml"
Private Const CbarName As String = "TypeLib"
Private Const CboCaption As String = "TypeLibBox"
Private WithEvents Btn As Office.CommandBarButton
Private Sub Workbook_Open()
Init
End Sub
Private Sub Workbook_AddinInstall()
Init
End Sub
Private Sub Workbook_AddinUninstall()
On Error Resume Next
Application.VBE.CommandBars(CbarName).Delete
On Error GoTo 0
End Sub
Private Sub Init()
Dim Cbar As Office.CommandBar
Dim Cbo As Office.CommandBarComboBox
Dim d As Object
Dim nodes As Object
Dim XmlFilePath As String
Dim i As Long
On Error Resume Next
Set Cbar = Application.VBE.CommandBars(CbarName)
If Err.Number <> 0 Then
Select Case Err.Number
Case 1004
MsgBox "[セキュリティ センターの設定]から" & vbNewLine & vbNewLine & _
"【VBA プロジェクト オブジェクト モデルへのアクセスを信頼する】" & vbNewLine & vbNewLine & _
"にチェックを入れた後、アドインを再度読み込んでください。", vbExclamation + vbSystemModal
Exit Sub
End Select
Err.Clear
End If
On Error GoTo 0
If Cbar Is Nothing Then
'コマンドバー設定
Set Cbar = Application.VBE.CommandBars.Add(Name:=CbarName, Position:=msoBarFloating)
Set Cbo = Cbar.Controls.Add(Type:=msoControlComboBox)
Cbo.Caption = CboCaption
Cbo.Width = 150
Set Btn = Cbar.Controls.Add(Type:=msoControlButton)
Btn.Caption = "参照"
Btn.Style = msoButtonCaption
'XMLファイル読込
XmlFilePath = AddPathSeparator(ThisWorkbook.Path) & XmlFileName
With CreateObject("Scripting.FileSystemObject")
If .FileExists(XmlFilePath) = False Then
CreateTypeLibXml XmlFilePath
End If
End With
Set d = CreateObject("Msxml2.DOMDocument")
If d.Load(XmlFilePath) = True Then
Set nodes = d.SelectNodes("/items/item")
For i = 0 To nodes.Length - 1
Cbo.AddItem nodes.item(i).Attributes(1).Text, i + 1
Next
End If
End If
Cbar.Visible = True
End Sub
Private Sub Btn_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
Dim d As Object
Dim XmlFilePath As String
With Application.VBE.CommandBars(CbarName).Controls(CboCaption)
If .ListIndex > 0 Then
Set d = CreateObject("Msxml2.DOMDocument")
XmlFilePath = AddPathSeparator(ThisWorkbook.Path) & XmlFileName
If d.Load(XmlFilePath) = True Then
'MsgBox d.SelectNodes("/items/item").item(.ListIndex - 1).Attributes(2).Text '確認用
On Error Resume Next
Application.VBE.ActiveVBProject.References.AddFromFile _
d.SelectNodes("/items/item").item(.ListIndex - 1).Attributes(2).Text
If Err.Number <> 0 Then
MsgBox "参照設定に失敗しました。", _
vbCritical + vbSystemModal, _
"Error No:" & Err.Number
Err.Clear
End If
On Error GoTo 0
End If
End If
End With
End Sub
Private Sub CreateTypeLibXml(ByVal XmlFilePath As String)
'TypeLib情報をXMLに格納
Dim reg As Object
Dim rs As Object
Dim d As Object
Dim item As Object
Dim items As Object
Dim names As Variant
Dim child_names As Variant
Dim lib As Variant
Dim tlb As Variant
Dim ret1 As Long, ret2 As Long
Dim i As Long, j As Long
Const adVarChar = 200
Const HKEY_CLASSES_ROOT = &H80000000
Const SubKeyName As String = "TypeLib"
'レジストリから取得したTypeLib情報をRecordsetに格納
Set reg = CreateObject("WbemScripting.SWbemLocator") _
.ConnectServer(, "root\default") _
.Get("StdRegProv")
reg.EnumKey HKEY_CLASSES_ROOT, SubKeyName, names
If Not IsNull(names) Then
Set rs = CreateObject("ADODB.Recordset")
rs.Fields.Append "GUID", adVarChar, 255
rs.Fields.Append "Name", adVarChar, 255
rs.Fields.Append "Library", adVarChar, 255
rs.Open
For i = LBound(names) To UBound(names)
reg.EnumKey HKEY_CLASSES_ROOT, SubKeyName & ChrW(92) & names(i), child_names
If Not IsNull(child_names) Then
For j = LBound(child_names) To UBound(child_names)
ret1 = reg.GetStringValue(HKEY_CLASSES_ROOT, _
SubKeyName & ChrW(92) & _
names(i) & ChrW(92) & _
child_names(j), _
"", _
lib)
ret2 = reg.GetStringValue(HKEY_CLASSES_ROOT, _
SubKeyName & ChrW(92) & _
names(i) & ChrW(92) & _
child_names(j) & ChrW(92) & _
"0" & ChrW(92) & _
"win32", _
"", _
tlb)
If (ret1 = 0) And (ret2 = 0) Then
rs.AddNew
rs.Fields("GUID").Value = names(i)
rs.Fields("Name").Value = lib
rs.Fields("Library").Value = tlb
rs.Update
End If
Next
End If
Next
rs.Sort = "Name ASC" '名前順でソート
'TypeLib情報をXMLファイルとして保存
rs.MoveFirst
Set d = CreateObject("Msxml2.DOMDocument")
Set items = d.createElement("items")
Do Until rs.EOF
Set item = d.createElement("item")
item.setAttribute "guid", rs.Fields("GUID").Value
item.setAttribute "name", rs.Fields("Name").Value
item.setAttribute "library", rs.Fields("Library").Value
items.appendChild item
Set item = Nothing
rs.MoveNext
Loop
rs.Close
d.appendChild items
On Error Resume Next
d.Save XmlFilePath
If Err.Number <> 0 Then
MsgBox "XMLファイルの保存に失敗しました。" & vbNewLine & _
XmlFilePath, vbCritical + vbSystemModal
Err.Clear
End If
On Error GoTo 0
End If
End Sub
Private Function AddPathSeparator(ByVal str As String) As String
If Right(str, 1) <> ChrW(92) Then str = str & ChrW(92)
AddPathSeparator = str
End Function
動作画面
実際にアドインを読み込んで、動作させたときの様子が下図になります。
ComboBoxとCommandButtonしかシンプルなインターフェースで、自分で使った感じでは、なかなか使いやすいです。
ダウンロード
コードは上に書いていますが、一応アドインファイルもアップしておきますので、興味がある方は試してみてください。
(「VBA プロジェクト オブジェクト モデルへのアクセスを信頼する」にチェックが入っていないと使用できませんので、その点はご注意ください。)
► ダウンロード
この記事へのコメントはありません。