참조 설정 목록을 만드는 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

사전 준비