1VERSION 1.0 CLASS 2BEGIN 3 MultiUse = -1 'True 4END 5Attribute VB_Name = "MigrationAnalyser" 6Attribute VB_GlobalNameSpace = False 7Attribute VB_Creatable = False 8Attribute VB_PredeclaredId = False 9Attribute VB_Exposed = False 10'************************************************************************* 11' 12' Licensed to the Apache Software Foundation (ASF) under one 13' or more contributor license agreements. See the NOTICE file 14' distributed with this work for additional information 15' regarding copyright ownership. The ASF licenses this file 16' to you under the Apache License, Version 2.0 (the 17' "License"); you may not use this file except in compliance 18' with the License. You may obtain a copy of the License at 19' 20' http://www.apache.org/licenses/LICENSE-2.0 21' 22' Unless required by applicable law or agreed to in writing, 23' software distributed under the License is distributed on an 24' "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 25' KIND, either express or implied. See the License for the 26' specific language governing permissions and limitations 27' under the License. 28' 29'************************************************************************* 30Option Explicit 31 32Const CWORKBOOK_SHEETS_LIMIT = 256 33 34'Class variables 35Private Enum HFIssueType 36 hfInline 37 hfShape 38 hfFrame 39End Enum 40 41Private Enum HFIssueLocation 42 hfHeader 43 hfFooter 44End Enum 45 46Private Type CellAtrributes 47 LineStyle As Integer 48 FillPattern As Integer 49End Type 50 51Private Type BadSheetNameChar 52 BadChar As String 53 Position As Integer 54End Type 55 56Private mAnalysis As DocumentAnalysis 57Private mFileName As String 58 59Const RID_STR_EXCEL_SUBISSUE_ERROR_TYPE = "ERROR.TYPE" 60Const RID_STR_EXCEL_SUBISSUE_INFO = "INFO" 61Const RID_STR_EXCEL_SUBISSUE_DATEDIF = "DATEDIF" 62Const RID_STR_EXCEL_SUBISSUE_PHONETIC = "PHONETIC" 63Const FontError = 94 64Const CR_BADCHAR = "<TOKEN1>" 65Const CR_BADCHARNUM = "<TOKEN2>" 66Const DATA_SOURCE_EXCEL = 0 67Const DATA_SOURCE_EXTERNAL = 1 68Const DATA_SOURCE_MULTIPLE = 2 69Const DATA_SOURCE_EXTERNAL_FILE = 3 70Const C_MAX_CELL_RANGE_COUNT = 10000 71 72Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 73 74'***ADDING-ISSUE: Use Following Skeleton as Guideline for Adding Issue 75' For complete list of all RID_STR_... for Issues (IssueType), SubIssues (SubType) and Attributes refer to: 76' excel_res.bas and common_res.bas 77' 78' For complete list of all CID_... for Issue Categories(IssueID) and 79' CSTR_... for XML Issues (IssueTypeXML) and XML SubIssues (SubTypeXML) refer to: 80' ApplicationSpecific.bas and CommonMigrationAnalyser.bas 81' 82' You should not have to add any new Issue Categories or matching IssueTypes, only new SubIssues 83Sub Analyze_SKELETON() 84 On Error GoTo HandleErrors 85 Dim currentFunctionName As String 86 currentFunctionName = "Analyze_SKELETON" 87 Dim myIssue As IssueInfo 88 Set myIssue = New IssueInfo 89 90 With myIssue 91 .IssueID = CID_VBA_MACROS 'Issue Category 92 .IssueType = RID_STR_COMMON_ISSUE_VBA_MACROS 'Issue String 93 .SubType = RID_STR_COMMON_SUBISSUE_PROPERTIES 'SubIssue String 94 .Location = .CLocationDocument 'Location string 95 96 .IssueTypeXML = CSTR_ISSUE_VBA_MACROS 'Non localised XML Issue String 97 .SubTypeXML = CSTR_SUBISSUE_PROPERTIES 'Non localised XML SubIssue String 98 .locationXML = .CXMLLocationDocument 'Non localised XML location 99 100 .SubLocation = 0 'if not set will default to RID_STR_NOT_AVAILABLE_SHORTHAND 101 .Line = 0 'if not set will default to RID_STR_NOT_AVAILABLE_SHORTHAND 102 .column = 0 'if not set will default to RID_STR_NOT_AVAILABLE_SHORTHAND 103 104 ' Add as many Attribute Value pairs as needed 105 ' Note: following must always be true - Attributes.Count = Values.Count 106 .Attributes.Add "AAA" 107 .Values.Add "foobar" 108 109 ' Use AddIssueDetailsNote to add notes to the Issue Details if required 110 ' Public Sub AddIssueDetailsNote(myIssue As IssueInfo, noteNum As Long, noteStr As String, _ 111 ' Optional preStr As String = RID_STR_COMMON_NOTE_PRE) 112 ' Where preStr is prepended to the output, with "Note" as the default 113 AddIssueDetailsNote myIssue, 0, RID_STR_COMMON_NOTE_DOCUMENT_PROPERTIES_LOST 114 115 mAnalysis.IssuesCountArray(CID_VBA_MACROS) = _ 116 mAnalysis.IssuesCountArray(CID_VBA_MACROS) + 1 117 End With 118 119 mAnalysis.Issues.Add myIssue 120 121FinalExit: 122 Set myIssue = Nothing 123 Exit Sub 124 125HandleErrors: 126 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 127 Resume FinalExit 128End Sub 129 130Sub DoAnalyse(fileName As String, userFormTypesDict As Scripting.Dictionary, _ 131 startDir As String, storeToDir As String, fso As FileSystemObject) 132 On Error GoTo HandleErrors 133 Dim currentFunctionName As String 134 currentFunctionName = "DoAnalyse" 135 'Dim secAutomation As MsoAutomationSecurity 136 'secAutomation = Application.AutomationSecurity 137 138 mAnalysis.name = fileName 139 Dim aWB As Workbook 140 mAnalysis.TotalIssueTypes = CTOTAL_CATEGORIES 141 142 'Make Excel run as non interactively as possible 143 Application.EnableEvents = False 144 Application.DisplayAlerts = False 145 Application.Interactive = False 146 Application.AskToUpdateLinks = False 147 Application.EnableAnimations = False 148 Application.EnableSound = False 149 150 'Only supported in Office XP and above 151 'Application.AutomationSecurity = msoAutomationSecurityForceDisable 152 'mFileName = fso.GetFileName(fileName) 153 'WriteToLog "TmpDebug1", mFileName 154 155 Dim myPassword As String 156 157 myPassword = GetDefaultPassword 158 159 If myPassword = "" Then 160 myPassword = "xoxoxoxoxo" 161 End If 162 163 Set aWB = Workbooks.Open(fileName:=fileName, _ 164 Password:=myPassword, _ 165 WriteResPassword:=myPassword, _ 166 UpdateLinks:=0) 167 168 'Application.AutomationSecurity = secAutomation 169 170 'Do Analysis 171 Analyze_Password_Protection aWB 172 Analyze_Workbook_Protection aWB 173 174 'Set Doc Properties 175 SetDocProperties mAnalysis, aWB, fso 176 177 Analyze_SheetLimits aWB 178 Analyze_SheetDisplay aWB 179 Analyze_SheetIssues aWB 180 Analyze_SheetCharts aWB 181 Analyze_WorkbookVersion aWB 182 Analyze_Macros mAnalysis, userFormTypesDict, aWB 183 184 ' Doc Preparation only 185 ' Save document with any fixed issues under <storeToDir>\prepared\<source doc name> 186 If mAnalysis.PreparableIssuesCount > 0 And CheckDoPrepare Then 187 Dim preparedFullPath As String 188 preparedFullPath = GetPreparedFullPath(mAnalysis.name, startDir, storeToDir, fso) 189 If preparedFullPath <> "" Then 190 If fso.FileExists(preparedFullPath) Then 191 fso.DeleteFile preparedFullPath, True 192 End If 193 If fso.FolderExists(fso.GetParentFolderName(preparedFullPath)) Then 194 If IsOldVersion(aWB.FileFormat) Then 195 aWB.SaveAs fileName:=preparedFullPath, FileFormat:=xlExcel9795 196 Else 197 aWB.SaveAs preparedFullPath 198 End If 199 End If 200 End If 201 End If 202 203FinalExit: 204 If Not aWB Is Nothing Then 205 aWB.Close (False) 206 End If 207 208 Set aWB = Nothing 209 210 Application.EnableEvents = True 211 Application.DisplayAlerts = True 212 Application.Interactive = True 213 Application.AskToUpdateLinks = True 214 Application.EnableAnimations = True 215 Application.EnableSound = True 216 217 'Debug - Call Sleep(5000) 218 Exit Sub 219 220HandleErrors: 221 ' MsgBox currentFunctionName & " : " & fileName & ": " & Err.Number & " " & Err.Description & " " & Err.Source 222 ' Handle Password error on Doc Open, Modify and Cancel 223 If Err.Number = 1004 Then 224 WriteDebug currentFunctionName & " : " & fileName & ": " & _ 225 "User entered Invalid Document Password - " & Err.Number & " " & Err.Description & " " & Err.Source 226 HandleProtectedDocInvalidPassword mAnalysis, _ 227 "User entered Invalid Document Password, further analysis not possible", fso 228 Resume FinalExit 229 End If 230 mAnalysis.Application = RID_STR_COMMON_CANNOT_OPEN 231 WriteDebug currentFunctionName & " : " & fileName & ": " & Err.Number & " " & Err.Description & " " & Err.Source 232 Resume FinalExit 233End Sub 234 235Sub Analyze_SheetCharts(aWB As Workbook) 236 On Error GoTo HandleErrors 237 Dim currentFunctionName As String 238 currentFunctionName = "Analyze_SheetCharts" 239 240 Dim myChartSheet As Chart 241 242 For Each myChartSheet In aWB.Charts 243 SetChartIssueMinor myChartSheet, myChartSheet.name, False 244 SetChartIssueComplex myChartSheet, myChartSheet.name 245 Next myChartSheet 246 247 Exit Sub 248HandleErrors: 249 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 250End Sub 251 252Sub Analyze_EmbeddedCharts(mySheet As Worksheet) 253 On Error GoTo HandleErrors 254 Dim currentFunctionName As String 255 currentFunctionName = "Analyze_EmbeddedCharts" 256 Dim BorderIssue As Boolean 257 258 Dim index As Integer 259 BorderIssue = False 260 Dim chartcount As Integer 261 Dim myChart As Chart 262 263 chartcount = mySheet.ChartObjects.count 264 265 For index = 1 To chartcount 266 BorderIssue = False 267 With mySheet.ChartObjects(index) 268 If .Border.LineStyle <> xlLineStyleNone Then 269 BorderIssue = True 270 End If 271 SetChartIssueMinor .Chart, mySheet.name, BorderIssue 272 'If Not ((.ChartType = xlSurface) _ 273 ' And (.ChartType = xlSurfaceTopViewWireframe) _ 274 ' And (.ChartType = xlSurfaceTopView)) Then 275 SetChartIssueComplex .Chart, mySheet.name 276 'End If 277 End With 278 Next index 279 280 Exit Sub 281HandleErrors: 282 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 283End Sub 284 285Private Function getType(o As Variant) As Integer 286 If (VarType(o) = vbString) Then 287 Dim aDataSource As String 288 aDataSource = o 289 getType = DATA_SOURCE_EXCEL 290 If (Len(aDataSource) > 0) Then 291 Dim nBackslashPos As Long 292 nBackslashPos = InStr(Trim(aDataSource), "\") 293 If (nBackslashPos > 0 And nBackslashPos < 4) Then 294 getType = DATA_SOURCE_EXTERNAL_FILE 295 End If 296 End If 297 ElseIf (IsArray(o)) Then 298 If (hasSecondDimension(o)) Then 299 getType = DATA_SOURCE_MULTIPLE 300 Else 301 getType = DATA_SOURCE_EXTERNAL 302 End If 303 End If 304End Function 305 306Private Function hasSecondDimension(o2 As Variant) As Boolean 307 On Error GoTo njet 308 Dim temp As Integer 309 temp = UBound(o2, 2) 310 hasSecondDimension = True 311 Exit Function 312njet: 313 hasSecondDimension = False 314End Function 315 316Private Sub Analyze_PivotTable(myIssue As IssueInfo, myPivotTable As PivotTable) 317 On Error GoTo HandleErrors 318 Dim currentFunctionName As String 319 currentFunctionName = "Analyse_PivotTable" 320 321 Dim aPivotField As PivotField 322 Dim aNoteCount As Long 323 Dim bManualSort As Boolean 324 Dim bCalculatedValues As Boolean 325 Dim aSorting As XlSortOrder 326 Dim nCount As Integer 327 Dim nDataSource As Integer 328 329 bManualSort = False 330 bCalculatedValues = False 331 332 For Each aPivotField In myPivotTable.PivotFields 333 aSorting = xlAscending 334 335 On Error Resume Next 'some fields don't have any property at all 336 aSorting = aPivotField.AutoSortOrder 337 On Error GoTo HandleErrors 338 339 If (aSorting = xlManual) Then 340 bManualSort = True 341 End If 342 343 nCount = 0 344 345 On Error Resume Next 'some fields don't have any property at all 346 nCount = aPivotField.CalculatedItems.count 347 On Error GoTo HandleErrors 348 349 If (nCount > 0) Then 350 bCalculatedValues = True 351 End If 352 Next 353 354 nCount = 0 355 356 On Error Resume Next 'some fields don't have any property at all 357 nCount = myPivotTable.CalculatedFields.count 358 On Error GoTo HandleErrors 359 360 If (nCount > 0) Then 361 bCalculatedValues = True 362 End If 363 364 nDataSource = getType(myPivotTable.SourceData) 365 366 aNoteCount = 0 367 368 If (bManualSort) Then 369 AddIssueDetailsNote myIssue, aNoteCount, RID_RESXLT_COST_PIVOT_ManSort_Comment 370 aNoteCount = aNoteCount + 1 371 End If 372 373 If (nDataSource = DATA_SOURCE_EXTERNAL) Then 374 AddIssueDetailsNote myIssue, aNoteCount, RID_RESXLT_COST_PIVOT_ExternData_Comment 375 aNoteCount = aNoteCount + 1 376 ElseIf (nDataSource = DATA_SOURCE_MULTIPLE) Then 377 AddIssueDetailsNote myIssue, aNoteCount, RID_RESXLT_COST_PIVOT_MultConsRanges_Comment 378 aNoteCount = aNoteCount + 1 379 ElseIf (nDataSource = DATA_SOURCE_EXTERNAL_FILE) Then 380 Dim noteString As String 381 noteString = RID_RESXLT_COST_PIVOT_ExternData_Comment & "[" & _ 382 myPivotTable.SourceData & "]" 383 AddIssueDetailsNote myIssue, aNoteCount, noteString 384 aNoteCount = aNoteCount + 1 385 End If 386 387 If (bCalculatedValues) Then 388 AddIssueDetailsNote myIssue, aNoteCount, RID_RESXLT_COST_PIVOT_CalcVal_Comment 389 aNoteCount = aNoteCount + 1 390 End If 391 392FinalExit: 393 Exit Sub 394 395HandleErrors: 396 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 397 Resume FinalExit 398End Sub 399 400Private Sub SetChartIssueComplex(myChart As Chart, myName As String) 401 On Error GoTo HandleErrors 402 Dim currentFunctionName As String 403 currentFunctionName = "SetChartIssueComplex" 404 405 Dim myIssue As IssueInfo 406 Dim bSeriesChartTypeChanged As Boolean 407 Dim bDatasourceNotLinkedtoCell As Boolean 408 Dim bDatasourceOnDifferentSheet As Boolean 409 Dim bCategoryandValue As Boolean 410 Dim bCLabelMorethanOneCell As Boolean 411 Dim bOneColumnRow As Boolean 412 Dim bDataTable As Boolean 413 Dim bXAxes As Boolean 414 Dim bseries As Boolean 415 Dim bformat As Boolean 416 Dim bpivot As Boolean 417 418 419 Set myIssue = New IssueInfo 420 bSeriesChartTypeChanged = False 421 bDatasourceNotLinkedtoCell = False 422 bDatasourceOnDifferentSheet = False 423 bCategoryandValue = False 424 bCLabelMorethanOneCell = False 425 bOneColumnRow = False 426 bDataTable = False 427 bXAxes = False 428 429 bformat = FormatIssueComplex(myChart, bDataTable, bXAxes) 430 bseries = SeriesIssue(myChart, bSeriesChartTypeChanged, bDatasourceNotLinkedtoCell, bDatasourceOnDifferentSheet, bCategoryandValue, bCLabelMorethanOneCell, bOneColumnRow) 431 bpivot = Not (myChart.PivotLayout Is Nothing) 432 433 If (Not (bseries Or bformat Or bpivot)) Then 434 GoTo FinalExit 435 ElseIf bpivot Then 436 With myIssue 437 .IssueID = CID_CHARTS_TABLES 438 .IssueType = RID_STR_EXCEL_ISSUE_CHARTS_AND_TABLES 439 .SubType = RID_STR_EXCEL_SUBISSUE_PIVOT 440 .Location = .CLocationSheet 441 .SubLocation = myName 442 443 .IssueTypeXML = CSTR_ISSUE_CHARTS_TABLES 444 .SubTypeXML = CSTR_SUBISSUE_CHART_PIVOT 445 .locationXML = .CXMLLocationSheet 446 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_PIVOT_TABLE_NAME 447 .Values.Add myChart.PivotLayout.PivotTable.name 448 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_PIVOT_FIELDS_VISIBLE 449 .Values.Add myChart.HasPivotFields 450 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_PIVOT_FIELDS_NUM 451 .Values.Add myChart.PivotLayout.PivotTable.PivotFields.count 452 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_TYPE 453 .Values.Add getChartTypeAsString(myChart.ChartType) 454 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_CHARTNAME 455 .Values.Add myChart.name 456 End With 457 458 AddIssueDetailsNote myIssue, 0, RID_RESXLT_COST_PIVOT_PivotChart_Comment 459 mAnalysis.IssuesCountArray(CID_CHARTS_TABLES) = _ 460 mAnalysis.IssuesCountArray(CID_CHARTS_TABLES) + 1 461 mAnalysis.Issues.Add myIssue 462 463 GoTo FinalExit 464 Else 465 With myIssue 466 Dim NoteIndex As Long 467 NoteIndex = 0 468 469 .IssueID = CID_CHARTS_TABLES 470 .IssueType = RID_STR_EXCEL_ISSUE_CHARTS_AND_TABLES 471 .SubType = RID_STR_EXCEL_SUBISSUE_CHART_COMPLEX 472 .Location = .CLocationSheet 473 .SubLocation = myName 474 475 .IssueTypeXML = CSTR_ISSUE_CHARTS_TABLES 476 .SubTypeXML = CSTR_SUBISSUE_CHART_COMPLEX 477 .locationXML = .CXMLLocationSheet 478 479 If bDataTable Then 480 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_DATATABLE 481 .Values.Add RID_STR_EXCEL_ATTRIBUTE_SET 482 AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_DATATABLE 483 NoteIndex = NoteIndex + 1 484 End If 485 If bXAxes Then 486 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_XAXISCATEGORY 487 .Values.Add RID_STR_EXCEL_ATTRIBUTE_TIMESCALE 488 AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_XAXISCATEGORY 489 NoteIndex = NoteIndex + 1 490 End If 491 If bSeriesChartTypeChanged Then 492 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_SERIESCHARTTYPE 493 .Values.Add RID_STR_EXCEL_ATTRIBUTE_CHANGED 494 AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_SERIESCHARTTYPE 495 NoteIndex = NoteIndex + 1 496 End If 497 If bDatasourceNotLinkedtoCell Then 498 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_DATASOURCE 499 .Values.Add RID_STR_EXCEL_ATTRIBUTE_DATASOURCENOTLINKEDTOCELL 500 AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_DATASOURCENOTLINKEDTOCELL 501 NoteIndex = NoteIndex + 1 502 End If 503 If bDatasourceOnDifferentSheet Then 504 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_DATASOURCE 505 .Values.Add RID_STR_EXCEL_ATTRIBUTE_DATASOURCEONDIFFERENTSHEET 506 AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_DATASOURCEONDIFFERENTSHEET 507 NoteIndex = NoteIndex + 1 508 End If 509 If bCategoryandValue Then 510 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_CATEGORYANDDATA 511 .Values.Add RID_STR_EXCEL_ATTRIBUTE_SEPARATE 512 AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_CATEGORYANDDATA 513 NoteIndex = NoteIndex + 1 514 End If 515 If bCLabelMorethanOneCell Then 516 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_CATEGORYLABEL 517 .Values.Add RID_STR_EXCEL_ATTRIBUTE_CATEGORYLABELMORETHANONECELL 518 AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_CATEGORYLABELMORETHANONECELL 519 NoteIndex = NoteIndex + 1 520 End If 521 If bOneColumnRow Then 522 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_COLUMNBAR 523 .Values.Add RID_STR_EXCEL_ATTRIBUTE_ONECOLUMNROW 524 AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_COLUMNBAR 525 NoteIndex = NoteIndex + 1 526 End If 527 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_TYPE 528 .Values.Add getChartTypeAsString(myChart.ChartType) 529 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_CHARTNAME 530 .Values.Add myChart.name 531 End With 532 533 mAnalysis.IssuesCountArray(CID_CHARTS_TABLES) = _ 534 mAnalysis.IssuesCountArray(CID_CHARTS_TABLES) + 1 535 mAnalysis.Issues.Add myIssue 536 End If 537FinalExit: 538 Set myIssue = Nothing 539 Exit Sub 540 541HandleErrors: 542 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 543 Resume FinalExit 544End Sub 545 546Private Sub SetChartIssueMinor(myChart As Chart, myName As String, BorderIssue As Boolean) 547 On Error GoTo HandleErrors 548 Dim currentFunctionName As String 549 currentFunctionName = "SetChartIssueMinor" 550 551 Dim myIssue As IssueInfo 552 Dim bUnsupportedType As Boolean 553 Dim bTrendline As Boolean 554 Dim bDatalabelWithLegend As Boolean 555 Dim bLegendPosition As Boolean 556 Dim bTitleFont As Boolean 557 Dim bPiechartDirection As Boolean 558 Dim bAxisInterval As Boolean 559 560 561 Set myIssue = New IssueInfo 562 bUnsupportedType = False 563 bTrendline = False 564 bDatalabelWithLegend = False 565 bLegendPosition = False 566 bTitleFont = False 567 bPiechartDirection = False 568 bAxisInterval = False 569 570 571 If (Not FormatissueMinor(myChart, bUnsupportedType, bTrendline, bDatalabelWithLegend, bLegendPosition, bTitleFont, bPiechartDirection, bAxisInterval)) And (Not BorderIssue) Then 572 GoTo FinalExit 573 Else 574 With myIssue 575 Dim NoteIndex As Long 576 NoteIndex = 0 577 578 .IssueID = CID_CHARTS_TABLES 579 .IssueType = RID_STR_EXCEL_ISSUE_CHARTS_AND_TABLES 580 581 .SubType = RID_STR_EXCEL_SUBISSUE_CHART_MINOR 582 .Location = .CLocationSheet 583 .SubLocation = myName 584 585 .IssueTypeXML = CSTR_ISSUE_CHARTS_TABLES 586 .SubTypeXML = CSTR_SUBISSUE_CHART_PIVOT 587 .locationXML = .CXMLLocationSheet 588 589 If bUnsupportedType Then 590 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_UNSUPPORTEDTYPE 591 .Values.Add getChartTypeAsString(myChart.ChartType) 592 ' bubble chart 593 If (myChart.ChartType = xlBubble Or myChart.ChartType = xlBubble3DEffect) Then 594 AddIssueDetailsNote myIssue, NoteIndex, RID_RESXLT_COST_CHART_Bubble_Comment 595 ' bar of pie and pie of pie chart 596 ElseIf (myChart.ChartType = xlPieOfPie Or myChart.ChartType = xlBarOfPie) Then 597 AddIssueDetailsNote myIssue, NoteIndex, RID_RESXLT_COST_CHART_BarOfPie_Comment 598 ' Scatter chart 599 ElseIf (myChart.ChartType = xlXYScatter Or myChart.ChartType = xlXYScatterLines _ 600 Or myChart.ChartType = xlXYScatterLinesNoMarkers _ 601 Or myChart.ChartType = xlXYScatterSmooth _ 602 Or myChart.ChartType = xlXYScatterSmoothNoMarkers) Then 603 AddIssueDetailsNote myIssue, NoteIndex, RID_RESXLT_COST_CHART_Scattered_Comment 604 ' radar chart 605 ElseIf (myChart.ChartType = xlRadarMarkers Or myChart.ChartType = xlRadar) Then 606 AddIssueDetailsNote myIssue, NoteIndex, RID_RESXLT_COST_CHART_Radar_Comment 607 ' radar filled chart 608 ElseIf (myChart.ChartType = xlRadarFilled) Then 609 AddIssueDetailsNote myIssue, NoteIndex, RID_RESXLT_COST_CHART_FilledRadar_Comment 610 ' surface chart 611 ElseIf (myChart.ChartType = xlSurface Or myChart.ChartType = xlSurfaceTopView _ 612 Or myChart.ChartType = xlSurfaceTopViewWireframe _ 613 Or myChart.ChartType = xlSurfaceWireframe) Then 614 AddIssueDetailsNote myIssue, NoteIndex, RID_RESXLT_COST_CHART_Surface_Comment 615 Else 616 AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_UNSUPPORTEDTYPE1 617 NoteIndex = NoteIndex + 1 618 AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_UNSUPPORTEDTYPE2 619 End If 620 NoteIndex = NoteIndex + 1 621 End If 622 If bTrendline Then 623 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_TRENDLINE 624 .Values.Add RID_STR_EXCEL_ATTRIBUTE_SET 625 AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_TRENDLINE 626 NoteIndex = NoteIndex + 1 627 End If 628 If bDatalabelWithLegend Then 629 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_DATALABELWITHLEGEND 630 .Values.Add RID_STR_EXCEL_ATTRIBUTE_SET 631 AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_DATALABELWITHLEGEND 632 NoteIndex = NoteIndex + 1 633 End If 634 If bLegendPosition Then 635 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_LEGENDPOSITION 636 .Values.Add RID_STR_EXCEL_ATTRIBUTE_NOTRIGHT 637 AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_LEGENDPOSITION 638 NoteIndex = NoteIndex + 1 639 End If 640 If bTitleFont Then 641 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_TITLEFONT 642 .Values.Add RID_STR_EXCEL_ATTRIBUTE_DIFFERENT 643 AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_TITLEFONT 644 NoteIndex = NoteIndex + 1 645 End If 646 If bPiechartDirection Then 647 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_PIE 648 .Values.Add RID_STR_EXCEL_ATTRIBUTE_SLICES_IN_DIFFERENT_DIRECTION 649 End If 650 If BorderIssue Then 651 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_BORDER 652 .Values.Add RID_STR_EXCEL_ATTRIBUTE_SET 653 AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_BORDER 654 NoteIndex = NoteIndex + 1 655 End If 656 If bAxisInterval Then 657 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_AXISINTERVAL 658 .Values.Add RID_STR_EXCEL_ATTRIBUTE_AUTO 659 AddIssueDetailsNote myIssue, NoteIndex, RID_STR_EXCEL_NOTE_AXISINTERVAL 660 NoteIndex = NoteIndex + 1 661 End If 662 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_CHARTNAME 663 .Values.Add myChart.name 664 End With 665 666 mAnalysis.IssuesCountArray(CID_CHARTS_TABLES) = _ 667 mAnalysis.IssuesCountArray(CID_CHARTS_TABLES) + 1 668 mAnalysis.Issues.Add myIssue 669 End If 670FinalExit: 671 Set myIssue = Nothing 672 Exit Sub 673 674HandleErrors: 675 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 676 Resume FinalExit 677End Sub 678 679Sub SetChartIssue(myChart As Chart, myName As String, strSubType As String, _ 680 strXMLSubType As String) 681 On Error GoTo HandleErrors 682 Dim currentFunctionName As String 683 currentFunctionName = "SetChartIssue" 684 Dim myIssue As IssueInfo 685 Dim bUnsupportedPosition As Boolean 686 687 Set myIssue = New IssueInfo 688 689 ' Common Settings 690 With myIssue 691 .IssueID = CID_CHARTS_TABLES 692 .IssueType = RID_STR_EXCEL_ISSUE_CHARTS_AND_TABLES 693 .SubType = strSubType 694 .Location = .CLocationSheet 695 .SubLocation = myName 696 697 .IssueTypeXML = CSTR_ISSUE_CHARTS_TABLES 698 .SubTypeXML = strXMLSubType 699 .locationXML = .CXMLLocationSheet 700 701 702 If myChart.HasTitle Then 703 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_TITLE 704 .Values.Add myChart.chartTitle.Text 705 End If 706 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_TYPE 707 .Values.Add myChart.ChartType 'TBD - getChartTypeAsString() convert to String 708 709 'Pie Chart 710 If (myChart.ChartType = xlPie) Or _ 711 (myChart.ChartType = xlPieExploded) Or _ 712 (myChart.ChartType = xlPieOfPie) Or _ 713 (myChart.ChartType = xl3DPie) Or _ 714 (myChart.ChartType = xl3DPieExploded) Then 715 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_PIE 716 .Values.Add RID_STR_EXCEL_ATTRIBUTE_SLICES_IN_DIFFERENT_DIRECTION 717 End If 718 719 If Not myChart.PivotLayout Is Nothing Then 720 'Pivot Chart 721 .SubType = RID_STR_EXCEL_SUBISSUE_PIVOT & " " & strSubType 722 723 'Pivot Chart details 724 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_PIVOT_TABLE_NAME 725 .Values.Add myChart.PivotLayout.PivotTable.name 726 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_PIVOT_FIELDS_VISIBLE 727 .Values.Add myChart.HasPivotFields 728 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_PIVOT_FIELDS_NUM 729 .Values.Add myChart.PivotLayout.PivotTable.PivotFields.count 730 End If 731 End With 732 733 mAnalysis.IssuesCountArray(CID_CHARTS_TABLES) = _ 734 mAnalysis.IssuesCountArray(CID_CHARTS_TABLES) + 1 735 mAnalysis.Issues.Add myIssue 736 737FinalExit: 738 Set myIssue = Nothing 739 Exit Sub 740 741HandleErrors: 742 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 743 Resume FinalExit 744End Sub 745 746Function getLineStyleAsString(myLineStyle As XlLineStyle) As String 747 748 On Error GoTo HandleErrors 749 Dim currentFunctionName As String 750 currentFunctionName = "getLineStyleAsString" 751 752 Dim strVal As String 753 754 Select Case myLineStyle 755 Case xlContinuous 756 strVal = RID_STR_EXCEL_ENUMERATION_LINE_STYLE_CONTINUOUS 757 Case xlDash 758 strVal = RID_STR_EXCEL_ENUMERATION_LINE_STYLE_DASH 759 Case xlDashDot 760 strVal = RID_STR_EXCEL_ENUMERATION_LINE_STYLE_DASHDOT 761 Case xlDot 762 strVal = RID_STR_EXCEL_ENUMERATION_LINE_STYLE_DOT 763 Case xlDouble 764 strVal = RID_STR_EXCEL_ENUMERATION_LINE_STYLE_DOUBLE 765 Case xlSlantDashDot 766 strVal = RID_STR_EXCEL_ENUMERATION_LINE_STYLE_SLANTDASHDOT 767 Case xlLineStyleNone 768 strVal = RID_STR_EXCEL_ENUMERATION_LINE_STYLE_LINESTYLENONE 769 Case Else 770 strVal = RID_STR_EXCEL_ENUMERATION_UNKNOWN 771 End Select 772 773 774 getLineStyleAsString = strVal 775HandleErrors: 776 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 777End Function 778 779Function getChartTypeAsString(myChartType As XlChartType) As String 780 '********************************************************* 781 '**** Localisation: ON HOLD ****************************** 782 '********************************************************* 783 On Error GoTo HandleErrors 784 Dim currentFunctionName As String 785 currentFunctionName = "getChartTypeAsString" 786 787 Dim strVal As String 788 789 Select Case myChartType 790 Case xl3DArea 791 strVal = "3DArea" 792 Case xl3DAreaStacked 793 strVal = "3DAreaStacked" 794 Case xl3DAreaStacked100 795 strVal = "3DAreaStacked100" 796 Case xl3DBarClustered 797 strVal = "3DBarClustered" 798 Case xl3DBarStacked 799 strVal = "xl3DBarStacked" 800 Case xl3DBarStacked100 801 strVal = "xl3DBarStacked100" 802 Case xl3DColumn 803 strVal = "3DColumn" 804 Case xl3DColumnClustered 805 strVal = "xl3DColumnClustered" 806 Case xl3DColumnStacked 807 strVal = "xl3DColumnStacked" 808 Case xl3DColumnStacked100 809 strVal = "xl3DColumnStacked100" 810 Case xl3DLine 811 strVal = "3DLine" 812 Case xl3DPie 813 strVal = "3DPie" 814 Case xl3DPieExploded 815 strVal = "3DPieExploded" 816 Case xlArea 817 strVal = "Area" 818 Case xlAreaStacked 819 strVal = "AreaStacked" 820 Case xlAreaStacked100 821 strVal = "AreaStacked100" 822 Case xlBarClustered 823 strVal = "BarClustered" 824 Case xlBarOfPie 825 strVal = "BarOfPie" 826 Case xlBarStacked 827 strVal = "BarStacked" 828 Case xlBarStacked100 829 strVal = "BarStacked100" 830 Case xlBubble 831 strVal = "Bubble" 832 Case xlBubble3DEffect 833 strVal = "Bubble3DEffect" 834 Case xlColumnClustered 835 strVal = "ColumnClustered" 836 Case xlColumnStacked 837 strVal = "ColumnStacked" 838 Case xlColumnStacked100 839 strVal = "ColumnStacked100" 840 Case xlConeBarClustered 841 strVal = "ConeBarClustered" 842 Case xlConeBarStacked 843 strVal = "ConeBarStacked" 844 Case xlConeBarStacked100 845 strVal = "ConeBarStacked100" 846 Case xlConeCol 847 strVal = "ConeCol" 848 Case xlConeColClustered 849 strVal = "ConeColClustered" 850 Case xlConeColStacked 851 strVal = "ConeColStacked" 852 Case xlConeColStacked100 853 strVal = "ConeColStacked100" 854 Case xlCylinderBarClustered 855 strVal = "CylinderBarClustered" 856 Case xlCylinderBarStacked 857 strVal = "CylinderBarStacked" 858 Case xlCylinderBarStacked100 859 strVal = "CylinderBarStacked100" 860 Case xlCylinderCol 861 strVal = "CylinderCol" 862 Case xlCylinderColClustered 863 strVal = "CylinderColClustered" 864 Case xlCylinderColStacked 865 strVal = "CylinderColStacked" 866 Case xlCylinderColStacked100 867 strVal = "CylinderColStacked100" 868 Case xlDoughnut 869 strVal = "Doughnut" 870 Case xlLine 871 strVal = "Line" 872 Case xlLineMarkers 873 strVal = "LineMarkers" 874 Case xlLineMarkersStacked 875 strVal = "LineMarkersStacked" 876 Case xlLineMarkersStacked100 877 strVal = "LineMarkersStacked100" 878 Case xlLineStacked 879 strVal = "LineStacked" 880 Case xlLineStacked100 881 strVal = "LineStacked100" 882 Case xlPie 883 strVal = "Pie" 884 Case xlPieExploded 885 strVal = "PieExploded" 886 Case xlPieOfPie 887 strVal = "PieOfPie" 888 Case xlPyramidBarClustered 889 strVal = "PyramidBarClustered" 890 Case xlPyramidBarStacked 891 strVal = "PyramidBarStacked" 892 Case xlPyramidBarStacked100 893 strVal = "PyramidBarStacked100" 894 Case xlPyramidCol 895 strVal = "PyramidCol" 896 Case xlPyramidColClustered 897 strVal = "PyramidColClustered" 898 Case xlPyramidColStacked 899 strVal = "PyramidColStacked" 900 Case xlPyramidColStacked100 901 strVal = "PyramidColStacked100" 902 Case xlRadar 903 strVal = "Radar" 904 Case xlRadarFilled 905 strVal = "RadarFilled" 906 Case xlRadarMarkers 907 strVal = "RadarMarkers" 908 Case xlStockHLC 909 strVal = "StockHLC" 910 Case xlStockOHLC 911 strVal = "StockOHLC" 912 Case xlStockVHLC 913 strVal = "StockVHLC" 914 Case xlStockVOHLC 915 strVal = "StockVOHLC" 916 Case xlSurface 917 strVal = "Surface" 918 Case xlSurfaceTopView 919 strVal = "SurfaceTopView" 920 Case xlSurfaceTopViewWireframe 921 strVal = "SurfaceTopViewWireframe" 922 Case xlSurfaceWireframe 923 strVal = "SurfaceWireframe" 924 Case xlXYScatter 925 strVal = "XYScatter" 926 Case xlXYScatterLines 927 strVal = "XYScatterLines" 928 Case xlXYScatterLinesNoMarkers 929 strVal = "XYScatterLinesNoMarkers" 930 Case xlXYScatterSmooth 931 strVal = "XYScatterSmooth" 932 Case xlXYScatterSmoothNoMarkers 933 strVal = "XYScatterSmoothNoMarkers" 934 Case Else 935 strVal = RID_STR_EXCEL_ENUMERATION_UNKNOWN 936 End Select 937 938 getChartTypeAsString = strVal 939 940 Exit Function 941 942HandleErrors: 943 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 944End Function 945 946Sub HandleZoomIssue(currentSheet) 947 Dim myIssue As IssueInfo 948 Dim currentFunctionName As String 949 currentFunctionName = "HandleZoomIssue" 950 951 On Error GoTo HandleErrors 952 953 Set myIssue = New IssueInfo 954 With myIssue 955 .IssueID = CID_FORMAT 956 .IssueType = RID_STR_EXCEL_ISSUE_FORMAT 957 .SubType = RID_STR_EXCEL_SUBISSUE_ZOOM 958 .Location = .CLocationSheet 959 .SubLocation = currentSheet.name 960 961 .IssueTypeXML = CSTR_ISSUE_FORMAT 962 .SubTypeXML = CSTR_SUBISSUE_ZOOM 963 .locationXML = .CXMLLocationSheet 964 965 AddIssueDetailsNote myIssue, 0, RID_STR_EXCEL_NOTE_ZOOM 966 End With 967 968 mAnalysis.IssuesCountArray(CID_FORMAT) = _ 969 mAnalysis.IssuesCountArray(CID_FORMAT) + 1 970 mAnalysis.Issues.Add myIssue 971 972FinalExit: 973 Set myIssue = Nothing 974 Exit Sub 975 976HandleErrors: 977 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 978 Resume FinalExit 979End Sub 980 981Sub Analyze_SheetDisplay(aWB As Workbook) 982 On Error GoTo HandleErrors 983 Dim currentFunctionName As String 984 currentFunctionName = "Analyze_SheetDisplay" 985 986 If aWB.Sheets.count = 1 Then Exit Sub 987 988 Dim lastZoomVal As Integer 989 Dim bInitZoom As Boolean 990 Dim bZoomChanged As Boolean 991 Dim ws As Object 992 993 bInitZoom = True 994 bZoomChanged = False 995 996 For Each ws In aWB.Sheets 997 ws.Activate 998 999 On Error GoTo HandleErrors 1000 1001 If bInitZoom Then 1002 lastZoomVal = ActiveWindow.Zoom 1003 bInitZoom = False 1004 ElseIf Not bZoomChanged Then 1005 If ActiveWindow.Zoom <> lastZoomVal Then 1006 bZoomChanged = True 1007 HandleZoomIssue ws 1008 End If 1009 End If 1010 If bZoomChanged Then Exit For 1011 Next ws 1012 1013FinalExit: 1014 Exit Sub 1015 1016HandleErrors: 1017 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1018 Resume FinalExit 1019End Sub 1020 1021Sub Analyze_SheetLimits(aWB As Workbook) 1022 On Error GoTo HandleErrors 1023 Dim currentFunctionName As String 1024 currentFunctionName = "Analyze_SheetLimits" 1025 Dim myIssue As IssueInfo 1026 1027 If aWB.Sheets.count < CWORKBOOK_SHEETS_LIMIT + 1 Then Exit Sub 1028 1029 Set myIssue = New IssueInfo 1030 With myIssue 1031 .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES 1032 .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES 1033 .SubType = RID_STR_EXCEL_SUBISSUE_MAX_SHEETS_EXCEEDED 1034 .Location = .CLocationWorkBook 1035 .SubLocation = aWB.name 1036 1037 .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES 1038 .SubTypeXML = CSTR_SUBISSUE_MAX_SHEETS_EXCEEDED 1039 .locationXML = .CXMLLocationWorkBook 1040 1041 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_NUMBER_OF_SHEETS 1042 .Values.Add aWB.Sheets.count 1043 1044 AddIssueDetailsNote myIssue, 0, RID_STR_EXCEL_NOTE_SHEET_LIMITS_1 & CWORKBOOK_SHEETS_LIMIT 1045 AddIssueDetailsNote myIssue, 1, RID_STR_EXCEL_NOTE_SHEET_LIMITS_2 & CWORKBOOK_SHEETS_LIMIT 1046 End With 1047 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _ 1048 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1 1049 mAnalysis.Issues.Add myIssue 1050 Set myIssue = Nothing 1051 1052FinalExit: 1053 Set myIssue = Nothing 1054 Exit Sub 1055 1056HandleErrors: 1057 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1058 Resume FinalExit 1059End Sub 1060 1061Sub Analyze_SheetIssues(aWB As Workbook) 1062 On Error GoTo HandleErrors 1063 Dim currentFunctionName As String 1064 currentFunctionName = "Analyze_SheetIssues" 1065 1066 Dim myWrkSheet As Worksheet 1067 1068 For Each myWrkSheet In aWB.Worksheets 1069 Analyze_OLEEmbedded myWrkSheet 1070 Analyze_CellInSheetIssues myWrkSheet 1071 Analyze_EmbeddedCharts myWrkSheet 1072 Analyze_SheetName myWrkSheet 1073 Analyze_QueryTables myWrkSheet 1074 Next myWrkSheet 1075 1076 Exit Sub 1077HandleErrors: 1078 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1079End Sub 1080 1081Sub Analyze_SheetName(mySheet As Worksheet) 1082 On Error GoTo HandleErrors 1083 Dim currentFunctionName As String 1084 currentFunctionName = "Analyze_SheetName" 1085 Dim myIssue As IssueInfo 1086 Set myIssue = New IssueInfo 1087 1088 Dim invalidCharacters As String 1089 invalidCharacters = InvalidSheetNameCharacters(mySheet.name) 1090 If Len(invalidCharacters) <> 0 Then 1091 With myIssue 1092 .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES 1093 .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES 1094 .SubType = RID_STR_EXCEL_SUBISSUE_INVALID_WORKSHEET_NAME 1095 .Location = .CLocationSheet 1096 .SubLocation = mySheet.name 1097 1098 .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES 1099 .SubTypeXML = CSTR_SUBISSUE_INVALID_WORKSHEET_NAME 1100 .locationXML = .CXMLLocationSheet 1101 1102 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_INVALIDCHARACTER 1103 .Values.Add invalidCharacters 1104 1105 AddIssueDetailsNote myIssue, 0, RID_STR_EXCEL_NOTE_INVALIDWORKSHEETNAME 1106 1107 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _ 1108 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1 1109 End With 1110 mAnalysis.Issues.Add myIssue 1111 End If 1112 1113FinalExit: 1114 Set myIssue = Nothing 1115 Exit Sub 1116 1117HandleErrors: 1118 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1119 Resume FinalExit 1120End Sub 1121 1122Function InvalidSheetNameCharacters(aName As String) As String 1123 On Error GoTo HandleErrors 1124 Dim currentFunctionName As String 1125 currentFunctionName = "InvalidSheetNameCharacters" 1126 1127 Dim I As Integer 1128 Dim NameCount As Integer 1129 Dim newBadCharLine As String 1130 Dim invalidCharacterDetails As String 1131 Dim BadCharPosition As String 1132 Dim theBadChars As BadSheetNameChar 1133 NameCount = Len(aName) 1134 invalidCharacterDetails = "" 1135 For I = 1 To NameCount 1136 theBadChars.BadChar = Mid(aName, I, 1) 1137 theBadChars.Position = I 1138 BadCharPosition = CStr(theBadChars.Position) 1139 Select Case theBadChars.BadChar 1140 Case "[", "]", "{", "}", ".", "!", "%", "$", "^", ".", "&", "(", ")", _ 1141 "-", "=", "+", "~", "#", "@", "'", ";", "<", ">", ",", "|", "`" 1142 newBadCharLine = ReplaceTopic2Tokens(RID_STR_EXCEL_ATTRIBUTE_BADCHARACTER, CR_BADCHAR, _ 1143 theBadChars.BadChar, CR_BADCHARNUM, BadCharPosition) 1144 invalidCharacterDetails = invalidCharacterDetails + newBadCharLine + ", " 1145 Case Else 1146 End Select 1147 Next I 1148 If Len(invalidCharacterDetails) > 0 Then 1149 InvalidSheetNameCharacters = Left(invalidCharacterDetails, (Len(invalidCharacterDetails) - 2)) 1150 Else 1151 InvalidSheetNameCharacters = "" 1152 End If 1153 Exit Function 1154 1155HandleErrors: 1156 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1157 1158End Function 1159 1160Sub Analyze_QueryTables(mySheet As Worksheet) 1161 On Error GoTo HandleErrors 1162 Dim currentFunctionName As String 1163 currentFunctionName = "Analyze_QueryTables" 1164 1165 Dim aTable As QueryTable 1166 Dim myIssue As IssueInfo 1167 Set myIssue = New IssueInfo 1168 1169 For Each aTable In mySheet.QueryTables 1170 If (aTable.QueryType = xlADORecordset) Or _ 1171 (aTable.QueryType = xlDAORecordSet) Or _ 1172 (aTable.QueryType = xlODBCQuery) Or _ 1173 (aTable.QueryType = xlOLEDBQuery) Then 1174 1175 With myIssue 1176 .IssueID = CID_CHARTS_TABLES 1177 .IssueType = RID_STR_EXCEL_ISSUE_CHARTS_AND_TABLES 1178 .SubType = RID_RESXLS_COST_DB_Query 1179 .Location = .CLocationSheet 1180 .SubLocation = mySheet.name 1181 1182 .IssueTypeXML = CSTR_ISSUE_CHARTS_TABLES 1183 .SubTypeXML = CSTR_SUBISSUE_DB_QUERY 1184 .locationXML = .CXMLLocationSheet 1185 1186 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_DB_QUERY 1187 .Values.Add aTable.Connection 1188 1189 AddIssueDetailsNote myIssue, 0, RID_STR_EXCEL_NOTE_DB_QUERY 1190 1191 mAnalysis.IssuesCountArray(CID_CHARTS_TABLES) = _ 1192 mAnalysis.IssuesCountArray(CID_CHARTS_TABLES) + 1 1193 End With 1194 mAnalysis.Issues.Add myIssue 1195 End If 1196 Next aTable 1197 1198FinalExit: 1199 Set myIssue = Nothing 1200 Exit Sub 1201 1202HandleErrors: 1203 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1204 Resume FinalExit 1205End Sub 1206 1207Sub Analyze_WorkbookVersion(aWB As Workbook) 1208 On Error GoTo HandleErrors 1209 Dim currentFunctionName As String 1210 currentFunctionName = "Analyze_WorkbookVersion" 1211 Dim myIssue As IssueInfo 1212 Set myIssue = New IssueInfo 1213 Dim aProp As Variant 1214 1215 If IsOldVersion(aWB.FileFormat) Then 1216 With myIssue 1217 .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES 1218 .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES 1219 .SubType = RID_STR_EXCEL_SUBISSUE_OLD_WORKBOOK_VERSION 1220 .Location = .CLocationWorkBook 1221 1222 .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES 1223 .SubTypeXML = CSTR_SUBISSUE_OLD_WORKBOOK_VERSION 1224 .locationXML = .CXMLLocationWorkBook 1225 1226 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_WORKBOOK_VERSION 1227 .Values.Add aWB.FileFormat 1228 1229 AddIssueDetailsNote myIssue, 0, RID_STR_EXCEL_NOTE_OLDWORKBOOKVERSION 1230 1231 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _ 1232 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1 1233 End With 1234 Call DoPreparation(mAnalysis, myIssue, RID_STR_EXCEL_NOTE_OLD_OLDWORKBOOKVERSION_PREPARABLE, aProp, aWB) 1235 1236 mAnalysis.Issues.Add myIssue 1237 End If 1238 1239FinalExit: 1240 Set myIssue = Nothing 1241 Exit Sub 1242 1243HandleErrors: 1244 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1245 Resume FinalExit 1246End Sub 1247 1248Function getRange(myRange As Range) As String 1249 On Error GoTo HandleErrors 1250 Dim currentFunctionName As String 1251 currentFunctionName = "getRange" 1252 getRange = "" 1253 1254 On Error Resume Next 1255 getRange = myRange.Address(RowAbsolute:=False, ColumnAbsolute:=False, ReferenceStyle:=xlA1) 1256 1257FinalExit: 1258 Exit Function 1259 1260HandleErrors: 1261 WriteDebug currentFunctionName & " : myRange.name " & myRange.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1262 Resume FinalExit 1263End Function 1264 1265Sub Analyze_CellInSheetIssues(mySheet As Worksheet) 1266 On Error GoTo HandleErrors 1267 Dim currentFunctionName As String 1268 currentFunctionName = "Analyze_CellInSheetIssues" 1269 Dim myCellRng As Range 1270 1271 Set myCellRng = mySheet.UsedRange 1272 Call CheckAllCellFormatting(myCellRng, mySheet.name) 1273 Call CheckAllCellFunctions(myCellRng, mySheet.name) 1274 1275FinalExit: 1276 Exit Sub 1277HandleErrors: 1278 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1279End Sub 1280 1281Sub CheckAllCellFormatting(CurrRange As Range, myName As String) 1282 On Error GoTo HandleErrors 1283 Dim currentFunctionName As String 1284 currentFunctionName = "CheckAllCellFormatting" 1285 1286 Dim myCell As Range 1287 Dim myCellAttri As CellAtrributes 1288 Dim bCellIssue As Boolean 1289 Dim bCellIssueAll As Boolean 1290 Dim startTime As Single 1291 1292 bCellIssue = False 1293 bCellIssueAll = False 1294 startTime = Timer 1295 1296 For Each myCell In CurrRange 1297 bCellIssue = CheckCellFormatting(myCell, myCellAttri) 1298 bCellIssueAll = bCellIssueAll Or bCellIssue 1299 If (Timer - gExcelMaxRangeProcessTime > startTime) Then 1300 WriteDebug currentFunctionName & " : [" & myName & _ 1301 "]Too much time needed, abortet cell formatting check." 1302 Exit For 1303 End If 1304 Next 1305 1306FinalExit: 1307 If bCellIssueAll Then 1308 ReportCellFormattingIssue myName, myCellAttri 1309 End If 1310 1311 Exit Sub 1312 1313HandleErrors: 1314 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1315End Sub 1316 1317Function CheckLineFormatIssue(myRange As Range, edge As XlBordersIndex) As Boolean 1318 CheckLineFormatIssue = (myRange.Borders(edge).LineStyle <> xlContinuous) And _ 1319 (myRange.Borders(edge).LineStyle <> xlDouble) And _ 1320 (myRange.Borders(edge).LineStyle <> xlLineStyleNone) 1321End Function 1322 1323Private Function CheckCellFormatting(myCell As Range, myCellAttri As CellAtrributes) As Boolean 1324 Dim currentFunctionName As String 1325 currentFunctionName = "CheckCellFormatting" 1326 1327 On Error GoTo HandleErrors 1328 1329 Dim bCellLineFormatIssue As Boolean 1330 1331 CheckCellFormatting = False 1332 1333 bCellLineFormatIssue = CheckLineFormatIssue(myCell, xlEdgeBottom) Or _ 1334 CheckLineFormatIssue(myCell, xlEdgeLeft) Or _ 1335 CheckLineFormatIssue(myCell, xlEdgeRight) Or _ 1336 CheckLineFormatIssue(myCell, xlEdgeTop) 1337 1338 CheckCellFormatting = bCellLineFormatIssue Or _ 1339 (myCell.Interior.Pattern <> xlPatternSolid And myCell.Interior.Pattern <> xlPatternNone) 1340 1341 If Not CheckCellFormatting Then Exit Function 1342 1343 If bCellLineFormatIssue Then 1344 myCellAttri.LineStyle = myCellAttri.LineStyle + 1 1345 End If 1346 If (myCell.Interior.Pattern <> xlPatternSolid And myCell.Interior.Pattern <> xlPatternNone) Then 1347 myCellAttri.FillPattern = myCellAttri.FillPattern + 1 1348 End If 1349 1350 Exit Function 1351HandleErrors: 1352 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1353End Function 1354 1355Private Sub ReportCellFormattingIssue(myName As String, myCellAttri As CellAtrributes) 1356 Dim currentFunctionName As String 1357 currentFunctionName = "ReportCellFormattingIssue" 1358 1359 On Error GoTo HandleErrors 1360 1361 Dim myIssue As IssueInfo 1362 Set myIssue = New IssueInfo 1363 1364 With myIssue 1365 .IssueID = CID_FORMAT 1366 .IssueType = RID_STR_EXCEL_ISSUE_FORMAT 1367 .SubType = RID_STR_EXCEL_SUBISSUE_ATTRIBUTES 1368 .Location = .CLocationSheet 1369 1370 .IssueTypeXML = CSTR_ISSUE_FORMAT 1371 .SubTypeXML = CSTR_SUBISSUE_ATTRIBUTES 1372 .locationXML = .CXMLLocationSheet 1373 1374 .SubLocation = myName 1375 '.Line = myCell.row 1376 '.column = Chr(myCell.column + 65 - 1) 1377 1378 Dim noteCount As Long 1379 noteCount = 0 1380 1381 If myCellAttri.LineStyle > 0 Then 1382 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_LINE_STYLE 1383 .Values.Add RID_STR_EXCEL_ATTRIBUTE_DASHED_DOT 1384 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_NUMBER_OF_CELLS 1385 .Values.Add myCellAttri.LineStyle 1386 AddIssueDetailsNote myIssue, noteCount, RID_STR_EXCEL_NOTE_CELL_ATTRIBUTES_3 1387 noteCount = noteCount + 1 1388 End If 1389 If myCellAttri.FillPattern > 0 Then 1390 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_FILL_PATTERN 1391 .Values.Add RID_STR_EXCEL_ATTRIBUTE_PATTERNED 1392 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_NUMBER_OF_CELLS 1393 .Values.Add myCellAttri.FillPattern 1394 AddIssueDetailsNote myIssue, noteCount, RID_STR_EXCEL_NOTE_CELL_ATTRIBUTES_4 1395 noteCount = noteCount + 1 1396 End If 1397 1398 1399 mAnalysis.IssuesCountArray(CID_FORMAT) = _ 1400 mAnalysis.IssuesCountArray(CID_FORMAT) + 1 1401 End With 1402 1403 mAnalysis.Issues.Add myIssue 1404 1405FinalExit: 1406 Set myIssue = Nothing 1407 Exit Sub 1408HandleErrors: 1409 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1410End Sub 1411 1412Sub CheckAllCellFunctions(CurrRange As Range, myName As String) 1413 On Error GoTo HandleErrors 1414 Dim currentFunctionName As String 1415 currentFunctionName = "CheckAllCellFunctions" 1416 1417 Dim myCell As Range 1418 Dim startTime As Single 1419 1420 startTime = Timer 1421 1422 For Each myCell In CurrRange 1423 Call CheckCellFunction(myCell, myName) 1424 If (Timer - gExcelMaxRangeProcessTime > startTime) Then 1425 WriteDebug currentFunctionName & " : [" & myName & _ 1426 "]Too much time needed, abortet cell functions check (xlCellTypeFormulas)." 1427 Exit For 1428 End If 1429 Next 1430 1431FinalExit: 1432 Exit Sub 1433HandleErrors: 1434 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1435End Sub 1436 1437Sub CheckCellFunction(myCell As Range, myName As String) 1438 Dim currentFunctionName As String 1439 currentFunctionName = "CheckCellFunction" 1440 1441 On Error GoTo HandleErrors 1442 Dim bCellFunctionIssue As Boolean 1443 Dim bCellINFOFunctionIssue As Boolean 1444 Dim bCellERROR_TYPEFunctionIssue As Boolean 1445 Dim bCellExternalFunctionIssue As Boolean 1446 Dim bHasDateDifFunction As Boolean 1447 Dim bHasPhoneticFunction As Boolean 1448 Dim aFormularStr As String 1449 1450 aFormularStr = myCell.FormulaR1C1 1451 1452 If (aFormularStr = Null) Then Exit Sub 1453 If (aFormularStr = "") Then Exit Sub 1454 1455 bCellINFOFunctionIssue = (InStr(aFormularStr, "INFO(") <> 0) 1456 bCellERROR_TYPEFunctionIssue = (InStr(aFormularStr, "ERROR.TYPE(") <> 0) 1457 bCellExternalFunctionIssue = (InStr(aFormularStr, ".xls!") <> 0) 1458 bHasDateDifFunction = (InStr(aFormularStr, "DATEDIF(") <> 0) 1459 bHasPhoneticFunction = (InStr(aFormularStr, "PHONETIC(") <> 0) 1460 1461 bCellFunctionIssue = bCellINFOFunctionIssue Or bCellERROR_TYPEFunctionIssue _ 1462 Or bCellExternalFunctionIssue Or bHasDateDifFunction Or bHasPhoneticFunction 1463 1464 If Not bCellFunctionIssue Then Exit Sub 1465 1466 Dim myIssue As IssueInfo 1467 Set myIssue = New IssueInfo 1468 1469 With myIssue 1470 .IssueID = CID_FUNCTIONS 1471 .IssueType = RID_STR_EXCEL_ISSUE_FUNCTIONS 1472 .Location = .CLocationSheet 1473 1474 .IssueTypeXML = CSTR_ISSUE_FUNCTIONS 1475 .locationXML = .CXMLLocationSheet 1476 1477 .SubLocation = myName 1478 .Line = myCell.row 1479 .column = Chr(myCell.column + 65 - 1) 1480 1481 Dim noteCount As Long 1482 noteCount = 0 1483 If bCellINFOFunctionIssue Then 1484 .SubTypeXML = CSTR_SUBISSUE_INFO 1485 .SubType = RID_STR_EXCEL_SUBISSUE_INFO 1486 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_FUNCTION_STRING 1487 .Values.Add myCell.FormulaR1C1 1488 AddIssueDetailsNote myIssue, noteCount, RID_STR_EXCEL_NOTE_CELL_FUNCTIONS_1 1489 noteCount = noteCount + 1 1490 End If 1491 If bCellERROR_TYPEFunctionIssue Then 1492 .SubTypeXML = CSTR_SUBISSUE_ERROR_TYPE 1493 .SubType = RID_STR_EXCEL_SUBISSUE_ERROR_TYPE 1494 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_FUNCTION_STRING 1495 .Values.Add myCell.FormulaR1C1 1496 AddIssueDetailsNote myIssue, noteCount, RID_STR_EXCEL_NOTE_CELL_FUNCTIONS_2 1497 noteCount = noteCount + 1 1498 End If 1499 If bCellExternalFunctionIssue Then 1500 .SubTypeXML = CSTR_SUBISSUE_EXTERNAL 1501 .SubType = RID_STR_EXCEL_SUBISSUE_EXTERNAL 1502 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_FUNCTION_STRING 1503 .Values.Add myCell.FormulaR1C1 1504 AddIssueDetailsNote myIssue, noteCount, RID_STR_EXCEL_NOTE_CELL_FUNCTIONS_3 1505 noteCount = noteCount + 1 1506 End If 1507 If bHasDateDifFunction Then 1508 .SubTypeXML = CSTR_SUBISSUE_DATEDIF 1509 .SubType = RID_STR_EXCEL_SUBISSUE_DATEDIF 1510 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_FUNCTION_STRING 1511 .Values.Add myCell.FormulaR1C1 1512 AddIssueDetailsNote myIssue, noteCount, RID_STR_EXCEL_NOTE_CELL_FUNCTIONS_DATEDIF 1513 noteCount = noteCount + 1 1514 End If 1515 If bHasPhoneticFunction Then 1516 .SubTypeXML = CSTR_SUBISSUE_PHONETIC 1517 .SubType = RID_STR_EXCEL_SUBISSUE_PHONETIC 1518 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_FUNCTION_STRING 1519 .Values.Add myCell.FormulaR1C1 1520 AddIssueDetailsNote myIssue, noteCount, RID_STR_EXCEL_NOTE_CELL_FUNCTIONS_PHONETIC 1521 noteCount = noteCount + 1 1522 End If 1523 1524 mAnalysis.IssuesCountArray(CID_FUNCTIONS) = _ 1525 mAnalysis.IssuesCountArray(CID_FUNCTIONS) + 1 1526 End With 1527 1528 mAnalysis.Issues.Add myIssue 1529 1530FinalExit: 1531 Set myIssue = Nothing 1532 Exit Sub 1533HandleErrors: 1534 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1535End Sub 1536 1537Sub Analyze_Password_Protection(aWB As Workbook) 1538 On Error GoTo HandleErrors 1539 Dim currentFunctionName As String 1540 currentFunctionName = "Analyze_Password_Protection" 1541 Dim myIssue As IssueInfo 1542 Set myIssue = New IssueInfo 1543 1544 If aWB.HasPassword Or aWB.WriteReserved Then 1545 With myIssue 1546 .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES 1547 .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES 1548 .SubType = RID_STR_COMMON_SUBISSUE_PASSWORDS_PROTECTION 1549 1550 .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES 1551 .SubTypeXML = CSTR_SUBISSUE_PASSWORD_PROTECTION 1552 .locationXML = .CLocationWorkBook 1553 1554 .Location = .CLocationWorkBook 1555 1556 If aWB.HasPassword Then 1557 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_PASSWORD_TO_OPEN 1558 .Values.Add RID_STR_EXCEL_ATTRIBUTE_SET 1559 End If 1560 If aWB.WriteReserved Then 1561 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_PASSWORD_TO_MODIFY 1562 .Values.Add RID_STR_EXCEL_ATTRIBUTE_SET 1563 End If 1564 1565 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _ 1566 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1 1567 End With 1568 1569 mAnalysis.Issues.Add myIssue 1570 End If 1571 1572FinalExit: 1573 Set myIssue = Nothing 1574 Exit Sub 1575HandleErrors: 1576 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1577 Resume FinalExit 1578End Sub 1579 1580Sub SetDocProperties(docAnalysis As DocumentAnalysis, wb As Workbook, fso As FileSystemObject) 1581 On Error GoTo HandleErrors 1582 Dim currentFunctionName As String 1583 currentFunctionName = "SetProperties" 1584 Dim f As File 1585 Set f = fso.GetFile(docAnalysis.name) 1586 1587 Const appPropertyAppName = 9 1588 Const appPropertyLastAuthor = 7 1589 Const appPropertyRevision = 8 1590 Const appPropertyTemplate = 6 1591 Const appPropertyTimeCreated = 11 1592 Const appPropertyTimeLastSaved = 12 1593 1594 On Error Resume Next 1595 docAnalysis.PageCount = wb.Sheets.count 1596 docAnalysis.Created = f.DateCreated 1597 docAnalysis.Modified = f.DateLastModified 1598 docAnalysis.Accessed = f.DateLastAccessed 1599 docAnalysis.Printed = DateValue("01/01/1900") 1600 On Error GoTo HandleErrors 1601 1602 On Error Resume Next 'Some apps may not support all props 1603 docAnalysis.Application = getAppSpecificApplicationName & " " & Application.Version 1604 'docAnalysis.Application = wb.BuiltinDocumentProperties(appPropertyAppName) 1605 'If InStr(docAnalysis.Application, "Microsoft") = 1 Then 1606 ' docAnalysis.Application = Mid(docAnalysis.Application, Len("Microsoft") + 2) 1607 'End If 1608 'If InStr(Len(docAnalysis.Application) - 2, docAnalysis.Application, ".") = 0 Then 1609 ' docAnalysis.Application = docAnalysis.Application & " " & Application.Version 1610 'End If 1611 1612 docAnalysis.SavedBy = _ 1613 wb.BuiltinDocumentProperties(appPropertyLastAuthor) 1614 docAnalysis.Revision = _ 1615 val(wb.BuiltinDocumentProperties(appPropertyRevision)) 1616 docAnalysis.Template = _ 1617 fso.GetFileName(wb.BuiltinDocumentProperties(appPropertyTemplate)) 1618 docAnalysis.Modified = _ 1619 wb.BuiltinDocumentProperties(appPropertyTimeLastSaved) 1620 1621FinalExit: 1622 Set f = Nothing 1623 Exit Sub 1624 1625HandleErrors: 1626 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1627 Resume FinalExit 1628End Sub 1629 1630Sub Analyze_OLEEmbedded(wrkSheet As Worksheet) 1631 On Error GoTo HandleErrors 1632 Dim currentFunctionName As String 1633 currentFunctionName = "Analyze_OLEEmbedded" 1634 1635 ' Handle Shapes 1636 Dim aShape As Shape 1637 For Each aShape In wrkSheet.Shapes 1638 Analyze_OLEEmbeddedSingleShape mAnalysis, aShape, wrkSheet.name 1639 Analyze_Lines mAnalysis, aShape, wrkSheet.name 1640 Analyze_Transparency mAnalysis, aShape, wrkSheet.name 1641 Analyze_Gradients mAnalysis, aShape, wrkSheet.name 1642 Next aShape 1643 1644 Exit Sub 1645 1646HandleErrors: 1647 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1648End Sub 1649 1650Sub Analyze_Workbook_Protection(aWB As Workbook) 1651 On Error GoTo HandleErrors 1652 Dim currentFunctionName As String 1653 currentFunctionName = "Analyze_Workbook_Protection" 1654 Dim myIssue As IssueInfo 1655 Set myIssue = New IssueInfo 1656 Dim bProtectSharing As Boolean 1657 Dim bProtectStructure As Boolean 1658 Dim bProtectWindows As Boolean 1659 1660 bProtectSharing = False 1661 bProtectStructure = False 1662 bProtectWindows = False 1663 1664 If Not WorkbookProtectTest(aWB, bProtectSharing, bProtectStructure, bProtectWindows) Then 1665 GoTo FinalExit 1666 End If 1667 1668 Set myIssue = New IssueInfo 1669 With myIssue 1670 .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES 1671 .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES 1672 .SubType = RID_STR_EXCEL_SUBISSUE_WORKBOOK_PROTECTION 1673 .Location = .CLocationWorkBook 1674 1675 .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES 1676 .SubTypeXML = CSTR_SUBISSUE_WORKBOOK_PROTECTION 1677 .locationXML = .CXMLLocationWorkBook 1678 1679 If bProtectSharing Then 1680 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_PROTECT_TYPE_SHARING 1681 .Values.Add RID_STR_EXCEL_ATTRIBUTE_SET 1682 End If 1683 If bProtectStructure Then 1684 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_PROTECT_TYPE_STRUCTURE 1685 .Values.Add RID_STR_EXCEL_ATTRIBUTE_SET 1686 End If 1687 If bProtectWindows Then 1688 .Attributes.Add RID_STR_EXCEL_ATTRIBUTE_PROTECT_TYPE_WINDOWS 1689 .Values.Add RID_STR_EXCEL_ATTRIBUTE_SET 1690 End If 1691 1692 AddIssueDetailsNote myIssue, 0, RID_STR_EXCEL_NOTE_PASSWORD_TO_OPEN 1693 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _ 1694 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1 1695 End With 1696 1697 mAnalysis.Issues.Add myIssue 1698 1699FinalExit: 1700 Set myIssue = Nothing 1701 Exit Sub 1702 1703HandleErrors: 1704 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1705 Resume FinalExit 1706 1707End Sub 1708 1709Private Function WorkbookProtectTest(aWB As Workbook, bProtectSharing As Boolean, _ 1710 bProtectStructure As Boolean, bProtectWindows As Boolean) As Boolean 1711 On Error GoTo HandleErrors 1712 Dim currentFunctionName As String 1713 currentFunctionName = "WorkbookProtectTest" 1714 1715 WorkbookProtectTest = False 1716 1717 On Error Resume Next 'Simulate Try Catch 1718 aWB.UnprotectSharing sharingPassword:=" " 1719 If Err.Number = 1004 Then 1720 bProtectSharing = True 1721 ElseIf Err.Number <> 0 Then 1722 Resume HandleErrors 1723 End If 1724 On Error GoTo HandleErrors 1725 1726 On Error Resume Next 'Simulate Try Catch 1727 aWB.Unprotect Password:="" 1728 If Err.Number = 1004 Then 1729 If aWB.ProtectStructure = True Then 1730 bProtectStructure = True 1731 End If 1732 If aWB.ProtectWindows = True Then 1733 bProtectWindows = True 1734 End If 1735 End If 1736 1737 If bProtectSharing Or bProtectStructure Or bProtectWindows Then 1738 WorkbookProtectTest = True 1739 End If 1740FinalExit: 1741 Exit Function 1742 1743HandleErrors: 1744 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1745 Resume FinalExit 1746 1747End Function 1748 1749Private Sub Class_Initialize() 1750 Set mAnalysis = New DocumentAnalysis 1751End Sub 1752Private Sub Class_Terminate() 1753 Set mAnalysis = Nothing 1754End Sub 1755 1756Public Property Get Results() As DocumentAnalysis 1757 Set Results = mAnalysis 1758End Property 1759Private Function FormatIssueComplex(myChart As Chart, bDataTable As Boolean, bXAxes As Boolean) As Boolean 1760 On Error GoTo HandleErrors 1761 Dim currentFunctionName As String 1762 currentFunctionName = "FormatIssueComplex" 1763 1764 bXAxes = False 1765 1766 If myChart.HasDataTable Then 1767 bDataTable = True 1768 End If 1769 If Not (IsPie(myChart) Or myChart.ChartType = xlDoughnut Or myChart.ChartType = xlBubble3DEffect) Then 1770 If myChart.HasAxis(1) Then 1771 If myChart.Axes(1).CategoryType = xlTimeScale Or myChart.Axes(1).CategoryType = xlAutomaticScale Then 1772 bXAxes = True 1773 End If 1774 End If 1775 End If 1776 If bDataTable Or bXAxes Then 1777 FormatIssueComplex = True 1778 End If 1779 Exit Function 1780HandleErrors: 1781 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1782End Function 1783 1784Private Function IsAreaChart(myChart As Chart) As Boolean 1785 1786 If (myChart.ChartType = xlArea Or myChart.ChartType = xl3DArea Or _ 1787 myChart.ChartType = xlAreaStacked Or _ 1788 myChart.ChartType = xl3DAreaStacked Or _ 1789 myChart.ChartType = xlAreaStacked100 Or _ 1790 myChart.ChartType = xl3DAreaStacked100) _ 1791 Then 1792 IsAreaChart = True 1793 Else 1794 IsAreaChart = False 1795 End If 1796 1797End Function 1798 1799Private 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 1800On Error GoTo HandleErrors 1801Dim currentFunctionName As String 1802currentFunctionName = "FormatissueMinor" 1803 1804Dim ctype As Integer 1805Dim fsize As Integer 1806Dim se As Series 1807Dim dl As DataLabel 1808 1809 FormatissueMinor = False 1810 ctype = myChart.ChartType 1811 1812 If (ctype = xlBubble Or ctype = xlPieOfPie Or ctype = xl3DPieExploded _ 1813 Or ctype = xlRadarFilled Or ctype = xlBubble3DEffect _ 1814 Or ctype = xlRadarMarkers Or ctype = xlRadar Or ctype = xlBarOfPie _ 1815 Or ctype = xlXYScatter Or ctype = xlXYScatterLines Or ctype = xlXYScatterLinesNoMarkers _ 1816 Or ctype = xlXYScatterSmooth Or ctype = xlXYScatterSmoothNoMarkers _ 1817 Or ctype = xlSurface Or ctype = xlSurfaceTopView Or ctype = xlSurfaceTopViewWireframe _ 1818 Or ctype = xlSurfaceWireframe) Then 1819 bUnsupportedType = True 1820 End If 1821 1822 For Each se In myChart.SeriesCollection 1823 On Error Resume Next ' may not have trendlines property 1824 If se.Trendlines.count <> 0 Then 1825 If Err.Number = 0 Then 1826 bTrendline = True 1827 End If 1828 End If 1829 If se.HasDataLabels Then 1830 If Err.Number = 0 Then 1831 If (IsAreaChart(myChart)) Then 1832 For Each dl In se.DataLabels 1833 If dl.ShowLegendKey = True Then 1834 bDatalabelWithLegend = True 1835 Exit For 1836 End If 1837 Next dl 1838 Else 1839 Dim pt As Point 1840 For Each pt In se.Points 1841 If pt.HasDataLabel Then 1842 If pt.DataLabel.ShowLegendKey Then 1843 bDatalabelWithLegend = True 1844 Exit For 1845 End If 1846 End If 1847 Next pt 1848 End If 1849 End If 1850 End If 1851 On Error GoTo HandleErrors 1852 If bTrendline And bDatalabelWithLegend Then 1853 Exit For 1854 End If 1855 Next se 1856 1857 If myChart.HasLegend Then 1858 Dim legPos As Long 1859 On Error Resume Next 'If legend moved accessing position will fail 1860 legPos = myChart.Legend.Position 1861 1862 If (Err.Number <> 0) Or (legPos <> xlLegendPositionRight) Then 1863 bLegendPosition = True 1864 End If 1865 On Error GoTo HandleErrors 1866 End If 1867 1868 If IsPie(myChart) Then 1869 bPiechartDirection = True 1870 ElseIf myChart.ChartType <> xlDoughnut And myChart.ChartType <> xlBubble3DEffect Then 1871 If myChart.HasAxis(xlValue, xlPrimary) Then 1872 With myChart.Axes(xlValue, xlPrimary) 1873 If .MajorUnitIsAuto And .MaximumScaleIsAuto And .MinimumScaleIsAuto And .MinorUnitIsAuto Then 1874 bAxisInterval = True 1875 End If 1876 End With 1877 End If 1878 End If 1879 1880 On Error Resume Next 'If title has mixed font size accessing Font.Size will fail - Title mixed font issue 1881 If myChart.HasTitle Then 1882 fsize = myChart.chartTitle.Font.Size 1883 If Err.Number = FontError Then 1884 bTitleFont = True 1885 End If 1886 End If 1887 1888 On Error GoTo HandleErrors 1889 If bUnsupportedType Or bTrendline Or bDatalabelWithLegend Or bLegendPosition Or bTitleFont Or bPiechartDirection Or bAxisInterval Then 1890 FormatissueMinor = True 1891 End If 1892 1893FinalExit: 1894 1895 Set se = Nothing 1896 Set dl = Nothing 1897 Exit Function 1898 1899HandleErrors: 1900 1901 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1902 Resume FinalExit 1903 1904End Function 1905 1906Private 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 1907On Error GoTo HandleErrors 1908Dim currentFunctionName As String 1909currentFunctionName = "SeriesIssue" 1910SeriesIssue = False 1911 1912Dim Num As Integer 1913Dim I As Integer 1914Dim i2 As Integer 1915Dim formula As String 1916Dim p1 As Integer, p2 As Integer 1917Dim b1 As Integer, b2 As Integer 1918Dim comma1 As Integer, comma2 As Integer 1919Dim starty As Integer 1920Dim ctype As Integer 1921Dim temp As Integer 1922Dim myarray() As String 1923Dim Values(3), sh 1924Dim chartseries As Series 1925Dim b As Boolean 1926Dim bmorecolumns As Boolean 1927Dim c As Boolean 1928 1929bmorecolumns = False 1930Num = myChart.SeriesCollection.count 1931 1932If (Num = 0) Then Exit Function 1933 1934ctype = myChart.SeriesCollection(1).ChartType 1935I = 0 1936sh = "" 1937 1938ReDim Preserve myarray(Num, 3) 1939 1940If IsPie(myChart) And Num > 1 Then 'if pie chart has more than one series,set series number to 1 1941 bmorecolumns = True 1942 Num = 1 1943End If 1944For Each chartseries In myChart.SeriesCollection 1945 On Error Resume Next 1946 formula = chartseries.formula 1947 If Err.Number <> 0 Then 1948 GoTo FinalExit 1949 End If 1950 If Not bSeriesChartTypeChanged Then 'check if the chart type changed 1951 temp = chartseries.ChartType 1952 If temp <> ctype Then 1953 bSeriesChartTypeChanged = True 1954 End If 1955 End If 1956 1957 'get each part of the formula, if it is a single range, set the value to the array 1958 p1 = InStr(1, formula, "(") 1959 comma1 = InStr(1, formula, ",") 1960 Values(0) = Mid(formula, p1 + 1, comma1 - p1 - 1) 1961 1962 If Mid(formula, comma1 + 1, 1) = "(" Then 1963' Multiple ranges 1964 bDatasourceNotLinkedtoCell = True 1965 GoTo FinalExit 1966 Else 1967 If Mid(formula, comma1 + 1, 1) = "{" Then 1968' Literal Array 1969 bDatasourceNotLinkedtoCell = True 1970 GoTo FinalExit 1971 Else 1972' A single range 1973 comma2 = InStr(comma1 + 1, formula, ",") 1974 Values(1) = Mid(formula, comma1 + 1, comma2 - comma1 - 1) 1975 starty = comma2 1976 End If 1977 End If 1978 1979 If Mid(formula, starty + 1, 1) = "(" Then 1980' Multiple ranges 1981 bDatasourceNotLinkedtoCell = True 1982 GoTo FinalExit 1983 Else 1984 If Mid(formula, starty + 1, 1) = "{" Then 1985' Literal Array 1986 bDatasourceNotLinkedtoCell = True 1987 GoTo FinalExit 1988 Else 1989' A single range 1990 comma1 = starty 1991 comma2 = InStr(comma1 + 1, formula, ",") 1992 Values(2) = Mid(formula, comma1 + 1, comma2 - comma1 - 1) 1993 End If 1994 End If 1995 1996 If SheetCheck(sh, Values) Then 'check if data from different sheet 1997 bDatasourceOnDifferentSheet = True 1998 GoTo FinalExit 1999 End If 2000 2001 For i2 = 0 To 2 'set data to myarray, if it is range, assign the range address, else null 2002 If IsRange(Values(i2)) Then 2003 myarray(I, i2) = Range(Values(i2)).Address 2004 'ElseIf (Not IsRange(values(i2))) And values(i2) <> "" Then 2005 ' bDatasourceNotLinkedtoCell = True 2006 ' myarray(i, i2) = "" 2007 Else 2008 bDatasourceNotLinkedtoCell = True 2009 myarray(I, i2) = "" 2010 End If 2011 Next i2 2012 2013 I = I + 1 2014 If bmorecolumns Then 'if it is pie chart, exit 2015 Exit For 2016 End If 2017Next chartseries 2018 2019 2020c = DataCheck(myarray, Num, bCategoryandValue, bCLabelMorethanOneCell, bOneColumnRow) 'check data values and category of the chart 2021 2022FinalExit: 2023If bSeriesChartTypeChanged Or bDatasourceNotLinkedtoCell Or bDatasourceOnDifferentSheet Or bCategoryandValue Or bCLabelMorethanOneCell Or bOneColumnRow Then 2024 SeriesIssue = True 2025End If 2026 2027Last: 2028 Set chartseries = Nothing 2029 Exit Function 2030 2031HandleErrors: 2032 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 2033 Resume Last 2034End Function 2035 2036Private Function DataCheck(myarray() As String, Num As Integer, bCategoryandValue As Boolean, bCLabelMorethanOneCell As Boolean, bOneColumnRow As Boolean) 2037On Error GoTo HandleErrors 2038Dim currentFunctionName As String 2039currentFunctionName = "DataCheck" 2040 2041Dim s1() As String 2042Dim v1() As String 2043Dim v2() As String 2044Dim c1() As String 2045Dim c2() As String 2046Dim bs1isrange As Boolean 2047Dim bc1isrange As Boolean 2048Dim bc2isrange As Boolean 2049Dim j As Integer 2050Dim I As Integer 2051Dim btemp1 As Boolean 2052Dim btemp2 As Boolean 2053 2054 2055bs1isrange = True 2056bc1isrange = True 2057bc2isrange = True 2058 2059If myarray(0, 1) = "" Then 2060 bs1isrange = False 2061Else 2062 s1 = SplitRange(myarray(0, 1)) 2063 If UBound(s1) < 4 Then 2064 bOneColumnRow = True 2065 GoTo FinalExit 2066 End If 2067 If (Asclong(s1(0)) <> Asclong(s1(2))) And (Asclong(s1(1)) <> Asclong(s1(3))) Then 2068 bCLabelMorethanOneCell = True 2069 GoTo FinalExit 2070 End If 2071 2072End If 2073 2074If myarray(0, 0) = "" Then 2075 ReDim c1(2) 2076 bc1isrange = False 2077 c1(0) = "" 2078 c1(1) = "" 2079Else 2080 If InStr(1, myarray(0, 0), ":") <> 0 Then 2081 bCLabelMorethanOneCell = True 2082 GoTo FinalExit 2083 End If 2084 c1 = SplitRange(myarray(0, 0)) 2085End If 2086v1 = SplitRange(myarray(0, 2)) 2087 2088If bs1isrange Then 2089 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 2090 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 2091 If (Not btemp1) And (Not btemp2) Then 2092 bCategoryandValue = True 2093 GoTo FinalExit 2094 End If 2095End If 2096If bc1isrange Then 2097 btemp1 = v1(0) = v1(2) And c1(0) = v1(0) And Asclong(c1(1)) <= Asclong(v1(1)) - 1 'data label beside row 2098 btemp2 = v1(1) = v1(3) And c1(1) = v1(1) And Asclong(c1(0)) <= Asclong(v1(0)) - 1 'data label beside column 2099 If (Not btemp1) And (Not btemp2) Then 2100 bCategoryandValue = True 2101 GoTo FinalExit 2102 End If 2103End If 2104For I = 1 To Num - 1 2105 If myarray(I, 0) = "" Then 2106 ReDim c2(2) 2107 c2(0) = "" 2108 c2(1) = "" 2109 bc2isrange = False 2110 Else 2111 If InStr(1, myarray(0, 1), ":") = 0 Then 2112 bCLabelMorethanOneCell = True 2113 GoTo FinalExit 2114 End If 2115 c2 = SplitRange(myarray(I, 0)) 2116 End If 2117 v2 = SplitRange(myarray(I, 2)) 2118 If bc2isrange Then 2119 btemp1 = v1(0) = v1(2) And c2(0) = v2(0) And Asclong(c2(1)) <= Asclong(v2(1)) - 1 'data label beside row 2120 btemp2 = v2(1) = v2(3) And c2(1) = v2(1) And Asclong(c2(0)) <= Asclong(v2(0)) - 1 'data label beside column 2121 If (Not btemp1) And (Not btemp2) Then 2122 bCategoryandValue = True 2123 GoTo FinalExit 2124 'break 2125 End If 2126 End If 2127 If bc1isrange And bc2isrange Then 2128 'series data beside last series data in column and data label beside last series data label 2129 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) 2130 'series data beside last series data in row and data label beside laast series data label 2131 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) 2132 If (Not btemp1) And (Not btemp2) Then 2133 bCategoryandValue = True 2134 GoTo FinalExit 2135 End If 2136 ElseIf Not bc2isrange Then 2137 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 2138 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 2139 If (Not btemp1) And (Not btemp2) Then 2140 bCategoryandValue = True 2141 GoTo FinalExit 2142 End If 2143 End If 2144 For j = 0 To 1 2145 c1(j) = c2(j) 2146 Next j 2147 For j = 0 To 3 2148 v1(j) = v2(j) 2149 Next j 2150 bc1isrange = bc2isrange 2151 bc2isrange = True 2152 2153Next I 2154FinalExit: 2155Exit Function 2156HandleErrors: 2157 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 2158End Function 2159Private Function SplitRange(a As String) As String() 2160On Error GoTo HandleErrors 2161Dim currentFunctionName As String 2162currentFunctionName = "SplitRange" 2163 2164Dim c1 As Integer, c2 As Integer, c3 As Integer 2165Dim start As Integer 2166Dim l As Integer 2167Dim rearray() As String 2168 2169start = 2 2170If a <> "" Then 2171 l = InStr(1, a, ":") 2172 If l = 0 Then 2173 ReDim rearray(2) 2174 c1 = InStr(start, a, "$") 2175 rearray(0) = Mid(a, start, c1 - start) 2176 rearray(1) = Mid(a, c1 + 1, Len(a) - c1) 2177 Else 2178 ReDim rearray(4) 2179 c1 = InStr(start, a, "$") 2180 rearray(0) = Mid(a, start, c1 - start) 2181 c2 = InStr(c1 + 1, a, "$") 2182 rearray(1) = Mid(a, c1 + 1, c2 - c1 - 2) 2183 c3 = InStr(c2 + 1, a, "$") 2184 rearray(2) = Mid(a, c2 + 1, c3 - c2 - 1) 2185 rearray(3) = Mid(a, c3 + 1, Len(a) - c3) 2186 End If 2187Else 2188 ReDim rearray(4) 2189 rearray(0) = "" 2190 rearray(1) = "" 2191 rearray(2) = "" 2192 rearray(3) = "" 2193End If 2194SplitRange = rearray 2195 2196Exit Function 2197HandleErrors: 2198 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 2199End Function 2200Private Function Asclong(s As String) As Integer 2201On Error GoTo HandleErrors 2202Dim currentFunctionName As String 2203currentFunctionName = "Asclong" 2204Asclong = 0 2205 2206Dim l As Integer 2207Dim I As Integer 2208Dim m As String 2209 2210l = Len(s) 2211 2212For I = 1 To l 2213 m = Mid(s, I, 1) 2214 Asclong = Asclong + Asc(m) 2215Next I 2216Exit Function 2217 2218HandleErrors: 2219 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 2220End Function 2221Private Function SheetCheck(sh As Variant, Values() As Variant) As Boolean 2222On Error GoTo HandleErrors 2223Dim currentFunctionName As String 2224currentFunctionName = "SheetCheck" 2225SheetCheck = False 2226 2227Dim c1 As Integer 2228Dim I As Integer 2229 2230Dim temp 2231 2232For I = 0 To 2 2233 If IsRange(Values(I)) Then 2234 c1 = InStr(1, Values(I), "!") 2235 If sh = "" Then 2236 sh = Mid(Values(I), 1, c1 - 1) 2237 temp = Mid(Values(I), 1, c1 - 1) 2238 Else 2239 temp = Mid(Values(I), 1, c1 - 1) 2240 End If 2241 If temp <> sh Then 2242 SheetCheck = True 2243 Exit Function 2244 End If 2245 End If 2246Next I 2247Exit Function 2248 2249HandleErrors: 2250 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 2251End Function 2252Private Function IsRange(Ref) As Boolean 2253On Error GoTo HandleErrors 2254Dim currentFunctionName As String 2255currentFunctionName = "IsRange" 2256 2257Dim x As Range 2258 2259On Error Resume Next 2260Set x = Range(Ref) 2261If Err = 0 Then 2262 IsRange = True 2263Else 2264 IsRange = False 2265End If 2266FinalExit: 2267 Set x = Nothing 2268 Exit Function 2269 2270HandleErrors: 2271 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 2272 Resume FinalExit 2273End Function 2274Private Function IsPie(myChart As Chart) As Boolean 2275On Error GoTo HandleErrors 2276Dim currentFunctionName As String 2277currentFunctionName = "IsPie" 2278Dim ctype As Integer 2279 IsPie = False 2280 2281 ctype = myChart.ChartType 2282 If (ctype = xlPie) Or _ 2283 (ctype = xlPieExploded) Or _ 2284 (ctype = xlPieOfPie) Or _ 2285 (ctype = xl3DPie) Or _ 2286 (ctype = xl3DPieExploded) Then 2287 2288 IsPie = True 2289 End If 2290 Exit Function 2291 2292HandleErrors: 2293 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 2294End Function 2295 2296Private Function IsOldVersion(aFormat As XlFileFormat) As Boolean 2297 Dim theResult As Boolean 2298 Dim currentFunctionName As String 2299 currentFunctionName = "IsOldVersion" 2300 2301 Select Case aFormat 2302 Case xlExcel2, xlExcel2FarEast, xlExcel3, xlExcel4, xlExcel4Workbook, xlExcel5, xlExcel7 2303 theResult = True 2304 Case xlExcel9795, xlWorkbookNormal 2305 theResult = False 2306 Case Else 2307 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": The version of this spreadsheet is not recognised" 2308 End Select 2309 2310 IsOldVersion = theResult 2311End Function 2312 2313 2314