'----------------------------------------------------------------------------
' A Macro to List All References on a Auto-Created New Sheet
' If you have a need for this
' It creates 523 Rows Including Header
' You can copy all this and paste in a New Module
' Then just use - "Cut" and And Paste - View Code
Sub ListAllPossibleToolsReferences()
' Do not Click on Link - unless you want to install
' clickable links with view code
Dim ws As Worksheet, objRegistry As Object
Dim strComputer As String, strKeyPath As String
Dim arrSubKeys() As Variant, subKey As Variant, versionKey As Variant, langKey As Variant
Dim arrVersionKeys() As Variant, arrLangKeys() As Variant
Dim strDescription As String, strPath As String, rowNum As Long
Dim versionParts() As String, majorVer As String, minorVer As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error Resume Next
Set ws = ThisWorkbook.Worksheets("All_Possible_References")
On Error GoTo 0
If ws Is Nothing Then
Set ws = ThisWorkbook.Worksheets.Add: ws.Name = "All_Possible_References"
Else
ws.Cells.Clear
End If
' Write Expanded Table Headers
With ws
.Cells(1, 1).Value = "Library Name / Description"
.Cells(1, 2).Value = "GUID"
.Cells(1, 3).Value = "Major Ver"
.Cells(1, 4).Value = "Minor Ver"
.Cells(1, 5).Value = "File Path / Location"
.Cells(1, 6).Value = "Action"
.Rows(1).Font.Bold = True
With .Columns("F")
.HorizontalAlignment = xlCenter
End With
End With
rowNum = 2
strComputer = "."
Set objRegistry = GetObject("winmgmts:\\" & strComputer & "\root\default:StdRegProv")
strKeyPath = "TypeLib"
objRegistry.EnumKey &H80000000, strKeyPath, arrSubKeys
On Error Resume Next
If Not IsNull(arrSubKeys) Then
For Each subKey In arrSubKeys
objRegistry.EnumKey &H80000000, strKeyPath & "\" & subKey, arrVersionKeys
If Not IsNull(arrVersionKeys) Then
For Each versionKey In arrVersionKeys
strDescription = ""
objRegistry.GetStringValue &H80000000, strKeyPath & "\" & subKey & "\" & versionKey, "", strDescription
' Split major and minor versions (e.g., "2.1" -> Major: 2, Minor: 1)
majorVer = "0": minorVer = "0"
If InStr(versionKey, ".") > 0 Then
versionParts = Split(versionKey, ".")
majorVer = versionParts(0)
minorVer = versionParts(1)
Else
majorVer = versionKey
End If
arrLangKeys = Empty
objRegistry.EnumKey &H80000000, strKeyPath & "\" & subKey & "\" & versionKey, arrLangKeys
strPath = ""
If Not IsNull(arrLangKeys) Then
For Each langKey In arrLangKeys
objRegistry.GetStringValue &H80000000, strKeyPath & "\" & subKey & "\" & versionKey & "\" & langKey & "\win32", "", strPath
If strPath = "" Then
objRegistry.GetStringValue &H80000000, strKeyPath & "\" & subKey & "\" & versionKey & "\" & langKey & "\win64", "", strPath
End If
If strPath <> "" Then Exit For
Next langKey
End If
If strDescription <> "" Then
ws.Cells(rowNum, 1).Value = strDescription
ws.Cells(rowNum, 2).Value = subKey
ws.Cells(rowNum, 3).Value = majorVer
ws.Cells(rowNum, 4).Value = minorVer
ws.Cells(rowNum, 5).Value = strPath
' Visual Link Anchor
ws.Cells(rowNum, 6).Value = "⚡ Click to Install/Activate"
ws.Cells(rowNum, 6).Font.Color = RGB(0, 102, 204)
ws.Cells(rowNum, 6).Font.Underline = xlUnderlineStyleSingle
rowNum = rowNum + 1
End If
Next versionKey
End If
Next subKey
End If
On Error GoTo 0
ws.Columns("A:F").AutoFit
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
' MsgBox "Generated list successfully!", vbInformation
Call AlphabetizeReferences
End Sub
'----------------------------------------------------------------------------
' Code below will Alphetize References
Sub AlphabetizeReferences()
Dim ws As Worksheet
Dim lastRow As Long
' Set the target sheet by its exact name
On Error Resume Next
Set ws = ThisWorkbook.Worksheets("All_Poss_Ref_VC")
On Error GoTo 0
If ws Is Nothing Then
MsgBox "Sheet 'All_Poss_Ref_VC' not found!", vbCritical, "Error"
Exit Sub
End If
' Dynamically find the last row containing data in Column A
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' Only attempt to sort if there is data below the header row
If lastRow >= 2 Then
With ws.Sort
.SortFields.Clear
' Set Column A (starting at A2) as the alphabetical sorting key
.SortFields.Add2 Key:=ws.Range("A2:A" & lastRow), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
' Define the complete data block boundaries (Columns A through F)
.SetRange ws.Range("A1:F" & lastRow)
.Header = xlYes ' Keep row 1 locked in place as the header
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End If
End Sub
'----------------------------------------------------------------------------
' VIEW CODE Below - do not put this in a standard macro - view code you will have Duplicates
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' Copy this View Code - Then Just Right Click on New Created Sheet and Select View Code and Paste
' Copy this View Code Put in the new Sheet that was Created
' Execute only if a single cell in column F (Action column) is selected
If Target.Cells.Count > 1 Then Exit Sub
If Target.Column <> 6 Then Exit Sub
If Target.row = 1 Or Target.Value = "" Then Exit Sub
Dim targetSheet As Worksheet
Dim guidStr As String, majorVer As Long, minorVer As Long, refName As String
Set targetSheet = ActiveSheet
refName = targetSheet.Cells(Target.row, 1).Value
guidStr = targetSheet.Cells(Target.row, 2).Value
majorVer = CLng(targetSheet.Cells(Target.row, 3).Value)
minorVer = CLng(targetSheet.Cells(Target.row, 4).Value)
' Ask user confirmation to prevent accidental clicks
Dim choice As VbMsgBoxResult
choice = MsgBox("Do you want to add the library reference '" & refName & "' to this workbook project?", vbYesNo + vbQuestion, "Confirm Activation")
If choice = vbYes Then
On Error Resume Next
' Try adding the reference programmatically via its registry GUID structure
ThisWorkbook.VBProject.References.AddFromGuid guidStr, majorVer, minorVer
If Err.Number = 32813 Then
MsgBox "This library reference is already active and installed in your project!", vbInformation, "Already Active"
ElseIf Err.Number = 0 Then
MsgBox "Successfully activated reference: " & refName, vbInformation, "Installation Success"
Else
MsgBox "Failed to auto-install: " & Err.Description & vbCrLf & "Ensure 'Trust Access to VBA Project Object Model' is enabled in Trust Center.", vbCritical, "Error"
End If
On Error GoTo 0
End If
' Move selection back to column A to avoid clicking loop triggers
Application.EnableEvents = False
targetSheet.Cells(Target.row, 1).Select
Application.EnableEvents = True
End Sub