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