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