mdlVBEReferences

Option Explicit

Private Const ModName As String = "mdlVBEReferences"

Sub Test_VBReferences()

    Dim a() As Variant

    Dim Target As Range

    Set Target = ThisWorkbook.Worksheets(1).Range("A1")

    VBReferences ThisWorkbook, a(), True

    Target.Resize(UBound(a), UBound(a, 2)).Value = a

    Target.CurrentRegion.Columns.AutoFit

End Sub

Public Function VBReferences(ByRef wkb As Workbook, ByRef output() As Variant, _

    Optional ByVal IncludeHeadings As Boolean = False) As Long

    Const ProcName As String = "VBReferences"

    On Error GoTo ErrorHandler

    Dim vbProj As VBIDE.VBProject

    Dim vbRef As VBIDE.Reference

    Dim i As Long

    Set vbProj = wkb.VBProject

    Const ArrayColumns As Integer = 10

    ReDim output(1 To vbProj.References.Count, 1 To ArrayColumns)

    ' If headings were requested, increase the size of the output array

    ' and populate the first 'row'with field (column) names

    '

    If IncludeHeadings = True Then

        i = i + 1

        ReDim output(1 To (vbProj.References.Count + 1), 1 To ArrayColumns)

        output(i, 1) = "Name"

        output(i, 2) = "Description"

        output(i, 3) = "Full Path"

        output(i, 4) = "File Date"

        output(i, 5) = "File Version"

        output(i, 6) = "Reference Version"

        output(i, 7) = "Built In"

        output(i, 8) = "Is Broken"

        output(i, 9) = "Type"

        output(i, 10) = "GUID"

    End If

    ' Get details for each active reference

    For Each vbRef In vbProj.References

        i = i + 1

        output(i, 1) = vbRef.Name

        output(i, 2) = IIf(Len(vbRef.Description) > 0, vbRef.Description, "No Description")

        output(i, 3) = vbRef.FullPath

        output(i, 4) = FileDate(vbRef.FullPath)

        output(i, 5) = FileVersion(vbRef.FullPath)

        output(i, 6) = vbRef.Major & "." & vbRef.Minor

        output(i, 7) = IIf(vbRef.BuiltIn = True, "Yes", "No")

        output(i, 8) = IIf(vbRef.IsBroken = True, "Yes", "No")

        output(i, 9) = RefTypeToString(vbRef.Type)

        output(i, 10) = IIf(Len(vbRef.GUID) > 0, vbRef.GUID, "No GUID")

    Next vbRef

ExitFunction:

    VBReferences = i

    Exit Function

ErrorHandler:

    Debug.Print ModName, ProcName, Err.Number, Err.Description, Erl

    '/Log.LogError ThisWorkbook, ModName, ProcName, Err.Number, Err.Description, Erl

    Resume ExitFunction

End Function

' Uses File System Object to return the passed file's version number (if any)

'

Private Function FileVersion(ByVal FileName As String) As String

    On Error GoTo ErrorHandler

    Dim ver As String

    Dim fso As Object ' FileSystemObject

    Set fso = CreateObject("Scripting.FileSystemObject")

    ver = fso.GetFileVersion(FileName)

    If Len(ver) = 0 Then

        ver = "No File Version"

    End If

ExitFunction:

    Set fso = Nothing

    FileVersion = ver

    Exit Function

ErrorHandler:

    ver = "Can't get File Version"

    Resume ExitFunction

End Function

' Returns the passed file's last modified or creation date

'

Private Function FileDate(ByVal FileName As String) As String

    On Error Resume Next

    Dim dte As String

    dte = FileDateTime(FileName)

    If Len(dte) = 0 Then

        dte = "Unknown Date"

    End If

    FileDate = dte

End Function

Private Function RefTypeToString(ByVal RefType As Integer) As String

    Dim value As String

    'VBA.vbext_RefKind

    'vbext_rk_Project  = VBA Project

    'vbext_rk_TypeLib = Type Library (DLL, EXE)

    Select Case RefType

        Case vbext_rk_Project

            value = "VBA Project"

        Case vbext_rk_TypeLib

            value = "Library (DLL, EXE)"

        Case Else

            value = "Unknown Reference"

    End Select

    RefTypeToString = value

End Function