VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "MigrationAnalyser" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False '************************************************************************* ' ' Licensed to the Apache Software Foundation (ASF) under one ' or more contributor license agreements. See the NOTICE file ' distributed with this work for additional information ' regarding copyright ownership. The ASF licenses this file ' to you under the Apache License, Version 2.0 (the ' "License"); you may not use this file except in compliance ' with the License. You may obtain a copy of the License at ' ' http://www.apache.org/licenses/LICENSE-2.0 ' ' Unless required by applicable law or agreed to in writing, ' software distributed under the License is distributed on an ' "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY ' KIND, either express or implied. See the License for the ' specific language governing permissions and limitations ' under the License. ' '************************************************************************* Option Explicit Const CWORKBOOK_SHEETS_LIMIT = 256 'Class variables Private Enum HFIssueType hfInline hfShape hfFrame End Enum Private Enum HFIssueLocation hfHeader hfFooter End Enum Private Type CellAtrributes LineStyle As Integer FillPattern As Integer End Type Private Type BadSheetNameChar BadChar As String Position As Integer End Type Private mAnalysis As DocumentAnalysis Private mFileName As String Const RID_STR_EXCEL_SUBISSUE_ERROR_TYPE = "ERROR.TYPE" Const RID_STR_EXCEL_SUBISSUE_INFO = "INFO" Const RID_STR_EXCEL_SUBISSUE_DATEDIF = "DATEDIF" Const RID_STR_EXCEL_SUBISSUE_PHONETIC = "PHONETIC" Const FontError = 94 Const CR_BADCHAR = "" Const CR_BADCHARNUM = "" Const DATA_SOURCE_EXCEL = 0 Const DATA_SOURCE_EXTERNAL = 1 Const DATA_SOURCE_MULTIPLE = 2 Const DATA_SOURCE_EXTERNAL_FILE = 3 Const C_MAX_CELL_RANGE_COUNT = 10000 Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) '***ADDING-ISSUE: Use Following Skeleton as Guideline for Adding Issue ' For complete list of all RID_STR_... for Issues (IssueType), SubIssues (SubType) and Attributes refer to: ' excel_res.bas and common_res.bas ' ' For complete list of all CID_... for Issue Categories(IssueID) and ' CSTR_... for XML Issues (IssueTypeXML) and XML SubIssues (SubTypeXML) refer to: ' ApplicationSpecific.bas and CommonMigrationAnalyser.bas ' ' You should not have to add any new Issue Categories or matching IssueTypes, only new SubIssues Sub Analyze_SKELETON() On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_SKELETON" Dim myIssue As IssueInfo Set myIssue = New IssueInfo With myIssue .IssueID = CID_VBA_MACROS 'Issue Category .IssueType = RID_STR_COMMON_ISSUE_VBA_MACROS 'Issue String .SubType = RID_STR_COMMON_SUBISSUE_PROPERTIES 'SubIssue String .Location = .CLocationDocument 'Location string .IssueTypeXML = CSTR_ISSUE_VBA_MACROS 'Non localised XML Issue String .SubTypeXML = CSTR_SUBISSUE_PROPERTIES 'Non localised XML SubIssue String .locationXML = .CXMLLocationDocument 'Non localised XML location .SubLocation = 0 'if not set will default to RID_STR_NOT_AVAILABLE_SHORTHAND .Line = 0 'if not set will default to RID_STR_NOT_AVAILABLE_SHORTHAND .column = 0 'if not set will default to RID_STR_NOT_AVAILABLE_SHORTHAND ' Add as many Attribute Value pairs as needed ' Note: following must always be true - Attributes.Count = Values.Count .Attributes.Add "AAA" .Values.Add "foobar" ' Use AddIssueDetailsNote to add notes to the Issue Details if required ' Public Sub AddIssueDetailsNote(myIssue As IssueInfo, noteNum As Long, noteStr As String, _ ' Optional preStr As String = RID_STR_COMMON_NOTE_PRE) ' Where preStr is prepended to the output, with "Note" as the default AddIssueDetailsNote myIssue, 0, RID_STR_COMMON_NOTE_DOCUMENT_PROPERTIES_LOST mAnalysis.IssuesCountArray(CID_VBA_MACROS) = _ mAnalysis.IssuesCountArray(CID_VBA_MACROS) + 1 End With mAnalysis.Issues.Add myIssue FinalExit: Set myIssue = Nothing Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Sub Sub DoAnalyse(fileName As String, userFormTypesDict As Scripting.Dictionary, _ startDir As String, storeToDir As String, fso As FileSystemObject) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "DoAnalyse" 'Dim secAutomation As MsoAutomationSecurity 'secAutomation = Application.AutomationSecurity mAnalysis.name = fileName Dim aWB As Workbook mAnalysis.TotalIssueTypes = CTOTAL_CATEGORIES 'Make Excel run as non interactively as possible Application.EnableEvents = False Application.DisplayAlerts = False Application.Interactive = False Application.AskToUpdateLinks = False Application.EnableAnimations = False Application.EnableSound = False 'Only supported in Office XP and above 'Application.AutomationSecurity = msoAutomationSecurityForceDisable 'mFileName = fso.GetFileName(fileName) 'WriteToLog "TmpDebug1", mFileName Dim myPassword As String myPassword = GetDefaultPassword If myPassword = "" Then myPassword = "xoxoxoxoxo" End If Set aWB = Workbooks.Open(fileName:=fileName, _ Password:=myPassword, _ WriteResPassword:=myPassword, _ UpdateLinks:=0) 'Application.AutomationSecurity = secAutomation 'Do Analysis Analyze_Password_Protection aWB Analyze_Workbook_Protection aWB 'Set Doc Properties SetDocProperties mAnalysis, aWB, fso Analyze_SheetLimits aWB Analyze_SheetDisplay aWB Analyze_SheetIssues aWB Analyze_SheetCharts aWB Analyze_WorkbookVersion aWB Analyze_Macros mAnalysis, userFormTypesDict, aWB ' Doc Preparation only ' Save document with any fixed issues under \prepared\ If mAnalysis.PreparableIssuesCount > 0 And CheckDoPrepare Then Dim preparedFullPath As String preparedFullPath = GetPreparedFullPath(mAnalysis.name, startDir, storeToDir, fso) If preparedFullPath <> "" Then If fso.FileExists(preparedFullPath) Then fso.DeleteFile preparedFullPath, True End If If fso.FolderExists(fso.GetParentFolderName(preparedFullPath)) Then If IsOldVersion(aWB.FileFormat) Then aWB.SaveAs fileName:=preparedFullPath, FileFormat:=xlExcel9795 Else aWB.SaveAs preparedFullPath End If End If End If End If FinalExit: If Not aWB Is Nothing Then aWB.Close (False) End If Set aWB = Nothing Application.EnableEvents = True Application.DisplayAlerts = True Application.Interactive = True Application.AskToUpdateLinks = True Application.EnableAnimations = True Application.EnableSound = True 'Debug - Call Sleep(5000) Exit Sub HandleErrors: ' MsgBox currentFunctionName & " : " & fileName & ": " & Err.Number & " " & Err.Description & " " & Err.Source ' Handle Password error on Doc Open, Modify and Cancel If Err.Number = 1004 Then WriteDebug currentFunctionName & " : " & fileName & ": " & _ "User entered Invalid Document Password - " & Err.Number & " " & Err.Description & " " & Err.Source HandleProtectedDocInvalidPassword mAnalysis, _ "User entered Invalid Document Password, further analysis not possible", fso Resume FinalExit End If mAnalysis.Application = RID_STR_COMMON_CANNOT_OPEN WriteDebug currentFunctionName & " : " & fileName & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Sub Sub Analyze_SheetCharts(aWB As Workbook) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_SheetCharts" Dim myChartSheet As Chart For Each myChartSheet In aWB.Charts SetChartIssueMinor myChartSheet, myChartSheet.name, False SetChartIssueComplex myChartSheet, myChartSheet.name Next myChartSheet Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source End Sub Sub Analyze_EmbeddedCharts(mySheet As Worksheet) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_EmbeddedCharts" Dim BorderIssue As Boolean Dim index As Integer BorderIssue = False Dim chartcount As Integer Dim myChart As Chart chartcount = mySheet.ChartObjects.count For index = 1 To chartcount BorderIssue = False With mySheet.ChartObjects(index) If .Border.LineStyle <> xlLineStyleNone Then BorderIssue = True End If SetChartIssueMinor .Chart, mySheet.name, BorderIssue 'If Not ((.ChartType = xlSurface) _ ' And (.ChartType = xlSurfaceTopViewWireframe) _ ' And (.ChartType = xlSurfaceTopView)) Then SetChartIssueComplex .Chart, mySheet.name 'End If End With Next index Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source End Sub Private Function getType(o As Variant) As Integer If (VarType(o) = vbString) Then Dim aDataSource As String aDataSource = o getType = DATA_SOURCE_EXCEL If (Len(aDataSource) > 0) Then Dim nBackslashPos As Long nBackslashPos = InStr(Trim(aDataSource), "\") If (nBackslashPos > 0 And nBackslashPos < 4) Then getType = DATA_SOURCE_EXTERNAL_FILE End If End If ElseIf (IsArray(o)) Then If (hasSecondDimension(o)) Then getType = DATA_SOURCE_MULTIPLE Else getType = DATA_SOURCE_EXTERNAL End If End If End Function Private Function hasSecondDimension(o2 As Variant) As Boolean On Error GoTo njet Dim temp As Integer temp = UBound(o2, 2) hasSecondDimension = True Exit Function njet: hasSecondDimension = False End Function Private Sub Analyze_PivotTable(myIssue As IssueInfo, myPivotTable As PivotTable) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyse_PivotTable" Dim aPivotField As PivotField Dim aNoteCount As Long Dim bManualSort As Boolean Dim bCalculatedValues As Boolean Dim aSorting As XlSortOrder Dim nCount As Integer Dim nDataSource As Integer bManualSort = False bCalculatedValues = False For Each aPivotField In myPivotTable.PivotFields aSorting = xlAscending On Error Resume Next 'some fields don't have any property at all aSorting = aPivotField.AutoSortOrder On Error GoTo HandleErrors If (aSorting = xlManual) Then bManualSort = True End If nCount = 0 On Error Resume Next 'some fields don't have any property at all nCount = aPivotField.CalculatedItems.count On Error GoTo HandleErrors If (nCount > 0) Then bCalculatedValues = True End If Next nCount = 0 On Error Resume Next 'some fields don't have any property at all nCount = myPivotTable.CalculatedFields.count On Error GoTo HandleErrors If (nCount > 0) Then bCalculatedValues = True End If nDataSource = getType(myPivotTable.SourceData) aNoteCount = 0 If (bManualSort) Then AddIssueDetailsNote myIssue, aNoteCount, RID_RESXLT_COST_PIVOT_ManSort_Comment aNoteCount = aNoteCount + 1 End If If (nDataSource = DATA_SOURCE_EXTERNAL) Then AddIssueDetailsNote myIssue, aNoteCount, RID_RESXLT_COST_PIVOT_ExternData_Comment aNoteCount = aNoteCount + 1 ElseIf (nDataSource = DATA_SOURCE_MULTIPLE) Then AddIssueDetailsNote myIssue, aNoteCount, RID_RESXLT_COST_PIVOT_MultConsRanges_Comment aNoteCount = aNoteCount + 1 ElseIf (nDataSource = DATA_SOURCE_EXTERNAL_FILE) Then Dim noteString As String noteString = RID_RESXLT_COST_PIVOT_ExternData_Comment & "[" & _ myPivotTable.SourceData & "]" AddIssueDetailsNote myIssue, aNoteCount, noteString aNoteCount = aNoteCount + 1 End If If (bCalculatedValues) Then AddIssueDetailsNote myIssue, aNoteCount, RID_RESXLT_COST_PIVOT_CalcVal_Comment aNoteCount = aNoteCount + 1 End If FinalExit: Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Sub Private Sub SetChartIssueComplex(myChart As Chart, myName As String) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "SetChartIssueComplex" Dim myIssue As IssueInfo Dim bSeriesChartTypeChanged As Boolean Dim bDatasourceNotLinkedtoCell As Boolean Dim bDatasourceOnDifferentSheet As Boolean Dim bCategoryandValue As Boolean Dim bCLabelMorethanOneCell As Boolean Dim bOneColumnRow As Boolean Dim bDataTable As Boolean Dim bXAxes As Boolean Dim bseries As Boolean Dim bformat As Boolean Dim bpivot As Boolean Set myIssue = New IssueInfo bSeriesChartTypeChanged = False bDatasourceNotLinkedtoCell = False bDatasourceOnDifferentSheet = False bCategoryandValue = False bCLabelMorethanOneCell = False bOneColumnRow = False bDataTable = False bXAxes = False bformat = FormatIssueComplex(myChart, bDataTable, bXAxes) bseries = SeriesIssue(myChart, bSeriesChartTypeChanged, bDatasourceNotLinkedtoCell, bDatasourceOnDifferentSheet, bCategoryandValue, bCLabelMorethanOneCell, bOneColumnRow) bpivot = Not (myChart.PivotLayout Is Nothing) If (Not (bseries Or bformat Or bpivot)) Then GoTo FinalExit ElseIf bpivot Then With myIssue .IssueID = CID_CHARTS_TABLES .IssueType = RID_STR_EXCEL_ISSUE_CHARTS_AND_TABLES .SubType = RID_STR_EXCEL_SUBISSUE_PIVOT .Location = .CLocationSheet .SubLocation = myName .IssueTypeXML = CSTR_ISSUE_CHARTS_TABLES .SubTypeXML = CSTR_SUBISSUE_CHART_PIVOT .locationXML = .CXMLLocationSheet .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_PIVOT_TABLE_NAME .Values.Add myChart.PivotLayout.PivotTable.name .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_PIVOT_FIELDS_VISIBLE .Values.Add myChart.HasPivotFields .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_PIVOT_FIELDS_NUM .Values.Add myChart.PivotLayout.PivotTable.PivotFields.count .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_TYPE .Values.Add getChartTypeAsString(myChart.ChartType) .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_CHARTNAME .Values.Add myChart.name End With AddIssueDetailsNote myIssue, 0, RID_RESXLT_COST_PIVOT_PivotChart_Comment mAnalysis.IssuesCountArray(CID_CHARTS_TABLES) = _ mAnalysis.IssuesCountArray(CID_CHARTS_TABLES) + 1 mAnalysis.Issues.Add myIssue GoTo FinalExit Else With myIssue Dim NoteIndex As Long NoteIndex = 0 .IssueID = CID_CHARTS_TABLES .IssueType = RID_STR_EXCEL_ISSUE_CHARTS_AND_TABLES .SubType = RID_STR_EXCEL_SUBISSUE_CHART_COMPLEX .Location = .CLocationSheet .SubLocation = myName .IssueTypeXML = CSTR_ISSUE_CHARTS_TABLES .SubTypeXML = CSTR_SUBISSUE_CHART_COMPLEX .locationXML = .CXMLLocationSheet If bDataTable Then .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_DATATABLE .Values.Add RID_STR_EXCEL_ATTRIBUTE_SET AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_DATATABLE NoteIndex = NoteIndex + 1 End If If bXAxes Then .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_XAXISCATEGORY .Values.Add RID_STR_EXCEL_ATTRIBUTE_TIMESCALE AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_XAXISCATEGORY NoteIndex = NoteIndex + 1 End If If bSeriesChartTypeChanged Then .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_SERIESCHARTTYPE .Values.Add RID_STR_EXCEL_ATTRIBUTE_CHANGED AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_SERIESCHARTTYPE NoteIndex = NoteIndex + 1 End If If bDatasourceNotLinkedtoCell Then .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_DATASOURCE .Values.Add RID_STR_EXCEL_ATTRIBUTE_DATASOURCENOTLINKEDTOCELL AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_DATASOURCENOTLINKEDTOCELL NoteIndex = NoteIndex + 1 End If If bDatasourceOnDifferentSheet Then .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_DATASOURCE .Values.Add RID_STR_EXCEL_ATTRIBUTE_DATASOURCEONDIFFERENTSHEET AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_DATASOURCEONDIFFERENTSHEET NoteIndex = NoteIndex + 1 End If If bCategoryandValue Then .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_CATEGORYANDDATA .Values.Add RID_STR_EXCEL_ATTRIBUTE_SEPARATE AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_CATEGORYANDDATA NoteIndex = NoteIndex + 1 End If If bCLabelMorethanOneCell Then .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_CATEGORYLABEL .Values.Add RID_STR_EXCEL_ATTRIBUTE_CATEGORYLABELMORETHANONECELL AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_CATEGORYLABELMORETHANONECELL NoteIndex = NoteIndex + 1 End If If bOneColumnRow Then .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_COLUMNBAR .Values.Add RID_STR_EXCEL_ATTRIBUTE_ONECOLUMNROW AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_COLUMNBAR NoteIndex = NoteIndex + 1 End If .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_TYPE .Values.Add getChartTypeAsString(myChart.ChartType) .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_CHARTNAME .Values.Add myChart.name End With mAnalysis.IssuesCountArray(CID_CHARTS_TABLES) = _ mAnalysis.IssuesCountArray(CID_CHARTS_TABLES) + 1 mAnalysis.Issues.Add myIssue End If FinalExit: Set myIssue = Nothing Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Sub Private Sub SetChartIssueMinor(myChart As Chart, myName As String, BorderIssue As Boolean) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "SetChartIssueMinor" Dim myIssue As IssueInfo Dim bUnsupportedType As Boolean Dim bTrendline As Boolean Dim bDatalabelWithLegend As Boolean Dim bLegendPosition As Boolean Dim bTitleFont As Boolean Dim bPiechartDirection As Boolean Dim bAxisInterval As Boolean Set myIssue = New IssueInfo bUnsupportedType = False bTrendline = False bDatalabelWithLegend = False bLegendPosition = False bTitleFont = False bPiechartDirection = False bAxisInterval = False If (Not FormatissueMinor(myChart, bUnsupportedType, bTrendline, bDatalabelWithLegend, bLegendPosition, bTitleFont, bPiechartDirection, bAxisInterval)) And (Not BorderIssue) Then GoTo FinalExit Else With myIssue Dim NoteIndex As Long NoteIndex = 0 .IssueID = CID_CHARTS_TABLES .IssueType = RID_STR_EXCEL_ISSUE_CHARTS_AND_TABLES .SubType = RID_STR_EXCEL_SUBISSUE_CHART_MINOR .Location = .CLocationSheet .SubLocation = myName .IssueTypeXML = CSTR_ISSUE_CHARTS_TABLES .SubTypeXML = CSTR_SUBISSUE_CHART_PIVOT .locationXML = .CXMLLocationSheet If bUnsupportedType Then .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_UNSUPPORTEDTYPE .Values.Add getChartTypeAsString(myChart.ChartType) ' bubble chart If (myChart.ChartType = xlBubble Or myChart.ChartType = xlBubble3DEffect) Then AddIssueDetailsNote myIssue, NoteIndex, RID_RESXLT_COST_CHART_Bubble_Comment ' bar of pie and pie of pie chart ElseIf (myChart.ChartType = xlPieOfPie Or myChart.ChartType = xlBarOfPie) Then AddIssueDetailsNote myIssue, NoteIndex, RID_RESXLT_COST_CHART_BarOfPie_Comment ' Scatter chart ElseIf (myChart.ChartType = xlXYScatter Or myChart.ChartType = xlXYScatterLines _ Or myChart.ChartType = xlXYScatterLinesNoMarkers _ Or myChart.ChartType = xlXYScatterSmooth _ Or myChart.ChartType = xlXYScatterSmoothNoMarkers) Then AddIssueDetailsNote myIssue, NoteIndex, RID_RESXLT_COST_CHART_Scattered_Comment ' radar chart ElseIf (myChart.ChartType = xlRadarMarkers Or myChart.ChartType = xlRadar) Then AddIssueDetailsNote myIssue, NoteIndex, RID_RESXLT_COST_CHART_Radar_Comment ' radar filled chart ElseIf (myChart.ChartType = xlRadarFilled) Then AddIssueDetailsNote myIssue, NoteIndex, RID_RESXLT_COST_CHART_FilledRadar_Comment ' surface chart ElseIf (myChart.ChartType = xlSurface Or myChart.ChartType = xlSurfaceTopView _ Or myChart.ChartType = xlSurfaceTopViewWireframe _ Or myChart.ChartType = xlSurfaceWireframe) Then AddIssueDetailsNote myIssue, NoteIndex, RID_RESXLT_COST_CHART_Surface_Comment Else AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_UNSUPPORTEDTYPE1 NoteIndex = NoteIndex + 1 AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_UNSUPPORTEDTYPE2 End If NoteIndex = NoteIndex + 1 End If If bTrendline Then .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_TRENDLINE .Values.Add RID_STR_EXCEL_ATTRIBUTE_SET AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_TRENDLINE NoteIndex = NoteIndex + 1 End If If bDatalabelWithLegend Then .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_DATALABELWITHLEGEND .Values.Add RID_STR_EXCEL_ATTRIBUTE_SET AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_DATALABELWITHLEGEND NoteIndex = NoteIndex + 1 End If If bLegendPosition Then .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_LEGENDPOSITION .Values.Add RID_STR_EXCEL_ATTRIBUTE_NOTRIGHT AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_LEGENDPOSITION NoteIndex = NoteIndex + 1 End If If bTitleFont Then .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_TITLEFONT .Values.Add RID_STR_EXCEL_ATTRIBUTE_DIFFERENT AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_TITLEFONT NoteIndex = NoteIndex + 1 End If If bPiechartDirection Then .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_PIE .Values.Add RID_STR_EXCEL_ATTRIBUTE_SLICES_IN_DIFFERENT_DIRECTION End If If BorderIssue Then .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_BORDER .Values.Add RID_STR_EXCEL_ATTRIBUTE_SET AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_BORDER NoteIndex = NoteIndex + 1 End If If bAxisInterval Then .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_AXISINTERVAL .Values.Add RID_STR_EXCEL_ATTRIBUTE_AUTO AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_AXISINTERVAL NoteIndex = NoteIndex + 1 End If .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_CHARTNAME .Values.Add myChart.name End With mAnalysis.IssuesCountArray(CID_CHARTS_TABLES) = _ mAnalysis.IssuesCountArray(CID_CHARTS_TABLES) + 1 mAnalysis.Issues.Add myIssue End If FinalExit: Set myIssue = Nothing Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Sub Sub SetChartIssue(myChart As Chart, myName As String, strSubType As String, _ strXMLSubType As String) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "SetChartIssue" Dim myIssue As IssueInfo Dim bUnsupportedPosition As Boolean Set myIssue = New IssueInfo ' Common Settings With myIssue .IssueID = CID_CHARTS_TABLES .IssueType = RID_STR_EXCEL_ISSUE_CHARTS_AND_TABLES .SubType = strSubType .Location = .CLocationSheet .SubLocation = myName .IssueTypeXML = CSTR_ISSUE_CHARTS_TABLES .SubTypeXML = strXMLSubType .locationXML = .CXMLLocationSheet If myChart.HasTitle Then .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_TITLE .Values.Add myChart.chartTitle.Text End If .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_TYPE .Values.Add myChart.ChartType 'TBD - getChartTypeAsString() convert to String 'Pie Chart If (myChart.ChartType = xlPie) Or _ (myChart.ChartType = xlPieExploded) Or _ (myChart.ChartType = xlPieOfPie) Or _ (myChart.ChartType = xl3DPie) Or _ (myChart.ChartType = xl3DPieExploded) Then .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_PIE .Values.Add RID_STR_EXCEL_ATTRIBUTE_SLICES_IN_DIFFERENT_DIRECTION End If If Not myChart.PivotLayout Is Nothing Then 'Pivot Chart .SubType = RID_STR_EXCEL_SUBISSUE_PIVOT & " " & strSubType 'Pivot Chart details .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_PIVOT_TABLE_NAME .Values.Add myChart.PivotLayout.PivotTable.name .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_PIVOT_FIELDS_VISIBLE .Values.Add myChart.HasPivotFields .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_PIVOT_FIELDS_NUM .Values.Add myChart.PivotLayout.PivotTable.PivotFields.count End If End With mAnalysis.IssuesCountArray(CID_CHARTS_TABLES) = _ mAnalysis.IssuesCountArray(CID_CHARTS_TABLES) + 1 mAnalysis.Issues.Add myIssue FinalExit: Set myIssue = Nothing Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Sub Function getLineStyleAsString(myLineStyle As XlLineStyle) As String On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "getLineStyleAsString" Dim strVal As String Select Case myLineStyle Case xlContinuous strVal = RID_STR_EXCEL_ENUMERATION_LINE_STYLE_CONTINUOUS Case xlDash strVal = RID_STR_EXCEL_ENUMERATION_LINE_STYLE_DASH Case xlDashDot strVal = RID_STR_EXCEL_ENUMERATION_LINE_STYLE_DASHDOT Case xlDot strVal = RID_STR_EXCEL_ENUMERATION_LINE_STYLE_DOT Case xlDouble strVal = RID_STR_EXCEL_ENUMERATION_LINE_STYLE_DOUBLE Case xlSlantDashDot strVal = RID_STR_EXCEL_ENUMERATION_LINE_STYLE_SLANTDASHDOT Case xlLineStyleNone strVal = RID_STR_EXCEL_ENUMERATION_LINE_STYLE_LINESTYLENONE Case Else strVal = RID_STR_EXCEL_ENUMERATION_UNKNOWN End Select getLineStyleAsString = strVal HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source End Function Function getChartTypeAsString(myChartType As XlChartType) As String '********************************************************* '**** Localisation: ON HOLD ****************************** '********************************************************* On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "getChartTypeAsString" Dim strVal As String Select Case myChartType Case xl3DArea strVal = "3DArea" Case xl3DAreaStacked strVal = "3DAreaStacked" Case xl3DAreaStacked100 strVal = "3DAreaStacked100" Case xl3DBarClustered strVal = "3DBarClustered" Case xl3DBarStacked strVal = "xl3DBarStacked" Case xl3DBarStacked100 strVal = "xl3DBarStacked100" Case xl3DColumn strVal = "3DColumn" Case xl3DColumnClustered strVal = "xl3DColumnClustered" Case xl3DColumnStacked strVal = "xl3DColumnStacked" Case xl3DColumnStacked100 strVal = "xl3DColumnStacked100" Case xl3DLine strVal = "3DLine" Case xl3DPie strVal = "3DPie" Case xl3DPieExploded strVal = "3DPieExploded" Case xlArea strVal = "Area" Case xlAreaStacked strVal = "AreaStacked" Case xlAreaStacked100 strVal = "AreaStacked100" Case xlBarClustered strVal = "BarClustered" Case xlBarOfPie strVal = "BarOfPie" Case xlBarStacked strVal = "BarStacked" Case xlBarStacked100 strVal = "BarStacked100" Case xlBubble strVal = "Bubble" Case xlBubble3DEffect strVal = "Bubble3DEffect" Case xlColumnClustered strVal = "ColumnClustered" Case xlColumnStacked strVal = "ColumnStacked" Case xlColumnStacked100 strVal = "ColumnStacked100" Case xlConeBarClustered strVal = "ConeBarClustered" Case xlConeBarStacked strVal = "ConeBarStacked" Case xlConeBarStacked100 strVal = "ConeBarStacked100" Case xlConeCol strVal = "ConeCol" Case xlConeColClustered strVal = "ConeColClustered" Case xlConeColStacked strVal = "ConeColStacked" Case xlConeColStacked100 strVal = "ConeColStacked100" Case xlCylinderBarClustered strVal = "CylinderBarClustered" Case xlCylinderBarStacked strVal = "CylinderBarStacked" Case xlCylinderBarStacked100 strVal = "CylinderBarStacked100" Case xlCylinderCol strVal = "CylinderCol" Case xlCylinderColClustered strVal = "CylinderColClustered" Case xlCylinderColStacked strVal = "CylinderColStacked" Case xlCylinderColStacked100 strVal = "CylinderColStacked100" Case xlDoughnut strVal = "Doughnut" Case xlLine strVal = "Line" Case xlLineMarkers strVal = "LineMarkers" Case xlLineMarkersStacked strVal = "LineMarkersStacked" Case xlLineMarkersStacked100 strVal = "LineMarkersStacked100" Case xlLineStacked strVal = "LineStacked" Case xlLineStacked100 strVal = "LineStacked100" Case xlPie strVal = "Pie" Case xlPieExploded strVal = "PieExploded" Case xlPieOfPie strVal = "PieOfPie" Case xlPyramidBarClustered strVal = "PyramidBarClustered" Case xlPyramidBarStacked strVal = "PyramidBarStacked" Case xlPyramidBarStacked100 strVal = "PyramidBarStacked100" Case xlPyramidCol strVal = "PyramidCol" Case xlPyramidColClustered strVal = "PyramidColClustered" Case xlPyramidColStacked strVal = "PyramidColStacked" Case xlPyramidColStacked100 strVal = "PyramidColStacked100" Case xlRadar strVal = "Radar" Case xlRadarFilled strVal = "RadarFilled" Case xlRadarMarkers strVal = "RadarMarkers" Case xlStockHLC strVal = "StockHLC" Case xlStockOHLC strVal = "StockOHLC" Case xlStockVHLC strVal = "StockVHLC" Case xlStockVOHLC strVal = "StockVOHLC" Case xlSurface strVal = "Surface" Case xlSurfaceTopView strVal = "SurfaceTopView" Case xlSurfaceTopViewWireframe strVal = "SurfaceTopViewWireframe" Case xlSurfaceWireframe strVal = "SurfaceWireframe" Case xlXYScatter strVal = "XYScatter" Case xlXYScatterLines strVal = "XYScatterLines" Case xlXYScatterLinesNoMarkers strVal = "XYScatterLinesNoMarkers" Case xlXYScatterSmooth strVal = "XYScatterSmooth" Case xlXYScatterSmoothNoMarkers strVal = "XYScatterSmoothNoMarkers" Case Else strVal = RID_STR_EXCEL_ENUMERATION_UNKNOWN End Select getChartTypeAsString = strVal Exit Function HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source End Function Sub HandleZoomIssue(currentSheet) Dim myIssue As IssueInfo Dim currentFunctionName As String currentFunctionName = "HandleZoomIssue" On Error GoTo HandleErrors Set myIssue = New IssueInfo With myIssue .IssueID = CID_FORMAT .IssueType = RID_STR_EXCEL_ISSUE_FORMAT .SubType = RID_STR_EXCEL_SUBISSUE_ZOOM .Location = .CLocationSheet .SubLocation = currentSheet.name .IssueTypeXML = CSTR_ISSUE_FORMAT .SubTypeXML = CSTR_SUBISSUE_ZOOM .locationXML = .CXMLLocationSheet AddIssueDetailsNote myIssue, 0, RID_STR_EXCEL_NOTE_ZOOM End With mAnalysis.IssuesCountArray(CID_FORMAT) = _ mAnalysis.IssuesCountArray(CID_FORMAT) + 1 mAnalysis.Issues.Add myIssue FinalExit: Set myIssue = Nothing Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Sub Sub Analyze_SheetDisplay(aWB As Workbook) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_SheetDisplay" If aWB.Sheets.count = 1 Then Exit Sub Dim lastZoomVal As Integer Dim bInitZoom As Boolean Dim bZoomChanged As Boolean Dim ws As Object bInitZoom = True bZoomChanged = False For Each ws In aWB.Sheets ws.Activate On Error GoTo HandleErrors If bInitZoom Then lastZoomVal = ActiveWindow.Zoom bInitZoom = False ElseIf Not bZoomChanged Then If ActiveWindow.Zoom <> lastZoomVal Then bZoomChanged = True HandleZoomIssue ws End If End If If bZoomChanged Then Exit For Next ws FinalExit: Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Sub Sub Analyze_SheetLimits(aWB As Workbook) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_SheetLimits" Dim myIssue As IssueInfo If aWB.Sheets.count < CWORKBOOK_SHEETS_LIMIT + 1 Then Exit Sub Set myIssue = New IssueInfo With myIssue .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES .SubType = RID_STR_EXCEL_SUBISSUE_MAX_SHEETS_EXCEEDED .Location = .CLocationWorkBook .SubLocation = aWB.name .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES .SubTypeXML = CSTR_SUBISSUE_MAX_SHEETS_EXCEEDED .locationXML = .CXMLLocationWorkBook .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_NUMBER_OF_SHEETS .Values.Add aWB.Sheets.count AddIssueDetailsNote myIssue, 0, RID_STR_EXCEL_NOTE_SHEET_LIMITS_1 & CWORKBOOK_SHEETS_LIMIT AddIssueDetailsNote myIssue, 1, RID_STR_EXCEL_NOTE_SHEET_LIMITS_2 & CWORKBOOK_SHEETS_LIMIT End With mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _ mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1 mAnalysis.Issues.Add myIssue Set myIssue = Nothing FinalExit: Set myIssue = Nothing Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Sub Sub Analyze_SheetIssues(aWB As Workbook) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_SheetIssues" Dim myWrkSheet As Worksheet For Each myWrkSheet In aWB.Worksheets Analyze_OLEEmbedded myWrkSheet Analyze_CellInSheetIssues myWrkSheet Analyze_EmbeddedCharts myWrkSheet Analyze_SheetName myWrkSheet Analyze_QueryTables myWrkSheet Next myWrkSheet Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source End Sub Sub Analyze_SheetName(mySheet As Worksheet) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_SheetName" Dim myIssue As IssueInfo Set myIssue = New IssueInfo Dim invalidCharacters As String invalidCharacters = InvalidSheetNameCharacters(mySheet.name) If Len(invalidCharacters) <> 0 Then With myIssue .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES .SubType = RID_STR_EXCEL_SUBISSUE_INVALID_WORKSHEET_NAME .Location = .CLocationSheet .SubLocation = mySheet.name .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES .SubTypeXML = CSTR_SUBISSUE_INVALID_WORKSHEET_NAME .locationXML = .CXMLLocationSheet .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_INVALIDCHARACTER .Values.Add invalidCharacters AddIssueDetailsNote myIssue, 0, RID_STR_EXCEL_NOTE_INVALIDWORKSHEETNAME mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _ mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1 End With mAnalysis.Issues.Add myIssue End If FinalExit: Set myIssue = Nothing Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Sub Function InvalidSheetNameCharacters(aName As String) As String On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "InvalidSheetNameCharacters" Dim I As Integer Dim NameCount As Integer Dim newBadCharLine As String Dim invalidCharacterDetails As String Dim BadCharPosition As String Dim theBadChars As BadSheetNameChar NameCount = Len(aName) invalidCharacterDetails = "" For I = 1 To NameCount theBadChars.BadChar = Mid(aName, I, 1) theBadChars.Position = I BadCharPosition = CStr(theBadChars.Position) Select Case theBadChars.BadChar Case "[", "]", "{", "}", ".", "!", "%", "$", "^", ".", "&", "(", ")", _ "-", "=", "+", "~", "#", "@", "'", ";", "<", ">", ",", "|", "`" newBadCharLine = ReplaceTopic2Tokens(RID_STR_EXCEL_ATTRIBUTE_BADCHARACTER, CR_BADCHAR, _ theBadChars.BadChar, CR_BADCHARNUM, BadCharPosition) invalidCharacterDetails = invalidCharacterDetails + newBadCharLine + ", " Case Else End Select Next I If Len(invalidCharacterDetails) > 0 Then InvalidSheetNameCharacters = Left(invalidCharacterDetails, (Len(invalidCharacterDetails) - 2)) Else InvalidSheetNameCharacters = "" End If Exit Function HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source End Function Sub Analyze_QueryTables(mySheet As Worksheet) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_QueryTables" Dim aTable As QueryTable Dim myIssue As IssueInfo Set myIssue = New IssueInfo For Each aTable In mySheet.QueryTables If (aTable.QueryType = xlADORecordset) Or _ (aTable.QueryType = xlDAORecordSet) Or _ (aTable.QueryType = xlODBCQuery) Or _ (aTable.QueryType = xlOLEDBQuery) Then With myIssue .IssueID = CID_CHARTS_TABLES .IssueType = RID_STR_EXCEL_ISSUE_CHARTS_AND_TABLES .SubType = RID_RESXLS_COST_DB_Query .Location = .CLocationSheet .SubLocation = mySheet.name .IssueTypeXML = CSTR_ISSUE_CHARTS_TABLES .SubTypeXML = CSTR_SUBISSUE_DB_QUERY .locationXML = .CXMLLocationSheet .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_DB_QUERY .Values.Add aTable.Connection AddIssueDetailsNote myIssue, 0, RID_STR_EXCEL_NOTE_DB_QUERY mAnalysis.IssuesCountArray(CID_CHARTS_TABLES) = _ mAnalysis.IssuesCountArray(CID_CHARTS_TABLES) + 1 End With mAnalysis.Issues.Add myIssue End If Next aTable FinalExit: Set myIssue = Nothing Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Sub Sub Analyze_WorkbookVersion(aWB As Workbook) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_WorkbookVersion" Dim myIssue As IssueInfo Set myIssue = New IssueInfo Dim aProp As Variant If IsOldVersion(aWB.FileFormat) Then With myIssue .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES .SubType = RID_STR_EXCEL_SUBISSUE_OLD_WORKBOOK_VERSION .Location = .CLocationWorkBook .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES .SubTypeXML = CSTR_SUBISSUE_OLD_WORKBOOK_VERSION .locationXML = .CXMLLocationWorkBook .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_WORKBOOK_VERSION .Values.Add aWB.FileFormat AddIssueDetailsNote myIssue, 0, RID_STR_EXCEL_NOTE_OLDWORKBOOKVERSION mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _ mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1 End With Call DoPreparation(mAnalysis, myIssue, RID_STR_EXCEL_NOTE_OLD_OLDWORKBOOKVERSION_PREPARABLE, aProp, aWB) mAnalysis.Issues.Add myIssue End If FinalExit: Set myIssue = Nothing Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Sub Function getRange(myRange As Range) As String On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "getRange" getRange = "" On Error Resume Next getRange = myRange.Address(RowAbsolute:=False, ColumnAbsolute:=False, ReferenceStyle:=xlA1) FinalExit: Exit Function HandleErrors: WriteDebug currentFunctionName & " : myRange.name " & myRange.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Function Sub Analyze_CellInSheetIssues(mySheet As Worksheet) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_CellInSheetIssues" Dim myCellRng As Range Set myCellRng = mySheet.UsedRange Call CheckAllCellFormatting(myCellRng, mySheet.name) Call CheckAllCellFunctions(myCellRng, mySheet.name) FinalExit: Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source End Sub Sub CheckAllCellFormatting(CurrRange As Range, myName As String) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "CheckAllCellFormatting" Dim myCell As Range Dim myCellAttri As CellAtrributes Dim bCellIssue As Boolean Dim bCellIssueAll As Boolean Dim startTime As Single bCellIssue = False bCellIssueAll = False startTime = Timer For Each myCell In CurrRange bCellIssue = CheckCellFormatting(myCell, myCellAttri) bCellIssueAll = bCellIssueAll Or bCellIssue If (Timer - gExcelMaxRangeProcessTime > startTime) Then WriteDebug currentFunctionName & " : [" & myName & _ "]Too much time needed, abortet cell formatting check." Exit For End If Next FinalExit: If bCellIssueAll Then ReportCellFormattingIssue myName, myCellAttri End If Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source End Sub Function CheckLineFormatIssue(myRange As Range, edge As XlBordersIndex) As Boolean CheckLineFormatIssue = (myRange.Borders(edge).LineStyle <> xlContinuous) And _ (myRange.Borders(edge).LineStyle <> xlDouble) And _ (myRange.Borders(edge).LineStyle <> xlLineStyleNone) End Function Private Function CheckCellFormatting(myCell As Range, myCellAttri As CellAtrributes) As Boolean Dim currentFunctionName As String currentFunctionName = "CheckCellFormatting" On Error GoTo HandleErrors Dim bCellLineFormatIssue As Boolean CheckCellFormatting = False bCellLineFormatIssue = CheckLineFormatIssue(myCell, xlEdgeBottom) Or _ CheckLineFormatIssue(myCell, xlEdgeLeft) Or _ CheckLineFormatIssue(myCell, xlEdgeRight) Or _ CheckLineFormatIssue(myCell, xlEdgeTop) CheckCellFormatting = bCellLineFormatIssue Or _ (myCell.Interior.Pattern <> xlPatternSolid And myCell.Interior.Pattern <> xlPatternNone) If Not CheckCellFormatting Then Exit Function If bCellLineFormatIssue Then myCellAttri.LineStyle = myCellAttri.LineStyle + 1 End If If (myCell.Interior.Pattern <> xlPatternSolid And myCell.Interior.Pattern <> xlPatternNone) Then myCellAttri.FillPattern = myCellAttri.FillPattern + 1 End If Exit Function HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source End Function Private Sub ReportCellFormattingIssue(myName As String, myCellAttri As CellAtrributes) Dim currentFunctionName As String currentFunctionName = "ReportCellFormattingIssue" On Error GoTo HandleErrors Dim myIssue As IssueInfo Set myIssue = New IssueInfo With myIssue .IssueID = CID_FORMAT .IssueType = RID_STR_EXCEL_ISSUE_FORMAT .SubType = RID_STR_EXCEL_SUBISSUE_ATTRIBUTES .Location = .CLocationSheet .IssueTypeXML = CSTR_ISSUE_FORMAT .SubTypeXML = CSTR_SUBISSUE_ATTRIBUTES .locationXML = .CXMLLocationSheet .SubLocation = myName '.Line = myCell.row '.column = Chr(myCell.column + 65 - 1) Dim noteCount As Long noteCount = 0 If myCellAttri.LineStyle > 0 Then .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_LINE_STYLE .Values.Add RID_STR_EXCEL_ATTRIBUTE_DASHED_DOT .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_NUMBER_OF_CELLS .Values.Add myCellAttri.LineStyle AddIssueDetailsNote myIssue, noteCount, RID_STR_EXCEL_NOTE_CELL_ATTRIBUTES_3 noteCount = noteCount + 1 End If If myCellAttri.FillPattern > 0 Then .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_FILL_PATTERN .Values.Add RID_STR_EXCEL_ATTRIBUTE_PATTERNED .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_NUMBER_OF_CELLS .Values.Add myCellAttri.FillPattern AddIssueDetailsNote myIssue, noteCount, RID_STR_EXCEL_NOTE_CELL_ATTRIBUTES_4 noteCount = noteCount + 1 End If mAnalysis.IssuesCountArray(CID_FORMAT) = _ mAnalysis.IssuesCountArray(CID_FORMAT) + 1 End With mAnalysis.Issues.Add myIssue FinalExit: Set myIssue = Nothing Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source End Sub Sub CheckAllCellFunctions(CurrRange As Range, myName As String) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "CheckAllCellFunctions" Dim myCell As Range Dim startTime As Single startTime = Timer For Each myCell In CurrRange Call CheckCellFunction(myCell, myName) If (Timer - gExcelMaxRangeProcessTime > startTime) Then WriteDebug currentFunctionName & " : [" & myName & _ "]Too much time needed, abortet cell functions check (xlCellTypeFormulas)." Exit For End If Next FinalExit: Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source End Sub Sub CheckCellFunction(myCell As Range, myName As String) Dim currentFunctionName As String currentFunctionName = "CheckCellFunction" On Error GoTo HandleErrors Dim bCellFunctionIssue As Boolean Dim bCellINFOFunctionIssue As Boolean Dim bCellERROR_TYPEFunctionIssue As Boolean Dim bCellExternalFunctionIssue As Boolean Dim bHasDateDifFunction As Boolean Dim bHasPhoneticFunction As Boolean Dim aFormularStr As String aFormularStr = myCell.FormulaR1C1 If (aFormularStr = Null) Then Exit Sub If (aFormularStr = "") Then Exit Sub bCellINFOFunctionIssue = (InStr(aFormularStr, "INFO(") <> 0) bCellERROR_TYPEFunctionIssue = (InStr(aFormularStr, "ERROR.TYPE(") <> 0) bCellExternalFunctionIssue = (InStr(aFormularStr, ".xls!") <> 0) bHasDateDifFunction = (InStr(aFormularStr, "DATEDIF(") <> 0) bHasPhoneticFunction = (InStr(aFormularStr, "PHONETIC(") <> 0) bCellFunctionIssue = bCellINFOFunctionIssue Or bCellERROR_TYPEFunctionIssue _ Or bCellExternalFunctionIssue Or bHasDateDifFunction Or bHasPhoneticFunction If Not bCellFunctionIssue Then Exit Sub Dim myIssue As IssueInfo Set myIssue = New IssueInfo With myIssue .IssueID = CID_FUNCTIONS .IssueType = RID_STR_EXCEL_ISSUE_FUNCTIONS .Location = .CLocationSheet .IssueTypeXML = CSTR_ISSUE_FUNCTIONS .locationXML = .CXMLLocationSheet .SubLocation = myName .Line = myCell.row .column = Chr(myCell.column + 65 - 1) Dim noteCount As Long noteCount = 0 If bCellINFOFunctionIssue Then .SubTypeXML = CSTR_SUBISSUE_INFO .SubType = RID_STR_EXCEL_SUBISSUE_INFO .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_FUNCTION_STRING .Values.Add myCell.FormulaR1C1 AddIssueDetailsNote myIssue, noteCount, RID_STR_EXCEL_NOTE_CELL_FUNCTIONS_1 noteCount = noteCount + 1 End If If bCellERROR_TYPEFunctionIssue Then .SubTypeXML = CSTR_SUBISSUE_ERROR_TYPE .SubType = RID_STR_EXCEL_SUBISSUE_ERROR_TYPE .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_FUNCTION_STRING .Values.Add myCell.FormulaR1C1 AddIssueDetailsNote myIssue, noteCount, RID_STR_EXCEL_NOTE_CELL_FUNCTIONS_2 noteCount = noteCount + 1 End If If bCellExternalFunctionIssue Then .SubTypeXML = CSTR_SUBISSUE_EXTERNAL .SubType = RID_STR_EXCEL_SUBISSUE_EXTERNAL .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_FUNCTION_STRING .Values.Add myCell.FormulaR1C1 AddIssueDetailsNote myIssue, noteCount, RID_STR_EXCEL_NOTE_CELL_FUNCTIONS_3 noteCount = noteCount + 1 End If If bHasDateDifFunction Then .SubTypeXML = CSTR_SUBISSUE_DATEDIF .SubType = RID_STR_EXCEL_SUBISSUE_DATEDIF .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_FUNCTION_STRING .Values.Add myCell.FormulaR1C1 AddIssueDetailsNote myIssue, noteCount, RID_STR_EXCEL_NOTE_CELL_FUNCTIONS_DATEDIF noteCount = noteCount + 1 End If If bHasPhoneticFunction Then .SubTypeXML = CSTR_SUBISSUE_PHONETIC .SubType = RID_STR_EXCEL_SUBISSUE_PHONETIC .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_FUNCTION_STRING .Values.Add myCell.FormulaR1C1 AddIssueDetailsNote myIssue, noteCount, RID_STR_EXCEL_NOTE_CELL_FUNCTIONS_PHONETIC noteCount = noteCount + 1 End If mAnalysis.IssuesCountArray(CID_FUNCTIONS) = _ mAnalysis.IssuesCountArray(CID_FUNCTIONS) + 1 End With mAnalysis.Issues.Add myIssue FinalExit: Set myIssue = Nothing Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source End Sub Sub Analyze_Password_Protection(aWB As Workbook) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_Password_Protection" Dim myIssue As IssueInfo Set myIssue = New IssueInfo If aWB.HasPassword Or aWB.WriteReserved Then With myIssue .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES .SubType = RID_STR_COMMON_SUBISSUE_PASSWORDS_PROTECTION .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES .SubTypeXML = CSTR_SUBISSUE_PASSWORD_PROTECTION .locationXML = .CLocationWorkBook .Location = .CLocationWorkBook If aWB.HasPassword Then .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_PASSWORD_TO_OPEN .Values.Add RID_STR_EXCEL_ATTRIBUTE_SET End If If aWB.WriteReserved Then .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_PASSWORD_TO_MODIFY .Values.Add RID_STR_EXCEL_ATTRIBUTE_SET End If mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _ mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1 End With mAnalysis.Issues.Add myIssue End If FinalExit: Set myIssue = Nothing Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Sub Sub SetDocProperties(docAnalysis As DocumentAnalysis, wb As Workbook, fso As FileSystemObject) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "SetProperties" Dim f As File Set f = fso.GetFile(docAnalysis.name) Const appPropertyAppName = 9 Const appPropertyLastAuthor = 7 Const appPropertyRevision = 8 Const appPropertyTemplate = 6 Const appPropertyTimeCreated = 11 Const appPropertyTimeLastSaved = 12 On Error Resume Next docAnalysis.PageCount = wb.Sheets.count docAnalysis.Created = f.DateCreated docAnalysis.Modified = f.DateLastModified docAnalysis.Accessed = f.DateLastAccessed docAnalysis.Printed = DateValue("01/01/1900") On Error GoTo HandleErrors On Error Resume Next 'Some apps may not support all props docAnalysis.Application = getAppSpecificApplicationName & " " & Application.Version 'docAnalysis.Application = wb.BuiltinDocumentProperties(appPropertyAppName) 'If InStr(docAnalysis.Application, "Microsoft") = 1 Then ' docAnalysis.Application = Mid(docAnalysis.Application, Len("Microsoft") + 2) 'End If 'If InStr(Len(docAnalysis.Application) - 2, docAnalysis.Application, ".") = 0 Then ' docAnalysis.Application = docAnalysis.Application & " " & Application.Version 'End If docAnalysis.SavedBy = _ wb.BuiltinDocumentProperties(appPropertyLastAuthor) docAnalysis.Revision = _ val(wb.BuiltinDocumentProperties(appPropertyRevision)) docAnalysis.Template = _ fso.GetFileName(wb.BuiltinDocumentProperties(appPropertyTemplate)) docAnalysis.Modified = _ wb.BuiltinDocumentProperties(appPropertyTimeLastSaved) FinalExit: Set f = Nothing Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Sub Sub Analyze_OLEEmbedded(wrkSheet As Worksheet) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_OLEEmbedded" ' Handle Shapes Dim aShape As Shape For Each aShape In wrkSheet.Shapes Analyze_OLEEmbeddedSingleShape mAnalysis, aShape, wrkSheet.name Analyze_Lines mAnalysis, aShape, wrkSheet.name Analyze_Transparency mAnalysis, aShape, wrkSheet.name Analyze_Gradients mAnalysis, aShape, wrkSheet.name Next aShape Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source End Sub Sub Analyze_Workbook_Protection(aWB As Workbook) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_Workbook_Protection" Dim myIssue As IssueInfo Set myIssue = New IssueInfo Dim bProtectSharing As Boolean Dim bProtectStructure As Boolean Dim bProtectWindows As Boolean bProtectSharing = False bProtectStructure = False bProtectWindows = False If Not WorkbookProtectTest(aWB, bProtectSharing, bProtectStructure, bProtectWindows) Then GoTo FinalExit End If Set myIssue = New IssueInfo With myIssue .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES .SubType = RID_STR_EXCEL_SUBISSUE_WORKBOOK_PROTECTION .Location = .CLocationWorkBook .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES .SubTypeXML = CSTR_SUBISSUE_WORKBOOK_PROTECTION .locationXML = .CXMLLocationWorkBook If bProtectSharing Then .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_PROTECT_TYPE_SHARING .Values.Add RID_STR_EXCEL_ATTRIBUTE_SET End If If bProtectStructure Then .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_PROTECT_TYPE_STRUCTURE .Values.Add RID_STR_EXCEL_ATTRIBUTE_SET End If If bProtectWindows Then .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_PROTECT_TYPE_WINDOWS .Values.Add RID_STR_EXCEL_ATTRIBUTE_SET End If AddIssueDetailsNote myIssue, 0, RID_STR_EXCEL_NOTE_PASSWORD_TO_OPEN mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _ mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1 End With mAnalysis.Issues.Add myIssue FinalExit: Set myIssue = Nothing Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Sub Private Function WorkbookProtectTest(aWB As Workbook, bProtectSharing As Boolean, _ bProtectStructure As Boolean, bProtectWindows As Boolean) As Boolean On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "WorkbookProtectTest" WorkbookProtectTest = False On Error Resume Next 'Simulate Try Catch aWB.UnprotectSharing sharingPassword:=" " If Err.Number = 1004 Then bProtectSharing = True ElseIf Err.Number <> 0 Then Resume HandleErrors End If On Error GoTo HandleErrors On Error Resume Next 'Simulate Try Catch aWB.Unprotect Password:="" If Err.Number = 1004 Then If aWB.ProtectStructure = True Then bProtectStructure = True End If If aWB.ProtectWindows = True Then bProtectWindows = True End If End If If bProtectSharing Or bProtectStructure Or bProtectWindows Then WorkbookProtectTest = True End If FinalExit: Exit Function HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Function Private Sub Class_Initialize() Set mAnalysis = New DocumentAnalysis End Sub Private Sub Class_Terminate() Set mAnalysis = Nothing End Sub Public Property Get Results() As DocumentAnalysis Set Results = mAnalysis End Property Private Function FormatIssueComplex(myChart As Chart, bDataTable As Boolean, bXAxes As Boolean) As Boolean On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "FormatIssueComplex" bXAxes = False If myChart.HasDataTable Then bDataTable = True End If If Not (IsPie(myChart) Or myChart.ChartType = xlDoughnut Or myChart.ChartType = xlBubble3DEffect) Then If myChart.HasAxis(1) Then If myChart.Axes(1).CategoryType = xlTimeScale Or myChart.Axes(1).CategoryType = xlAutomaticScale Then bXAxes = True End If End If End If If bDataTable Or bXAxes Then FormatIssueComplex = True End If Exit Function HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source End Function Private Function IsAreaChart(myChart As Chart) As Boolean If (myChart.ChartType = xlArea Or myChart.ChartType = xl3DArea Or _ myChart.ChartType = xlAreaStacked Or _ myChart.ChartType = xl3DAreaStacked Or _ myChart.ChartType = xlAreaStacked100 Or _ myChart.ChartType = xl3DAreaStacked100) _ Then IsAreaChart = True Else IsAreaChart = False End If End Function Private Function FormatissueMinor(myChart As Chart, bUnsupportedType As Boolean, bTrendline As Boolean, bDatalabelWithLegend As Boolean, bLegendPosition As Boolean, bTitleFont As Boolean, bPiechartDirection As Boolean, bAxisInterval As Boolean) As Boolean On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "FormatissueMinor" Dim ctype As Integer Dim fsize As Integer Dim se As Series Dim dl As DataLabel FormatissueMinor = False ctype = myChart.ChartType If (ctype = xlBubble Or ctype = xlPieOfPie Or ctype = xl3DPieExploded _ Or ctype = xlRadarFilled Or ctype = xlBubble3DEffect _ Or ctype = xlRadarMarkers Or ctype = xlRadar Or ctype = xlBarOfPie _ Or ctype = xlXYScatter Or ctype = xlXYScatterLines Or ctype = xlXYScatterLinesNoMarkers _ Or ctype = xlXYScatterSmooth Or ctype = xlXYScatterSmoothNoMarkers _ Or ctype = xlSurface Or ctype = xlSurfaceTopView Or ctype = xlSurfaceTopViewWireframe _ Or ctype = xlSurfaceWireframe) Then bUnsupportedType = True End If For Each se In myChart.SeriesCollection On Error Resume Next ' may not have trendlines property If se.Trendlines.count <> 0 Then If Err.Number = 0 Then bTrendline = True End If End If If se.HasDataLabels Then If Err.Number = 0 Then If (IsAreaChart(myChart)) Then For Each dl In se.DataLabels If dl.ShowLegendKey = True Then bDatalabelWithLegend = True Exit For End If Next dl Else Dim pt As Point For Each pt In se.Points If pt.HasDataLabel Then If pt.DataLabel.ShowLegendKey Then bDatalabelWithLegend = True Exit For End If End If Next pt End If End If End If On Error GoTo HandleErrors If bTrendline And bDatalabelWithLegend Then Exit For End If Next se If myChart.HasLegend Then Dim legPos As Long On Error Resume Next 'If legend moved accessing position will fail legPos = myChart.Legend.Position If (Err.Number <> 0) Or (legPos <> xlLegendPositionRight) Then bLegendPosition = True End If On Error GoTo HandleErrors End If If IsPie(myChart) Then bPiechartDirection = True ElseIf myChart.ChartType <> xlDoughnut And myChart.ChartType <> xlBubble3DEffect Then If myChart.HasAxis(xlValue, xlPrimary) Then With myChart.Axes(xlValue, xlPrimary) If .MajorUnitIsAuto And .MaximumScaleIsAuto And .MinimumScaleIsAuto And .MinorUnitIsAuto Then bAxisInterval = True End If End With End If End If On Error Resume Next 'If title has mixed font size accessing Font.Size will fail - Title mixed font issue If myChart.HasTitle Then fsize = myChart.chartTitle.Font.Size If Err.Number = FontError Then bTitleFont = True End If End If On Error GoTo HandleErrors If bUnsupportedType Or bTrendline Or bDatalabelWithLegend Or bLegendPosition Or bTitleFont Or bPiechartDirection Or bAxisInterval Then FormatissueMinor = True End If FinalExit: Set se = Nothing Set dl = Nothing Exit Function HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Function Private Function SeriesIssue(myChart As Chart, bSeriesChartTypeChanged As Boolean, bDatasourceNotLinkedtoCell As Boolean, bDatasourceOnDifferentSheet As Boolean, bCategoryandValue As Boolean, bCLabelMorethanOneCell As Boolean, bOneColumnRow As Boolean) As Boolean On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "SeriesIssue" SeriesIssue = False Dim Num As Integer Dim I As Integer Dim i2 As Integer Dim formula As String Dim p1 As Integer, p2 As Integer Dim b1 As Integer, b2 As Integer Dim comma1 As Integer, comma2 As Integer Dim starty As Integer Dim ctype As Integer Dim temp As Integer Dim myarray() As String Dim Values(3), sh Dim chartseries As Series Dim b As Boolean Dim bmorecolumns As Boolean Dim c As Boolean bmorecolumns = False Num = myChart.SeriesCollection.count If (Num = 0) Then Exit Function ctype = myChart.SeriesCollection(1).ChartType I = 0 sh = "" ReDim Preserve myarray(Num, 3) If IsPie(myChart) And Num > 1 Then 'if pie chart has more than one series,set series number to 1 bmorecolumns = True Num = 1 End If For Each chartseries In myChart.SeriesCollection On Error Resume Next formula = chartseries.formula If Err.Number <> 0 Then GoTo FinalExit End If If Not bSeriesChartTypeChanged Then 'check if the chart type changed temp = chartseries.ChartType If temp <> ctype Then bSeriesChartTypeChanged = True End If End If 'get each part of the formula, if it is a single range, set the value to the array p1 = InStr(1, formula, "(") comma1 = InStr(1, formula, ",") Values(0) = Mid(formula, p1 + 1, comma1 - p1 - 1) If Mid(formula, comma1 + 1, 1) = "(" Then ' Multiple ranges bDatasourceNotLinkedtoCell = True GoTo FinalExit Else If Mid(formula, comma1 + 1, 1) = "{" Then ' Literal Array bDatasourceNotLinkedtoCell = True GoTo FinalExit Else ' A single range comma2 = InStr(comma1 + 1, formula, ",") Values(1) = Mid(formula, comma1 + 1, comma2 - comma1 - 1) starty = comma2 End If End If If Mid(formula, starty + 1, 1) = "(" Then ' Multiple ranges bDatasourceNotLinkedtoCell = True GoTo FinalExit Else If Mid(formula, starty + 1, 1) = "{" Then ' Literal Array bDatasourceNotLinkedtoCell = True GoTo FinalExit Else ' A single range comma1 = starty comma2 = InStr(comma1 + 1, formula, ",") Values(2) = Mid(formula, comma1 + 1, comma2 - comma1 - 1) End If End If If SheetCheck(sh, Values) Then 'check if data from different sheet bDatasourceOnDifferentSheet = True GoTo FinalExit End If For i2 = 0 To 2 'set data to myarray, if it is range, assign the range address, else null If IsRange(Values(i2)) Then myarray(I, i2) = Range(Values(i2)).Address 'ElseIf (Not IsRange(values(i2))) And values(i2) <> "" Then ' bDatasourceNotLinkedtoCell = True ' myarray(i, i2) = "" Else bDatasourceNotLinkedtoCell = True myarray(I, i2) = "" End If Next i2 I = I + 1 If bmorecolumns Then 'if it is pie chart, exit Exit For End If Next chartseries c = DataCheck(myarray, Num, bCategoryandValue, bCLabelMorethanOneCell, bOneColumnRow) 'check data values and category of the chart FinalExit: If bSeriesChartTypeChanged Or bDatasourceNotLinkedtoCell Or bDatasourceOnDifferentSheet Or bCategoryandValue Or bCLabelMorethanOneCell Or bOneColumnRow Then SeriesIssue = True End If Last: Set chartseries = Nothing Exit Function HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume Last End Function Private Function DataCheck(myarray() As String, Num As Integer, bCategoryandValue As Boolean, bCLabelMorethanOneCell As Boolean, bOneColumnRow As Boolean) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "DataCheck" Dim s1() As String Dim v1() As String Dim v2() As String Dim c1() As String Dim c2() As String Dim bs1isrange As Boolean Dim bc1isrange As Boolean Dim bc2isrange As Boolean Dim j As Integer Dim I As Integer Dim btemp1 As Boolean Dim btemp2 As Boolean bs1isrange = True bc1isrange = True bc2isrange = True If myarray(0, 1) = "" Then bs1isrange = False Else s1 = SplitRange(myarray(0, 1)) If UBound(s1) < 4 Then bOneColumnRow = True GoTo FinalExit End If If (Asclong(s1(0)) <> Asclong(s1(2))) And (Asclong(s1(1)) <> Asclong(s1(3))) Then bCLabelMorethanOneCell = True GoTo FinalExit End If End If If myarray(0, 0) = "" Then ReDim c1(2) bc1isrange = False c1(0) = "" c1(1) = "" Else If InStr(1, myarray(0, 0), ":") <> 0 Then bCLabelMorethanOneCell = True GoTo FinalExit End If c1 = SplitRange(myarray(0, 0)) End If v1 = SplitRange(myarray(0, 2)) If bs1isrange Then btemp1 = s1(0) = s1(2) And s1(1) = v1(1) And s1(3) = v1(3) And Asclong(v1(0)) >= Asclong(s1(0)) + 1 'category beside first column btemp2 = s1(1) = s1(3) And s1(0) = v1(0) And s1(2) = v1(2) And Asclong(v1(1)) >= Asclong(s1(1)) + 1 'category beside first row If (Not btemp1) And (Not btemp2) Then bCategoryandValue = True GoTo FinalExit End If End If If bc1isrange Then btemp1 = v1(0) = v1(2) And c1(0) = v1(0) And Asclong(c1(1)) <= Asclong(v1(1)) - 1 'data label beside row btemp2 = v1(1) = v1(3) And c1(1) = v1(1) And Asclong(c1(0)) <= Asclong(v1(0)) - 1 'data label beside column If (Not btemp1) And (Not btemp2) Then bCategoryandValue = True GoTo FinalExit End If End If For I = 1 To Num - 1 If myarray(I, 0) = "" Then ReDim c2(2) c2(0) = "" c2(1) = "" bc2isrange = False Else If InStr(1, myarray(0, 1), ":") = 0 Then bCLabelMorethanOneCell = True GoTo FinalExit End If c2 = SplitRange(myarray(I, 0)) End If v2 = SplitRange(myarray(I, 2)) If bc2isrange Then btemp1 = v1(0) = v1(2) And c2(0) = v2(0) And Asclong(c2(1)) <= Asclong(v2(1)) - 1 'data label beside row btemp2 = v2(1) = v2(3) And c2(1) = v2(1) And Asclong(c2(0)) <= Asclong(v2(0)) - 1 'data label beside column If (Not btemp1) And (Not btemp2) Then bCategoryandValue = True GoTo FinalExit 'break End If End If If bc1isrange And bc2isrange Then 'series data beside last series data in column and data label beside last series data label btemp1 = v2(0) = v2(2) And Asclong(c2(0)) = Asclong(c1(0)) + 1 And c2(1) = c1(1) And Asclong(v2(0)) = Asclong(v1(0)) + 1 And v1(1) = v2(1) And v1(3) = v2(3) 'series data beside last series data in row and data label beside laast series data label btemp2 = v2(1) = v2(3) And c1(0) = c2(0) And Asclong(c2(1)) = Asclong(c1(1)) + 1 And Asclong(v2(1)) = Asclong(v1(1)) + 1 And v1(0) = v2(0) And v1(2) = v2(2) If (Not btemp1) And (Not btemp2) Then bCategoryandValue = True GoTo FinalExit End If ElseIf Not bc2isrange Then btemp1 = v2(0) = v2(2) And Asclong(v2(0)) = Asclong(v1(0)) + 1 And v1(1) = v2(1) And v1(3) = v2(3) 'series data beside last series data in column btemp2 = v2(1) = v2(3) And Asclong(v2(1)) = Asclong(v1(1)) + 1 And v1(0) = v2(0) And v1(2) = v2(2) 'series data beside last series data in row If (Not btemp1) And (Not btemp2) Then bCategoryandValue = True GoTo FinalExit End If End If For j = 0 To 1 c1(j) = c2(j) Next j For j = 0 To 3 v1(j) = v2(j) Next j bc1isrange = bc2isrange bc2isrange = True Next I FinalExit: Exit Function HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source End Function Private Function SplitRange(a As String) As String() On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "SplitRange" Dim c1 As Integer, c2 As Integer, c3 As Integer Dim start As Integer Dim l As Integer Dim rearray() As String start = 2 If a <> "" Then l = InStr(1, a, ":") If l = 0 Then ReDim rearray(2) c1 = InStr(start, a, "$") rearray(0) = Mid(a, start, c1 - start) rearray(1) = Mid(a, c1 + 1, Len(a) - c1) Else ReDim rearray(4) c1 = InStr(start, a, "$") rearray(0) = Mid(a, start, c1 - start) c2 = InStr(c1 + 1, a, "$") rearray(1) = Mid(a, c1 + 1, c2 - c1 - 2) c3 = InStr(c2 + 1, a, "$") rearray(2) = Mid(a, c2 + 1, c3 - c2 - 1) rearray(3) = Mid(a, c3 + 1, Len(a) - c3) End If Else ReDim rearray(4) rearray(0) = "" rearray(1) = "" rearray(2) = "" rearray(3) = "" End If SplitRange = rearray Exit Function HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source End Function Private Function Asclong(s As String) As Integer On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Asclong" Asclong = 0 Dim l As Integer Dim I As Integer Dim m As String l = Len(s) For I = 1 To l m = Mid(s, I, 1) Asclong = Asclong + Asc(m) Next I Exit Function HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source End Function Private Function SheetCheck(sh As Variant, Values() As Variant) As Boolean On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "SheetCheck" SheetCheck = False Dim c1 As Integer Dim I As Integer Dim temp For I = 0 To 2 If IsRange(Values(I)) Then c1 = InStr(1, Values(I), "!") If sh = "" Then sh = Mid(Values(I), 1, c1 - 1) temp = Mid(Values(I), 1, c1 - 1) Else temp = Mid(Values(I), 1, c1 - 1) End If If temp <> sh Then SheetCheck = True Exit Function End If End If Next I Exit Function HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source End Function Private Function IsRange(Ref) As Boolean On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "IsRange" Dim x As Range On Error Resume Next Set x = Range(Ref) If Err = 0 Then IsRange = True Else IsRange = False End If FinalExit: Set x = Nothing Exit Function HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Function Private Function IsPie(myChart As Chart) As Boolean On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "IsPie" Dim ctype As Integer IsPie = False ctype = myChart.ChartType If (ctype = xlPie) Or _ (ctype = xlPieExploded) Or _ (ctype = xlPieOfPie) Or _ (ctype = xl3DPie) Or _ (ctype = xl3DPieExploded) Then IsPie = True End If Exit Function HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source End Function Private Function IsOldVersion(aFormat As XlFileFormat) As Boolean Dim theResult As Boolean Dim currentFunctionName As String currentFunctionName = "IsOldVersion" Select Case aFormat Case xlExcel2, xlExcel2FarEast, xlExcel3, xlExcel4, xlExcel4Workbook, xlExcel5, xlExcel7 theResult = True Case xlExcel9795, xlWorkbookNormal theResult = False Case Else WriteDebug currentFunctionName & " : " & mAnalysis.name & ": The version of this spreadsheet is not recognised" End Select IsOldVersion = theResult End Function