Add Content Block
mdlUtils

Option Explicit

Private Const ModName As String = "mdlUtils"

' TODO: Move to Array class
Public Function TransposeArray(arr() As Variant) As Variant()
Const ProcName As String = "TransposeArray"
On Error GoTo ErrorHandler

Dim StartRow As Long
Dim StartCol As Long
Dim EndRow As Long
Dim EndCol As Long
Dim row As Long
Dim col As Long
Dim Res() As Variant

' Get size of original matrix
StartRow = LBound(arr)
EndRow = UBound(arr)
StartCol = LBound(arr, 2)
EndCol = UBound(arr, 2)

' Resize the target array
ReDim Res(StartCol To EndCol, StartRow To EndRow)

' Transpose the matrix
For row = StartRow To EndRow
For col = StartCol To EndCol
Res(col, row) = arr(row, col)
Next col
Next row

ExitFunction:
TransposeArray = Res
Exit Function

ErrorHandler:
log.LogError ThisWorkbook, ModName, ProcName, Err.Number, Err.Description, Erl
Resume ExitFunction

End Function



' TODO: MOve to Excelutil Class
Public Function SheetVisibleEnumToString(ByVal EnumValue As Integer) As String
Dim ReturnValue As String

Select Case EnumValue
Case -1
ReturnValue = "Visible"
Case 0
ReturnValue = "Hidden"
Case 2
ReturnValue = "Very Hidden"
Case Else
ReturnValue = "Unknown (" & EnumValue & ")"
End Select

SheetVisibleEnumToString = ReturnValue

End Function

mdlMain

​Option Explicit

Public Const AppName As String = "Workbook Metrics"

Private Const ModName As String = "mdlMain"

Private m_log As cErrorLog
Private m_Colours As cColours

Public Const CountFormat As String = "#,##0_ ;[Red]-#,##0 "
Public Const DecimalFormat As String = "#,##0.00_ ;[Red]-#,##0.00 "
Public Const NoValue As Variant = 0

Public Const LongMaxValue As Long = 2147483647

Sub Main()
'/
End Sub


Public Function log() As cErrorLog

If m_log Is Nothing Then
Set m_log = New cErrorLog
End If

Set log = m_log

End Function


Public Function Colour() As cColours
If m_Colours Is Nothing Then
Set m_Colours = New cColours
End If

Set Colour = m_Colours
End Function

mdlTEST

Option Explicit

Private Const ModName As String = "mdlTEST"

Sub Test_WorkbookMetrics()

Dim wm As cWorkbookMetrics_OLD
Dim wkb As Workbook

Dim msg As String
Dim ProtectedSheets As Long

Set wm = New cWorkbookMetrics_OLD

' Things whihch need to be checked/verified before a complete analysis can be provided:
' 1. Do I have trusted access to the VBA project object model?
' 2. Is the workbook's VBA Project protected?
' 3. Are there any worksheets which are protected?
' 4. Is the workbook protected

'/Set wkb = Workbooks("maturity checker_2016.xlsm")
Set wkb = Workbooks("ReportChecks_2016 TEST.xlsm")


If wm.IsVBEAccessTrusted(wkb) = False Then
Debug.Print "VBE access is not trusted"
GoTo ExitSub
End If


If wm.IsVBEProtected(wkb) = True Then
msg = "The selected workbook has its VBA code locked (protected)." & vbCrLf & vbCrLf & _
"Do you want to continue anyway?"

If MsgBox(msg, vbQuestion + vbYesNo, AppName) <> vbYes Then
Debug.Print "VBE is protected."
GoTo ExitSub
End If

wm.ProcessModules = False
wm.ProcessRoutines = False
End If

ProtectedSheets = wm.ProtectedSheetCount(wkb)

If ProtectedSheets > 0 Then
msg = "The selected workbook has " & ProtectedSheets & " protected worksheets." & vbCrLf & vbCrLf & _
"These will not be scanned." & vbCrLf & vbCrLf & _
"Do you want to continue anyway?"

If MsgBox(msg, vbQuestion + vbYesNo, AppName) <> vbYes Then
Debug.Print ProtectedSheets & " worksheets are protected."
GoTo ExitSub
End If

End If

'/wm.ProcessWorksheets = True
'/wm.ProcessExcelLinks = True
'/wm.ProcessHyperlinks = True
'/wm.ProcessFunctions = True
'/wm.ProcessQueryTables = True
'/wm.ProcessPivotTables = True
'/wm.ProcessModules = True
'/wm.ProcessRoutines = True
'/wm.ProcessButtons = True
wm.ProcessAddIns = True

wm.GetMetricsActiveFile wkb

ExitSub:
    Set wm = Nothing
    Exit Sub

End Sub


Sub Test_GetPivotTables()
    Dim pvt As cPivotTables
    Set pvt = New cPivotTables

    pvt.PivotTables ActiveSheet
End Sub

cAddIns

​Combine cAddIns and cComAddIns into a single class. Include enum parameter to select which add-ins to return:

Public Enum AddInTypes

    eExcelAddIns = 1

    eComAddIns = 2

    eAllAddIns = 3

​End Enum

cExcelLinks

​Option Explicit

Private Const ModName As String = "cLinks"

Public Function WorkbookLinks(ByRef wkb As Workbook, ByRef a() As Variant) As Long

Const ProcName As String = "GetWorkbookLinks"
On Error GoTo ErrorHandler

'/Application.StatusBar = "Workbook Links"

Dim i As Long
Dim lnk As Variant

ReDim a(3, 0)

If Not IsEmpty(wkb.LinkSources(xlExcelLinks)) Then
For Each lnk In wkb.LinkSources(xlExcelLinks)
ReDim Preserve a(3, i)

a(0, i) = wkb.Name
a(1, i) = "Excel Link"
a(2, i) = lnk
a(3, i) = LinkInfoStatusToString(wkb.LinkInfo(lnk, xlLinkInfoStatus))

i = i + 1
Next lnk
End If


If Not IsEmpty(wkb.LinkSources(xlOLELinks)) Then
For Each lnk In wkb.LinkSources(xlOLELinks)
ReDim Preserve a(3, i)

a(0, i) = wkb.Name
a(1, i) = "OLE Link"
a(2, i) = lnk
a(3, i) = LinkInfoStatusToString(wkb.LinkInfo(lnk, xlLinkInfoStatus))

i = i + 1
Next lnk
End If

If i > 0 Then
a() = WorksheetFunction.Transpose(a())
End If

ExitFunction:
WorkbookLinks = i
Exit Function

ErrorHandler:
log.LogError ThisWorkbook, ModName, ProcName, Err.Number, Err.Description, Erl
Resume ExitFunction

End Function



Private Function LinkInfoStatusToString(ByRef LinkStatus As XlLinkStatus) As String
Dim status As String

Select Case LinkStatus
Case xlLinkStatusOK
status = "No errors"

Case xlLinkStatusMissingFile
status = "File missing"
Case xlLinkStatusMissingSheet
status = "Sheet missing"
Case xlLinkStatusOld
status = "Status may be out of date"
Case xlLinkStatusSourceNotCalculated
status = "Not yet calculated"
Case xlLinkStatusIndeterminate
status = "Unable to determine status"
Case xlLinkStatusNotStarted
status = "Not started"
Case xlLinkStatusInvalidName
status = "Invalid name"
Case xlLinkStatusSourceNotOpen
LinkStatus = "Not open"
Case xlLinkStatusSourceOpen
status = "Source document is open"
Case xlLinkStatusCopiedValues
status = "Copied values"
Case Else
status = "Unknown"
End Select

LinkInfoStatusToString = status

End Function

cHyperlinks

​Option Explicit

Private Const ModName As String = "cHyperlinks"


Public Function Hyperlinks(ByRef wkb As Workbook, ByRef a() As Variant) As Long
Const ProcName As String = "Hyperlinks"
On Error GoTo ErrorHandler

Dim wks As Worksheet
Dim lnk As Hyperlink
Dim Target As Range
Dim cell As Range
Dim LinkCount As Long
Dim StartPos As Long

Dim FormulaArgs() As String
Dim temp As String

Const MaxCols As Integer = 5

ReDim a(MaxCols, 50000)

For Each wks In wkb.Worksheets

' Collate Hyperlink OBJECTS
For Each lnk In wks.Hyperlinks
a(0, LinkCount) = wkb.Name
a(1, LinkCount) = wks.Name
a(2, LinkCount) = LinkAddress(lnk)
a(3, LinkCount) = "Hyperlink"
a(4, LinkCount) = lnk.Name
a(5, LinkCount) = lnk.address

LinkCount = LinkCount + 1
Next lnk


' Collate Hyperlink FORMULAS
Set Target = GetFormulaRange(wks)

If Target Is Nothing Then
GoTo NextWorksheet
End If

For Each cell In Target.Cells
StartPos = InStr(1, cell.Formula, "HYPERLINK(")

If StartPos = 0 Then
GoTo NextCell
End If

StartPos = StartPos + Len("HYPERLINK(")
temp = Mid$(cell.Formula, StartPos, Len(cell.Formula) - StartPos)
FormulaArgs() = Split(temp, ",")

a(0, LinkCount) = wkb.Name
a(1, LinkCount) = wks.Name
a(2, LinkCount) = cell.address
a(3, LinkCount) = "Formula"
a(4, LinkCount) = Replace(FormulaArgs(1), """", "") ' Link Alias
a(5, LinkCount) = Replace(FormulaArgs(0), """", "") ' Link Address

LinkCount = LinkCount + 1

NextCell:
Next cell

NextWorksheet:
Next wks

If LinkCount > 0 Then
ReDim Preserve a(MaxCols, LinkCount - 1)
a() = TransposeArray(a())
End If

ExitFunction:
Hyperlinks = LinkCount
Exit Function

ErrorHandler:
log.LogError ThisWorkbook, ModName, ProcName, Err.Number, Err.Description, Erl
Resume ExitFunction

End Function







Private Function LinkAddress(ByRef lnk As Hyperlink) As String
Dim address As String

On Error Resume Next

address = lnk.Range.address

If Len(address) = 0 Then
address = lnk.address
End If

LinkAddress = address

End Function




Private Function GetFormulaRange(ByRef wks As Worksheet) As Range
On Error GoTo ErrorHandler

Dim Target As Range
Set Target = wks.Cells.SpecialCells(xlCellTypeFormulas)

ExitFunction:
Set GetFormulaRange = Target
Exit Function

ErrorHandler:
Resume ExitFunction

End Function


cMacroButtons

​Option Explicit

Private Const ModName As String = "cMacroButtons"


' -- History --
' 03-Sep-2018 MS: Added check for OnAction length for msoFormControl as some controls (e.g. combo box)
' don't have Characters.Text which raised an error.
' 11-Seo-2018 MS: Removed the check 'shp.Type = msoFormControl' to find *all* shapes which have a macro attached
Public Function MacroButtons(ByRef wkb As Workbook, ByRef a() As Variant) As Long
Const ProcName As String = "GetButtonMacros"
On Error GoTo ErrorHandler

Dim wks As Worksheet
Dim i As Long

Dim shp As Shape
Dim btn As OLEObject

ReDim a(5, 0)

For Each wks In wkb.Worksheets

For Each shp In wks.Shapes
'/If shp.Type = msoFormControl Then
If Len(shp.OnAction) > 0 Then
ReDim Preserve a(5, i)
a(0, i) = wkb.Name
a(1, i) = wks.Name
a(2, i) = "Shape"
a(3, i) = shp.Name
a(4, i) = Trim(shp.TextFrame.Characters.Text)

a(5, i) = shp.OnAction

' Sometimes the workbook prefix is missing from the OnAction
' If so, remove it to avoid confusion
If Left$(a(5, i), 4) = "[0]!" Then
a(5, i) = Right$(a(5, i), Len(a(5, i)) - Len("[0]!"))
End If

i = i + 1
End If
'/End If
Next shp

For Each btn In wks.OLEObjects
If btn.OLEType = xlButtonOnly Then
ReDim Preserve a(5, i)
a(0, i) = wkb.Name
a(1, i) = wks.Name
a(2, i) = "ActiveX"
a(3, i) = btn.Name
a(4, i) = Trim(btn.Object.Caption)
a(5, i) = btn.Name & "_Click"
i = i + 1
End If
Next btn

Next wks

a() = WorksheetFunction.Transpose(a)

ExitFunction:
MacroButtons = i
Exit Function

ErrorHandler:
log.LogError ThisWorkbook, ModName, ProcName, Err.Number, Err.Description, Erl
Resume ExitFunction

End Function

cModules

​Add updated cModules class

cPivotTables

​Option Explicit

Private Const ModName As String = "cPivotTables"


Public Function PivotTableCount(ByRef wks As Worksheet) As Long
Const ProcName As String = "GetPivotTableCount"
On Error GoTo ErrorHandler

Dim i As Long
Dim pvt As PivotTable

For Each pvt In wks.PivotTables
i = i + 1
Next pvt

ExitFunction:
Set pvt = Nothing
PivotTableCount = i
Exit Function

ErrorHandler:
log.LogError ThisWorkbook, ModName, ProcName, Err.Number, Err.Description, Erl
Resume ExitFunction

End Function


' https://www.contextures.com/excelpivottabledatasource.html

Public Function PivotTables(ByRef wks As Worksheet) As Long
Const ProcName As String = "PivotTables"
'/On Error GoTo ErrorHandler

Dim i As Long
Dim pvt As PivotTable

For Each pvt In wks.PivotTables
Debug.Print wks.Parent.Name
Debug.Print wks.Name
Debug.Print pvt.Name
Debug.Print pvt.DataBodyRange.CurrentRegion.address
Debug.Print pvt.SourceData

Debug.Print SourceTypeToString(pvt.PivotCache.SourceType)

Debug.Print pvt.PivotCache.Connection

'XlListObjectSourceType
'pvt.PivotCache.SourceType

Debug.Print String(50, "-")



i = i + 1
Next pvt

ExitFunction:
Set pvt = Nothing
Exit Function

ErrorHandler:
log.LogError ThisWorkbook, ModName, ProcName, Err.Number, Err.Description, Erl
Resume ExitFunction

End Function



Private Function SourceTypeToString(ByVal SourceType As XlListObjectSourceType) As String
Dim source As String

Select Case SourceType
Case xlSrcExternal '0
source = "External data source" '(Microsoft SharePoint Foundation site).
Case xlSrcModel '4
source = "PowerPivot Model"
Case xlSrcQuery '3
source = "Query"
Case xlSrcRange '1
source = "Range"
Case xlSrcXml '2
source = "XML"
Case Else
source = "Unknown Source Type (" & SourceType & ")"
End Select

SourceTypeToString = source

End Function


cQueryTables

​Option Explicit

Private Const ModName As String = "cQueryTables"


Public Function QueryTables(ByRef wkb As Workbook, ByRef a() As Variant) As Long
Const ProcName As String = "QueryTables"
On Error GoTo ErrorHandler

'/Application.StatusBar = "Query Table Metrics"

Dim wks As Worksheet
Dim qt As QueryTable
Dim i As Long

ReDim a(8, 0)

For Each wks In wkb.Worksheets

For Each qt In wks.QueryTables
ReDim Preserve a(8, i)

a(0, i) = wkb.Name
a(1, i) = wks.Name
a(2, i) = qt.ResultRange.address

If qt.WorkbookConnection Is Nothing Then
a(3, i) = "Nothing"
Else
a(3, i) = qt.WorkbookConnection
End If

a(4, i) = QueryTypeToString(qt.QueryType)
a(5, i) = WebSelectionTypeToString(qt.WebSelectionType)
a(6, i) = qt.Parameters.count
a(7, i) = qt.Name

If qt.WorkbookConnection Is Nothing Then
a(8, i) = "Connection Failed"
Else
a(8, i) = qt.Connection
End If

i = i + 1
Next
Next

If i > 0 Then
a() = WorksheetFunction.Transpose(a())
End If

ExitFunction:
Set wks = Nothing
Set qt = Nothing
QueryTables = i
Exit Function

ErrorHandler:
log.LogError ThisWorkbook, ModName, ProcName, Err.Number, Err.Description, Erl
Resume ExitFunction

End Function


Private Function QueryTypeToString(ByVal EnumValue As XlQueryType) As String
Dim ReturnValue As String

Select Case EnumValue
Case xlWebQuery: ReturnValue = "Web Query"
Case xlODBCQuery: ReturnValue = "ODBC Query"
Case xlOLEDBQuery: ReturnValue = "OLEDB Query"
Case xlADORecordset: ReturnValue = "ADO Recordset"
Case xlDAORecordset: ReturnValue = "DAO Recordset"
Case Else: ReturnValue = "Unknown"
End Select

QueryTypeToString = ReturnValue

End Function



Private Function WebSelectionTypeToString(ByVal EnumValue As XlWebSelectionType) As String
Dim ReturnValue As String

Select Case EnumValue
Case xlAllTables: ReturnValue = "All Tables "
Case xlEntirePage: ReturnValue = "Entire Page"
Case xlSpecifiedTables: ReturnValue = "Specified Tables"
Case Else: ReturnValue = "Unknown"
End Select

WebSelectionTypeToString = ReturnValue

End Function


cWorkbookMetrics_OLD

​Option Explicit

Private Const ModName As String = "cWorkbookMetrics"

'/Public Event Process(ByVal Index As Integer, ByVal Description As String)
Public Event Process(ByVal CurrentValue As Integer, ByVal MaxValue As Integer, ByVal Description As String)


Private Const wksNameSum As String = "Summary"

Private Const wksNameWks As String = "Worksheets"
Private Const wksNameLnk As String = "ExcelLinks"
Private Const wksNameHyp As String = "Hyperlinks"
Private Const wksNameFnc As String = "Functions"

Private Const wksNameQts As String = "QueryTables"
Private Const wksNamePvt As String = "PivotTables"

Private Const wksNameMod As String = "Modules"
Private Const wksNameRtn As String = "Routines"
Private Const wksNameAdd As String = "AddIns"
Private Const wksNameBtns As String = "Buttons"



Private Type Processes
Worksheets As Boolean
ExcelLinks As Boolean
Hyperlinks As Boolean
Functions As Boolean

QueryTables As Boolean
PivotTables As Boolean

Modules As Boolean
Routines As Boolean
AddIns As Boolean
Buttons As Boolean
End Type

Private prc As Processes


Private Type WorkbookMetrics
WorkbookName As String

Metrics() As Variant
ExcelLinks() As Variant
Hyperlinks() As Variant
Functions() As Variant

QueryTables() As Variant
PivotTables() As Variant

ModuleList() As Variant
ModuleMetrics() As Variant
AddIns() As Variant
MacroButtons() As Variant

' MetricsHeadings() As Variant
' ExcelLinksHeadings() As Variant
' HyperlinksHeadings() As Variant
' FunctionHeadings() As Variant
'
' QueryTablesHeadings() As Variant
' PivotTableHeadings() As Variant
'
' ModuleListHeadings() As Variant
' ModuleMetricsHeadings() As Variant
' ButtonsHeadings() As Variant
' AddInsHeadings() As Variant

MetricsCount As Long
ExcelLinksCount As Long
HyperlinksCount As Long
FunctionsCount As Long

QueryTablesCount As Long
PivotTablesCount As Long

ModuleListCount As Long
ModuleMetricsCount As Long
AddInsCount As Long
MacroButtonsCount As Long

End Type



Public Property Get ProcessWorksheets() As Boolean
ProcessWorksheets = prc.Worksheets
End Property

Public Property Let ProcessWorksheets(value As Boolean)
prc.Worksheets = value
End Property


Public Property Get ProcessExcelLinks() As Boolean
ProcessExcelLinks = prc.ExcelLinks
End Property

Public Property Let ProcessExcelLinks(value As Boolean)
prc.ExcelLinks = value
End Property


Public Property Get ProcessHyperlinks() As Boolean
ProcessHyperlinks = prc.Hyperlinks
End Property

Public Property Let ProcessHyperlinks(value As Boolean)
prc.Hyperlinks = value
End Property


Public Property Get ProcessFunctions() As Boolean
ProcessFunctions = prc.Functions
End Property

Public Property Let ProcessFunctions(value As Boolean)
prc.Functions = value
End Property


Public Property Get ProcessQueryTables() As Boolean
ProcessQueryTables = prc.QueryTables
End Property

Public Property Let ProcessQueryTables(value As Boolean)
prc.QueryTables = value
End Property


Public Property Get ProcessPivotTables() As Boolean
ProcessPivotTables = prc.PivotTables
End Property

Public Property Let ProcessPivotTables(value As Boolean)
prc.PivotTables = value
End Property


Public Property Get ProcessModules() As Boolean
ProcessModules = prc.Modules
End Property

Public Property Let ProcessModules(value As Boolean)
prc.Modules = value
End Property


Public Property Get ProcessRoutines() As Boolean
ProcessRoutines = prc.Routines
End Property

Public Property Let ProcessRoutines(value As Boolean)
prc.Routines = value
End Property


Public Property Get ProcessAddIns() As Boolean
ProcessAddIns = prc.AddIns
End Property

Public Property Let ProcessAddIns(value As Boolean)
prc.AddIns = value
End Property


Public Property Get ProcessButtons() As Boolean
ProcessButtons = prc.Buttons
End Property

Public Property Let ProcessButtons(value As Boolean)
prc.Buttons = value
End Property



Private Sub Class_Initialize()
'

End Sub



Public Function GetMetricsSelectedFile(ByVal PathName As String, ByVal filenames As Collection) As Boolean
Const ProcName As String = "GetMetricsSelectedFile"
On Error GoTo ErrorHandler

Dim status As Boolean
Dim wkb As Workbook

If ValidateIsVBEAccessTrusted = False Then
GoTo ExitFunction
End If


Dim output As Workbook
Dim wm As WorkbookMetrics
Dim i As Long

Application.ScreenUpdating = False

Set output = GetOutputWorkbook

Dim file As Variant

For Each file In filenames
' open r/o without updating links
Set wkb = Workbooks.Open(PathName & file, False, True)

GetWorkbookMetrics wkb, wm
wkb.Close False

SaveWorkbookMetrics output, wm
Next file

status = True

ExitFunction:
Application.ScreenUpdating = True
Set wkb = Nothing
GetMetricsSelectedFile = status
Exit Function

ErrorHandler:
log.LogError ThisWorkbook, ModName, ProcName, Err.Number, Err.Description, Erl
Resume ExitFunction

End Function






Public Function GetMetricsActiveFile(ByRef wkb As Workbook) As Boolean
Const ProcName As String = "GetMetricsActiveFile"
On Error GoTo ErrorHandler

Dim status As Boolean

Dim output As Workbook
Dim wm As WorkbookMetrics

'/Application.ScreenUpdating = False

If GetWorkbookMetrics(wkb, wm) = True Then

Application.Calculation = xlCalculationManual
'/Application.ScreenUpdating = False

Set output = GetOutputWorkbook

SaveWorkbookMetrics output, wm

status = True
End If

ExitFunction:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

Set output = Nothing
GetMetricsActiveFile = status
Exit Function

ErrorHandler:
log.LogError ThisWorkbook, ModName, ProcName, Err.Number, Err.Description, Erl
Resume ExitFunction

End Function


Public Function ValidateVBEProtected(ByRef wkb As Workbook) As Boolean
Const ProcName As String = "ValidateVBEProtected"
On Error GoTo ErrorHandler

Dim status As Boolean

status = True

If IsVBEProtected(wkb) Then

If IsVBEProtected(wkb) = True Then
Dim msg As String

msg = "The Visual Basic project for " & vbCrLf & _
"'" & wkb.Name & "' is locked. " & vbCrLf & vbCrLf & _
"You won't be able to get any VBA related metrics." & vbCrLf & _
"Do you want to continue anyway?"

If MsgBox(msg, vbQuestion + vbYesNo, AppName) = vbNo Then
status = False
End If
End If

End If

ExitFunction:
ValidateVBEProtected = status
Exit Function

ErrorHandler:
log.LogError ThisWorkbook, ModName, ProcName, Err.Number, Err.Description, Erl
Resume ExitFunction

End Function



Public Function ValidateIsVBEAccessTrusted() As Boolean
Const ProcName As String = "ValidateIsVBEAccessTrusted"
On Error GoTo ErrorHandler

Dim status As Boolean
Dim msg As String

If IsVBEAccessTrusted() = False Then
msg = "The Visual Basic Editor is locked from programmatic access." & vbCrLf & _
"Before trying again, change the following option:" & vbCrLf & vbCrLf & _
"1. From Excel select Files" & vbCrLf & _
"2. > Options" & vbCrLf & _
"3. > Trust Centre" & vbCrLf & _
"4. > Trust Centre Settings" & vbCrLf & _
"5. > Macro Settings" & vbCrLf & _
"6. > Under 'Developer Macro Settings' and check " & vbCrLf & _
" 'Trust access to the VBA project object model'"

MsgBox msg, vbInformation, AppName
Else
status = True
End If

ExitFunction:
ValidateIsVBEAccessTrusted = status
Exit Function

ErrorHandler:
log.LogError ThisWorkbook, ModName, ProcName, Err.Number, Err.Description, Erl
Resume ExitFunction

End Function



' The VBE editor has a setting to allow programmatic access to the VBA (virus protection).
' If locked, any programmatic attempt to access the VBE generates Error 1004 with message:
' "Programmatic access to Visual Basic Project is not trusted"
'
' -- To allow programmtic access to the VBE:
' 1. From Excel, select Files
' 2. Options
' 3. Trust Centre
' 4. Trust Centre Settings
' 5. Macro Settings
' 6. Under 'Developer Macro Settings' check 'Trust access to the VBA project object model'
Public Function IsVBEAccessTrusted(Optional ByRef wkb As Workbook) As Boolean
Const ProcName As String = "IsVBEAccessTrusted"
On Error GoTo ErrorHandler

Dim status As Boolean
Dim wkbTest As Workbook

If wkb Is Nothing Then
Application.ScreenUpdating = False
Set wkbTest = Workbooks.Add
Else
Set wkbTest = wkb
End If

Dim desc As String

desc = wkbTest.VBProject.Description
status = True

ExitFunction:
Application.ScreenUpdating = True
On Error Resume Next
If wkb Is Nothing Then
wkbTest.Close
End If
IsVBEAccessTrusted = status
Exit Function

ErrorHandler:
If Err.Description Like "*not trusted*" Then
' Programmatic access to Visual Basic Project is not trusted
' Do nothing
Else
log.LogError ThisWorkbook, ModName, ProcName, Err.Number, Err.Description, Erl
End If

Resume ExitFunction

End Function


Public Function IsVBEProtected(ByRef wkb As Workbook) As Boolean
Const ProcName As String = "IsVBEProtected"
On Error GoTo ErrorHandler

Dim status As Boolean

' If Me.IsVBEAccessTrusted(wkb) = False Then
' status = True
' GoTo ExitFunction
' End If

If wkb.VBProject.Protection = vbext_pp_locked Then
status = True
End If

ExitFunction:
IsVBEProtected = status
Exit Function

ErrorHandler:
log.LogError ThisWorkbook, ModName, ProcName, Err.Number, Err.Description, Erl
Resume ExitFunction

End Function


Private Function GetWorkbookMetrics(ByRef wkb As Workbook, _
ByRef wm As WorkbookMetrics) As Boolean

Const ProcName As String = "GetWorkbookMetrics"
On Error GoTo ErrorHandler

Dim status As Boolean
Dim CalcMode As Integer

CalcMode = Application.Calculation
Application.Calculation = xlCalculationManual

wm.WorkbookName = wkb.Name

Dim ProcessCount As Integer
Dim TotalCount As Integer


TotalCount = _
Abs(prc.Worksheets + prc.ExcelLinks + prc.Hyperlinks + _
prc.QueryTables + prc.PivotTables + prc.Functions + _
prc.Modules + prc.Routines + prc.Buttons + prc.AddIns)

If TotalCount = 0 Then
GoTo ExitSub
End If



If prc.Worksheets = True Then
ProcessCount = ProcessCount + 1
RaiseEvent Process(ProcessCount, TotalCount, "Worksheets")

Dim ws As cWorksheetMetrics
Set ws = New cWorksheetMetrics
wm.MetricsCount = ws.WorksheetMetrics(wkb, wm.Metrics)
End If

If prc.ExcelLinks = True Then
ProcessCount = ProcessCount + 1
RaiseEvent Process(ProcessCount, TotalCount, "Excel Links")

Dim lk As cExcelLinks
Set lk = New cExcelLinks
wm.ExcelLinksCount = lk.WorkbookLinks(wkb, wm.ExcelLinks)
End If

If prc.Hyperlinks = True Then
ProcessCount = ProcessCount + 1
RaiseEvent Process(ProcessCount, TotalCount, "Hyperlinks")

Dim hl As cHyperlinks
Set hl = New cHyperlinks
wm.HyperlinksCount = hl.Hyperlinks(wkb, wm.Hyperlinks)
End If


If prc.Functions = True Then
ProcessCount = ProcessCount + 1
RaiseEvent Process(ProcessCount, TotalCount, "Functions")

' Dim fn As cWorksheetFunctions
' Set fn = New cWorksheetFunctions
' wm.fn = fn.GetFunctions(wkb, wm.Functions)
End If


If prc.QueryTables = True Then
ProcessCount = ProcessCount + 1
RaiseEvent Process(ProcessCount, TotalCount, "Query Tables")

Dim qt As cQueryTables
Set qt = New cQueryTables
wm.QueryTablesCount = qt.QueryTables(wkb, wm.QueryTables)
End If


If prc.PivotTables = True Then
ProcessCount = ProcessCount + 1
RaiseEvent Process(ProcessCount, TotalCount, "Pivot Tables")

' Dim pv As cPivotTables
' Set pv = New cPivotTables
' wm.PivotTablesCount = pv.PivotTableCount
End If


Dim md As cModules

If prc.Modules = True Then
ProcessCount = ProcessCount + 1
RaiseEvent Process(ProcessCount, TotalCount, "Modules")

' Set md = New cModules
' wm.ModuleListCount = md.GetModuleList(wkb, wm.ModuleList)
End If

If prc.Routines = True Then
ProcessCount = ProcessCount + 1
RaiseEvent Process(ProcessCount, TotalCount, "Routines")

' Set md = New cModules
' wm.ModuleMetricsCount = md.GetModuleMetrics(wkb, wm.ModuleMetrics)
End If

If prc.Buttons = True Then
ProcessCount = ProcessCount + 1
RaiseEvent Process(ProcessCount, TotalCount, "Macro Buttons")

' Dim mb As cMacroButtons
' Set mb = New cMacroButtons
' wm.MacroButtonsCount = mb.MacroButtons(wkb, wm.MacroButtons)
End If

If prc.AddIns = True Then
ProcessCount = ProcessCount + 1
RaiseEvent Process(ProcessCount, TotalCount, "Add-Ins")

' Dim ai As cAddIns
' Set ai = New cAddIns
' wm.AddInsCount = ai.GetAddIns(wkb, wm.AddIns)
End If


status = True

ExitSub:
Application.Calculation = CalcMode
GetWorkbookMetrics = status
Exit Function

ErrorHandler:
log.LogError ThisWorkbook, ModName, ProcName, Err.Number, Err.Description, Erl
log.ShowMessage Err, ModName, ProcName, Erl
Resume ExitSub

End Function


Private Function SaveWorkbookMetrics(ByRef wkb As Workbook, ByRef wm As WorkbookMetrics) As Boolean
Const ProcName As String = "SaveWorkbookMetrics"
On Error GoTo ErrorHandler

Dim status As Boolean

Dim Target As Range
Dim UpperBound As Long
Dim LowerBound As Long

Set Target = Nothing


If wm.MetricsCount > 0 Then
Set Target = GetTargetCell(wkb.Worksheets(wksNameWks))
GetBounds wm.Metrics, wm.MetricsCount, LowerBound, UpperBound
Target.Resize(LowerBound, UpperBound).value = wm.Metrics

' Formulas, Constants, Pivot Tables Query Tables count
Target.Parent.Columns("E:M").NumberFormat = CountFormat
Target.Parent.Columns("N:N").NumberFormat = DecimalFormat
Target.CurrentRegion.Columns.AutoFit
End If


If wm.ModuleListCount > 0 Then
Set Target = GetTargetCell(wkb.Worksheets(wksNameMod))
GetBounds wm.ModuleList, wm.ModuleListCount, LowerBound, UpperBound
Target.Resize(LowerBound, UpperBound).value = wm.ModuleList
Target.Parent.Columns("D:D").NumberFormat = CountFormat
Target.CurrentRegion.Columns.AutoFit
End If


If wm.ModuleMetricsCount > 0 Then
Set Target = GetTargetCell(wkb.Worksheets(wksNameRtn))
GetBounds wm.ModuleMetrics, wm.ModuleMetricsCount, LowerBound, UpperBound
Target.Resize(LowerBound, UpperBound).value = wm.ModuleMetrics
Target.Parent.Columns("D:D").NumberFormat = CountFormat
Target.CurrentRegion.Columns.AutoFit
End If


If wm.QueryTablesCount > 0 Then
Set Target = GetTargetCell(wkb.Worksheets(wksNameQts))
GetBounds wm.QueryTables, wm.QueryTablesCount, LowerBound, UpperBound
Target.Resize(LowerBound, UpperBound).value = wm.QueryTables
Target.CurrentRegion.Columns.AutoFit
' Query Name & Connection String
Target.Parent.Columns("H:I").ColumnWidth = 50
End If


If wm.ExcelLinksCount > 0 Then
Set Target = GetTargetCell(wkb.Worksheets(wksNameLnk))
GetBounds wm.ExcelLinks, wm.ExcelLinksCount, LowerBound, UpperBound
Target.Resize(LowerBound, UpperBound).value = wm.ExcelLinks
Target.CurrentRegion.Columns.AutoFit
End If


If wm.HyperlinksCount > 0 Then
Set Target = GetTargetCell(wkb.Worksheets(wksNameHyp))
GetBounds wm.Hyperlinks, wm.HyperlinksCount, LowerBound, UpperBound
Target.Resize(LowerBound, UpperBound + 1).value = wm.Hyperlinks
Target.CurrentRegion.Columns.AutoFit

wkb.Worksheets(wksNameHyp).Columns("E:E").ColumnWidth = 50
wkb.Worksheets(wksNameHyp).Columns("F:F").ColumnWidth = 100
End If


If wm.MacroButtonsCount > 0 Then
Set Target = GetTargetCell(wkb.Worksheets(wksNameBtns))
GetBounds wm.MacroButtons, wm.MacroButtonsCount, LowerBound, UpperBound
Target.Resize(LowerBound, UpperBound).value = wm.MacroButtons
Target.CurrentRegion.Columns.AutoFit
End If

PopulateSummaryWorksheet wkb, wm
wkb.Worksheets(wksNameSum).Activate

status = True

ExitFunction:
SaveWorkbookMetrics = status
Exit Function

ErrorHandler:
log.LogError ThisWorkbook, ModName, ProcName, Err.Number, Err.Description, Erl
Resume ExitFunction

End Function


Private Function PopulateSummaryWorksheet(ByRef wkb As Workbook, ByRef wm As WorkbookMetrics)
Const ProcName As String = "PopulateSummaryWorksheet"
On Error GoTo ErrorHandler

Dim wks As Worksheet

Set wks = wkb.Worksheets(wksNameSum)

Dim Target As Range
Dim StartCell As Range

Dim formulas(12) As String
Dim i As Long
Dim WorkbookCount As Long

' TODO: Update formulas to handle column offset with new 'Protected' worksheet

' Each formula uses the 'Workbook Name' in Column A to calculate values in other sheets.
formulas(0) = "=COUNTIF(" & wksNameWks & "!C[-1], " & wksNameSum & "!RC[-1])" ' Worksheet
formulas(1) = "=SUMIF(" & wksNameWks & "!C[-2], " & wksNameSum & "!RC[-2], " & wksNameWks & "!C[2])" ' Formulas
formulas(2) = "=SUMIF(" & wksNameWks & "!C[-3], " & wksNameSum & "!RC[-3], " & wksNameWks & "!C[2])" ' Constants
formulas(3) = "=SUMIF(" & wksNameWks & "!C[-4], " & wksNameSum & "!RC[-4], " & wksNameWks & "!C[2])" ' Formula Errors
formulas(4) = "=SUMIF(" & wksNameWks & "!C[-5], " & wksNameSum & "!RC[-5], " & wksNameWks & "!C[2])" ' Constant Errors
formulas(5) = "=SUMIF(" & wksNameWks & "!C[-6], " & wksNameSum & "!RC[-6], " & wksNameWks & "!C[2])" ' Pivot Tables
formulas(6) = "=SUMIF(" & wksNameWks & "!C[-7], " & wksNameSum & "!RC[-7], " & wksNameWks & "!C[2])" ' Query Tables

formulas(7) = "=COUNTIFS(" & wksNameLnk & "!C[-8], " & wksNameSum & "!RC[-8], " & wksNameLnk & "!C[-7], ""Excel Link"")" ' Excel Links
formulas(8) = "=COUNTIFS(" & wksNameLnk & "!C[-9], " & wksNameSum & "!RC[-9], " & wksNameLnk & "!C[-8], ""OLE Link"")" ' OLE Links

formulas(9) = "=COUNTIF(" & wksNameHyp & "!C[-10], " & wksNameSum & "!RC[-10])" ' Hyperlinks

formulas(10) = "=COUNTIFS('" & wksNameMod & "'!C[-11], " & wksNameSum & "!RC[-11], '" & wksNameMod & "'!C[-8], "">0"")" ' VBA Modules
formulas(11) = "=SUMIF('" & wksNameMod & "'!C[-12], " & wksNameSum & "!RC[-12], '" & wksNameMod & "'!C[-9])" ' Lines of VBA Code

formulas(12) = "=SUMIF(" & wksNameWks & "!C[-13], " & wksNameSum & "!RC[-13], " & wksNameWks & "!C[-2])" ' Format Condition Cells
'/formulas(13) = "=SUMIF(" & wksNameWks & "!C[-14], " & wksNameSum & "!RC[-14], " & wksNameWks & "!C[-3])" ' Total Format Conditions


Set StartCell = GetTargetCell(wks)

StartCell.value = wm.WorkbookName
Set StartCell = StartCell.Offset(0, 1)

For i = LBound(formulas) To UBound(formulas)
Set Target = Range(StartCell, StartCell.Offset(WorkbookCount, 0))
Target.FormulaR1C1 = formulas(i)
Target.NumberFormat = CountFormat
Set StartCell = StartCell.Offset(0, 1)
Next i

wks.Columns("A:A").AutoFit

ExitFunction:
Exit Function

ErrorHandler:
log.LogError ThisWorkbook, ModName, ProcName, Err.Number, Err.Description, Erl
Resume ExitFunction

End Function

Private Function GetOutputWorkbook() As Workbook
Const ProcName As String = "GetOutputWorkbook"
On Error GoTo ErrorHandler

Dim wkb As Workbook
Dim wks As Worksheet
Dim Target As Range
Dim X As Variant
Dim i As Long

Dim sheets(0 To 7) As String
Dim headings(0 To 7) As Variant

Set wkb = Nothing

sheets(0) = wksNameSum
sheets(1) = wksNameWks
sheets(2) = wksNameMod
sheets(3) = wksNameRtn
sheets(4) = wksNameQts
sheets(5) = wksNameLnk
sheets(6) = wksNameHyp
sheets(7) = wksNameBtns


headings(0) = Array("Workbook Name", "Worksheets", "Formulas", "Constants", "Formula Errors", "Constant Errors", "Pivot Tables", "Query Tables", "Excel Links", "OLE Links", "Hyperlinks", "VBA Modules", "Lines of VBA Code", "Format Condition Cells") '/, "Total Format Conditions")
headings(1) = Array("Workbook Name", "Worksheet Name", "Visible State", "Protected", "Formulas", "Constants", "Formula Errors", "Constant Errors", "Pivot Tables", "Query Tables", "Hyperlinks", "Format Condition Cells", "Total Format Conditions", "Avg Conditions p/cell")

headings(2) = Array("Workbook Name", "Component Name", "Component Type", "Line Count")

'/headings(3) = Array("Workbook Name", "Module Name", "Procedure Name", "Type", "Scope", "Line Count")
headings(3) = Array("Workbook Name", "Module Name", "Procedure Name", "Procedure Type", "Line Count")

headings(4) = Array("Workbook Name", "Worksheet", "Table Range", "Connection Name", "Query Type", "Web Selection Type", "Parameters", "Query Name", "Connection String")
headings(5) = Array("Workbook Name", "Link Type", "Link Address", "Link Status")
headings(6) = Array("Workbook Name", "Worksheet", "Cell Address", "Link Type", "Link Name", "Link Address")
headings(7) = Array("Workbook Name", "Worksheet", "Button Type", "Button Name", "Button Text", "Button Routine")


Set wkb = Workbooks.Add

For i = LBound(sheets) To UBound(sheets)
If i = 0 Then
Set wks = wkb.Worksheets(1)
Else
Set wks = wkb.Worksheets.Add(, Worksheets(wkb.Worksheets.count))
End If

wks.Name = sheets(i)
Set Target = wks.Range("A1")

X = UBound(headings(i))
Set Target = Range(Target, Target.Offset(0, UBound(headings(i))))

Target.value = headings(i)
Target.Interior.Color = Colour.FidelityBlue
Target.Font.Color = vbWhite
Target.Font.Bold = True

Target.Columns.AutoFit

With Windows(wkb.Name)
.SplitColumn = 0
.SplitRow = 1
.FreezePanes = True
End With

Next i


ExitFunction:
Set GetOutputWorkbook = wkb
Exit Function

ErrorHandler:
log.LogError ThisWorkbook, ModName, ProcName, Err.Number, Err.Description, Erl
Resume ExitFunction

End Function



Private Function GetBounds(ByRef arr() As Variant, returncount As Long, ByRef lower As Long, ByRef upper As Long)
Const ProcName As String = "GetBounds"
On Error GoTo ErrorHandler

If returncount = 1 Then
lower = 1
upper = UBound(arr(), 1)
Else
lower = UBound(arr(), 1)
upper = UBound(arr(), 2)
End If

ExitFunction:
Exit Function

ErrorHandler:
log.LogError ThisWorkbook, ModName, ProcName, Err.Number, Err.Description, Erl
Resume ExitFunction

End Function



Private Function GetTargetCell(ByRef wks As Worksheet) As Range
Const ProcName As String = "GetTargetCell"
On Error GoTo ErrorHandler

Dim Target As Range

Set Target = wks.Range("A1")

If IsEmpty(Target.Offset(1, 0)) Then
Set Target = Target.Offset(1, 0)
Else
Set Target = Target.End(xlDown).Offset(1, 0)
End If

ExitFunction:
Set GetTargetCell = Target
Exit Function

ErrorHandler:
log.LogError ThisWorkbook, ModName, ProcName, Err.Number, Err.Description, Erl
Resume ExitFunction

End Function




' PivotTables appear to have *either* a DataSource *or* a (OLEDB/ADO) Connection
Private Function PivotDataSource(ByRef pvt As PivotTable) As String
On Error Resume Next

Dim source As String

source = pvt.SourceData

If Len(source) = 0 Then
source = pvt.PivotCache.ADOConnection
End If

PivotDataSource = source

End Function



Private Function PivotFile(ByRef pvt As PivotTable) As String
On Error Resume Next
Dim file As String

file = pvt.PivotCache.SourceDataFile

If Len(file) = 0 Then
file = pvt.Parent.Parent.Name
End If

PivotFile = file

End Function


Private Function QueryType(ByRef pvt As PivotTable) As String
Dim TypeName As String

Select Case pvt.PivotCache.QueryType
Case xlADORecordset '= 7
TypeName = "ADO Recordset"
Case xlDAORecordset '= 2
TypeName = "DAO Recordset"
Case xlODBCQuery '= 1
TypeName = "ODBC Query"
Case xlOLEDBQuery '= 5
TypeName = "OLEDB Query"
Case xlTextImport '= 6
TypeName = "Text Import"
Case xlWebQuery '= 4
TypeName = "Web Query"
Case Else
TypeName = "Unknown"
End Select

QueryType = TypeName

End Function



Public Function ProtectedSheetCount(ByRef wkb As Workbook) As Long
Const ProcName As String = "ProtectedSheetCount"
On Error GoTo ErrorHandler

Dim wks As Worksheet
Dim count As Long

For Each wks In wkb.Worksheets
If wks.ProtectContents = True Then
count = count + 1
End If
Next wks

ExitFunction:
Set wks = Nothing
ProtectedSheetCount = count
Exit Function

ErrorHandler:
log.LogError ThisWorkbook, ModName, ProcName, Err.Number, Err.Description, Erl
Resume ExitFunction

End Function



cWorksheetMetrics

​Option Explicit

Private Const ModName As String = "cWorksheetMetrics"

Private Type ConditionalFormats
CellCount As Long
TotalConditions As Long
AveragePerCell As Double
End Type

Private Enum CellTypes
eFormulas = 1
eConstants = 2
End Enum



Public Function WorksheetMetrics(ByRef wkb As Workbook, ByRef a() As Variant) As Long
Const ProcName As String = "GetWorksheetMetrics"
On Error GoTo ErrorHandler

'/Application.StatusBar = "Worksheet Metrics"

Dim wks As Worksheet
Dim FormulaCount As Long
Dim ConstantCount As Long
Dim FormulaErrorCount As Long
Dim ConstantErrorCount As Long
Dim QueryTableCount As Long
Dim HyperlinkCount As Long
Dim PivotTableCount As Long
Dim formats As ConditionalFormats
Dim i As Long

Const MaxColumns As Integer = 13
ReDim a(MaxColumns, 0)

For Each wks In wkb.Worksheets
'/Application.StatusBar = "Worksheet Metrics: " & wks.Name

ReDim Preserve a(MaxColumns, i)

If wks.ProtectContents = True Then
FormulaCount = NoValue
ConstantCount = NoValue
FormulaErrorCount = NoValue
ConstantErrorCount = NoValue
HyperlinkCount = NoValue
formats.AveragePerCell = NoValue
formats.CellCount = NoValue
formats.TotalConditions = NoValue
Else
FormulaCount = CellCount(wks, eFormulas)
ConstantCount = CellCount(wks, eConstants)

FormulaErrorCount = CellCount(wks, eFormulas, True)
ConstantErrorCount = CellCount(wks, eConstants, True)
HyperlinkCount = GetHyperlinkCount(wks)
formats = GetFormatConditionsCount(wks)
End If

QueryTableCount = wks.QueryTables.count

Dim pvt As cPivotTables
Set pvt = New cPivotTables
PivotTableCount = pvt.PivotTableCount(wks)

a(0, i) = wkb.Name
a(1, i) = wks.Name
a(2, i) = SheetVisibleEnumToString(wks.Visible)
a(3, i) = IIf(wks.ProtectContents = True, "Yes", "No")
a(4, i) = FormulaCount
a(5, i) = ConstantCount
a(6, i) = FormulaErrorCount
a(7, i) = ConstantErrorCount
a(8, i) = PivotTableCount
a(9, i) = QueryTableCount
a(10, i) = HyperlinkCount
a(11, i) = formats.CellCount
a(12, i) = formats.TotalConditions
a(13, i) = CSng(Format(formats.AveragePerCell, "0.0000"))

i = i + 1
Next wks

Set wks = Nothing

If i > 0 Then
a() = WorksheetFunction.Transpose(a())
End If

ExitFunction:
WorksheetMetrics = i
Exit Function

ErrorHandler:
log.LogError ThisWorkbook, ModName, ProcName, Err.Number, Err.Description, Erl
Resume ExitFunction

End Function


Private Function UnprotectSheet(ByRef wks As Worksheet)
On Error Resume Next
wks.Unprotect
End Function





' -- History --
' 03-Sep-2018 MS: Added error check for Overflows as I encountered a sheetr which had
' >2.1 billion conditional formats (the entire sheet had conditional format).
' Cells.count is a Long which generated an Overflow.
'
Private Function GetFormatConditionsCount(ByRef wks As Worksheet) As ConditionalFormats
Const ProcName As String = "GetFormatConditionsCount"
On Error GoTo ErrorHandler

Dim Target As Range
Dim cell As Range
Dim cf As ConditionalFormats

Set Target = wks.Cells.SpecialCells(xlCellTypeAllFormatConditions)

cf.CellCount = Target.Cells.count

For Each cell In Target.Cells
cf.TotalConditions = cf.TotalConditions + cell.FormatConditions.count
Next cell

If cf.CellCount > 0 Then
cf.AveragePerCell = cf.TotalConditions / cf.CellCount
End If

ExitFunction:
Set cell = Nothing
Set Target = Nothing
GetFormatConditionsCount = cf
Exit Function

ErrorHandler:
Select Case Err.Description
Case "Overflow"
cf.CellCount = LongMaxValue
Case "No cells were found."
' No cells with Format Conditions. Ignore and continue.

Case Else
log.LogError ThisWorkbook, ModName, ProcName, Err.Number, Err.Description, Erl
End Select

Resume ExitFunction

End Function




'Selection.SpecialCells(xlCellTypeConstants, 16).Select
'Selection.SpecialCells(xlCellTypeFormulas, 16).Select

Private Function CellCount(ByRef wks As Worksheet, CellType As CellTypes, _
Optional GetErrorCells As Boolean = False) As Long

Const ProcName As String = "GetCellCount"
On Error GoTo ErrorHandler

Dim ReturnValue As Long
Dim CellTypeEnum As Integer
Dim ValueTypeEnum As Integer

' Should we count formulas or values (constants)
If CellType = eFormulas Then
CellTypeEnum = xlCellTypeFormulas
Else
CellTypeEnum = xlCellTypeConstants
End If

' Should we count error or non-errors
If GetErrorCells = True Then
ValueTypeEnum = xlErrors
Else
ValueTypeEnum = xlLogical + xlNumbers + xlTextValues
End If

ReturnValue = wks.Cells.SpecialCells(CellTypeEnum, ValueTypeEnum).count

ExitFunction:
CellCount = ReturnValue
Exit Function

ErrorHandler:
ReturnValue = 0

If Err.Description = "No cells were found." Then
' Don't bother logging if no matching cells found
ElseIf Err.Description Like "*protected sheet*" Then
' You cannot use this command on a protected sheet.
Else
log.LogError ThisWorkbook, ModName, ProcName, Err.Number, Err.Description, Erl
End If

Resume ExitFunction

End Function


Private Function GetHyperlinkCount(ByRef wks As Worksheet) As Long
Const ProcName As String = "HyperlinkCount"
On Error GoTo ErrorHandler

Dim Target As Range
Dim cell As Range
Dim LinkCount As Long
Dim StartPos As Long

' Count Hyperlink OBJECTS
LinkCount = wks.Hyperlinks.count

' Count Hyperlink FORMULAS
Set Target = GetFormulaRange(wks)

If Not Target Is Nothing Then
For Each cell In Target.Cells
StartPos = InStr(1, cell.Formula, "HYPERLINK(")

If StartPos > 0 Then
LinkCount = LinkCount + 1
End If
Next cell
End If

ExitFunction:
GetHyperlinkCount = LinkCount
Exit Function

ErrorHandler:
log.LogError ThisWorkbook, ModName, ProcName, Err.Number, Err.Description, Erl
Resume ExitFunction

End Function

Private Function GetFormulaRange(ByRef wks As Worksheet) As Range
On Error GoTo ErrorHandler

Dim Target As Range
Set Target = wks.Cells.SpecialCells(xlCellTypeFormulas)

ExitFunction:
Set GetFormulaRange = Target
Exit Function

ErrorHandler:
Resume ExitFunction

End Function


mdlWorkbookStatistics


' www.clearlyandsimply.com/clearly_and_simply/2017/08/microsoft-excel-workbook-metrics.html
'
' Conditionally Formatted Cells: Count of cells with a conditional format
' Data Validation Cells: Count of cells with a data validation rule
' Named Ranges: count of named ranges, named ranges with #REF errors
' Charts: Count of charts (worksheet embedded charts only, i.e. without chart sheets)
' Worksheets: count of worksheets in the workbook (total, visible, hidden and very hidden).
'
Private Sub WorkbookStatistics()
    Dim FileSize As Single
    Dim Author As String
    Dim LastEditor As String
    Dim Created As Date
    Dim LastSaved As Date

    Author = ThisWorkbook.BuiltinDocumentProperties("Author")
    LastEditor = ThisWorkbook.BuiltinDocumentProperties("Last author")
    Created = ThisWorkbook.BuiltinDocumentProperties("Creation Date")
    LastSaved = ThisWorkbook.BuiltinDocumentProperties("Last Save Time")
    FileSize = FileLen(ThisWorkbook.FullName)

    Debug.Print Format(FileSize / 1024, "#,##0") & " Kb"
End Sub

ModName 14

CODE GOES HERE

>