| 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 = "<TOKEN1>" | |
| Const CR_BADCHARNUM = "<TOKEN2>" | |
| 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 <storeToDir>\prepared\<source doc name> | |
| 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 | |