参照設定の一覧を作るExcelマクロ

これは

参照設定の一覧を作るExcelマクロです。

• 現在表示中のブックに設定済みの参照設定
• （設定していないものも含む）全ての参照設定

の２種類を作りました。（使い道は、よく分かりません。）

処理結果イメージ

• 設定中のみ
  

• 全て
  

コード

Option Explicit

'* Microsoft Scripting Runtime
'* Microsoft WMI Scripting
'* Microsoft Visual Basic for Applications Extensibility

Dim mWbO As WbemScripting.SWbemObjectEx

Function F() As Excel.WorksheetFunction
    Set F = Excel.WorksheetFunction
End Function

Sub 一覧1()       '全ての参照設定を一覧出力
    Dim dic As Scripting.Dictionary
    Set dic = AllRefs()     '全ての参照設定
    一覧出力 dic
End Sub

Sub 一覧2()       'Bookに設定した参照設定を一覧出力
    Dim dic As Scripting.Dictionary
    Set dic = RefsInBook(Excel.ActiveWorkbook)  'ActiveWorkbookの参照設定
    一覧出力 dic
End Sub

Private Sub 一覧出力(dic As Scripting.Dictionary)
    Dim arr, rng As Excel.Range
    With dic
        arr = F.Transpose(F.Transpose(.Items))
        Set rng = Excel.Workbooks.Add.Worksheets(1).Cells.Resize(UBound(arr, 1), UBound(arr, 2))
    End With
    With rng
        .Value = arr
        .Worksheet.ListObjects.Add xlSrcRange, rng
        .EntireColumn.AutoFit
    End With
End Sub

' 「全ての参照設定」の辞書を作る

Function AllRefs() As Scripting.Dictionary
	Const TYPE_LIB = "TypeLib"
    Dim wName, wVer, wGUID, wMajor, wMinor, wArr

    Set AllRefs = CreateObject("Scripting.Dictionary")
    
    With AllRefs
		For Each wGUID In EnumKey(TYPE_LIB)
			For Each wVer In EnumKey(TYPE_LIB, wGUID)
				DoEvents
	         	wName = GetStringValue(TYPE_LIB, wGUID, wVer)
	         wArr = Split(wVer, ".")
	         wMajor = F.Hex2Dec(wArr(0))
	         wMinor = F.Hex2Dec(wArr(1))
            
	         .Add Join(Array(wGUID, wMajor, wMinor), vbTab), Array(wName, wGUID, wMajor, wMinor)
	        Next wVer
	    Next wGUID
    End With
End Function

Function EnumKey(ParamArray k())
    EnumKey = ExecMethod("EnumKey", "sNames", Join(k, "\"))
    If IsNull(EnumKey) Then EnumKey = Array()
End Function

Function GetStringValue(ParamArray k())
    GetStringValue = ExecMethod("GetStringValue", "sValue", Join(k, "\"))
    If IsNull(GetStringValue) Then GetStringValue = vbNullString
End Function

Function ExecMethod(method, prop, subkey) As Variant
    Dim param As WbemScripting.SWbemObjectEx
    With WbO
        Set param = .Methods_(method).InParameters.SpawnInstance_()
        param.Properties_("hDefKey").Value = &H80000000 'HKEY_CLASSES_ROOT
        param.Properties_("sSubKeyName").Value = subkey
        ExecMethod = .ExecMethod_(method, param).Properties_(prop).Value
    End With
End Function

Property Get WbO() As WbemScripting.SWbemObjectEx
    If mWbO Is Nothing Then Set mWbO = CreateObject("WbemScripting.SWbemLocator").ConnectServer(vbNullString, "root\default").Get("StdRegProv")
    Set WbO = mWbO
End Property

' 「アクティブなブックに設定されている参照設定」の辞書を作る

Function RefsInBook(wb As Excel.Workbook) As Scripting.Dictionary
	Dim ref As VBIDE.Reference
	Set RefsInBook = CreateObject("Scripting.Dictionary")
	With RefsInBook
		For Each ref In wb.VBProject.References
			.Add Join(Array(ref.GUID, ref.Major, ref.Minor), vbTab), Array(ref.Description, ref.GUID, ref.Major, ref.Minor)
		Next
	End With
End Function

事前準備

　 VBAプロジェクトモデルへのアクセスを信頼する
　 Microsoft Scripting Runtime
　 Microsoft WMI Scripting
　 Microsoft Visual Basic for Applications Extensibility