1Attribute VB_Name = "AnalysisDriver" 2'/************************************************************************* 3' * 4' DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER. 5' 6' Copyright 2000, 2010 Oracle and/or its affiliates. 7' 8' OpenOffice.org - a multi-platform office productivity suite 9' 10' This file is part of OpenOffice.org. 11' 12' OpenOffice.org is free software: you can redistribute it and/or modify 13' it under the terms of the GNU Lesser General Public License version 3 14' only, as published by the Free Software Foundation. 15' 16' OpenOffice.org is distributed in the hope that it will be useful, 17' but WITHOUT ANY WARRANTY; without even the implied warranty of 18' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19' GNU Lesser General Public License version 3 for more details 20' (a copy is included in the LICENSE file that accompanied this code). 21' 22' You should have received a copy of the GNU Lesser General Public License 23' version 3 along with OpenOffice.org. If not, see 24' <http://www.openoffice.org/license.html> 25' for a copy of the LGPLv3 License. 26' 27' ************************************************************************/ 28 29Option Explicit 30 31' Declare Public variables. 32Public Type ShortItemId 33 cb As Long 34 abID As Byte 35End Type 36 37Public Type ITEMIDLIST 38 mkid As ShortItemId 39End Type 40 41Public Declare Function FindWindow Lib "user32" Alias _ 42 "FindWindowA" (ByVal lpClassName As String, _ 43 ByVal lpWindowName As Long) As Long 44 45Private Declare Function GetTickCount Lib "kernel32" () As Long 46 47'This function saves the passed value to the file, 48'under the section and key names specified. 49'If the ini file, lpFileName, does not exist, it is created. 50'If the section, lpSectionName, does not exist, it is created. 51'If the key name, lpKeyName, does not exist, it is created. 52'If the key name exists, it's value, lpString, is replaced. 53Private Declare Function WritePrivateProfileString Lib "kernel32" _ 54 Alias "WritePrivateProfileStringA" _ 55 (ByVal lpSectionName As String, _ 56 ByVal lpKeyName As Any, _ 57 ByVal lpString As Any, _ 58 ByVal lpFileName As String) As Long 59 60Private Declare Function GetPrivateProfileString Lib "kernel32" _ 61 Alias "GetPrivateProfileStringA" _ 62 (ByVal lpSectionName As String, _ 63 ByVal lpKeyName As Any, _ 64 ByVal lpDefault As String, _ 65 ByVal lpReturnedString As String, _ 66 ByVal nSize As Long, _ 67 ByVal lpFileName As String) As Long 68 69Private Declare Function UrlEscape Lib "shlwapi" _ 70 Alias "UrlEscapeA" _ 71 (ByVal pszURL As String, _ 72 ByVal pszEscaped As String, _ 73 pcchEscaped As Long, _ 74 ByVal dwFlags As Long) As Long 75 76Public Declare Function SHGetPathFromIDList Lib "shell32.dll" _ 77 (ByVal pidl As Long, ByVal pszPath As String) As Long 78 79Public Declare Function SHGetSpecialFolderLocation Lib _ 80 "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder _ 81 As Long, pidl As ITEMIDLIST) As Long 82 83Public Const LOCALE_ILANGUAGE As Long = &H1 'language id 84Public Const LOCALE_SLANGUAGE As Long = &H2 'localized name of lang 85Public Const LOCALE_SENGLANGUAGE As Long = &H1001 'English name of lang 86Public Const LOCALE_SABBREVLANGNAME As Long = &H3 'abbreviated lang name 87Public Const LOCALE_SNATIVELANGNAME As Long = &H4 'native name of lang 88Public Const LOCALE_ICOUNTRY As Long = &H5 'country code 89Public Const LOCALE_SCOUNTRY As Long = &H6 'localized name of country 90Public Const LOCALE_SENGCOUNTRY As Long = &H1002 'English name of country 91Public Const LOCALE_SABBREVCTRYNAME As Long = &H7 'abbreviated country name 92Public Const LOCALE_SNATIVECTRYNAME As Long = &H8 'native name of country 93Public Const LOCALE_SINTLSYMBOL As Long = &H15 'intl monetary symbol 94Public Const LOCALE_IDEFAULTLANGUAGE As Long = &H9 'def language id 95Public Const LOCALE_IDEFAULTCOUNTRY As Long = &HA 'def country code 96Public Const LOCALE_IDEFAULTCODEPAGE As Long = &HB 'def oem code page 97Public Const LOCALE_IDEFAULTANSICODEPAGE As Long = &H1004 'def ansi code page 98Public Const LOCALE_IDEFAULTMACCODEPAGE As Long = &H1011 'def mac code page 99 100Public Const LOCALE_IMEASURE As Long = &HD '0 = metric, 1 = US 101Public Const LOCALE_SSHORTDATE As Long = &H1F 'short date format string 102 103'#if(WINVER >= &H0400) 104Public Const LOCALE_SISO639LANGNAME As Long = &H59 'ISO abbreviated language name 105Public Const LOCALE_SISO3166CTRYNAME As Long = &H5A 'ISO abbreviated country name 106'#endif /* WINVER >= as long = &H0400 */ 107 108'#if(WINVER >= &H0500) 109Public Const LOCALE_SNATIVECURRNAME As Long = &H1008 'native name of currency 110Public Const LOCALE_IDEFAULTEBCDICCODEPAGE As Long = &H1012 'default ebcdic code page 111Public Const LOCALE_SSORTNAME As Long = &H1013 'sort name 112'#endif /* WINVER >= &H0500 */ 113 114Public Declare Function GetSystemDefaultLangID Lib "kernel32" () As Long 115Public Declare Function GetUserDefaultLangID Lib "kernel32" () As Long 116 117Public Declare Function GetLocaleInfo Lib "kernel32" _ 118 Alias "GetLocaleInfoA" _ 119 (ByVal Locale As Long, _ 120 ByVal LCType As Long, _ 121 ByVal lpLCData As String, _ 122 ByVal cchData As Long) As Long 123 124 125Public Const CWIZARD = "analysis" 126 127Const CROWOFFSET = 2 128Const CDOCPROP_PAW_ROWOFFSET = 3 129Private mDocPropRowOffset As Long 130 131Const CNUMBERDOC_ALL = "All" 132Const CTOTAL_DOCS_ANALYZED = "TotalDocsAnalysed" 133Const CNUMDAYS_IN_MONTH = 30 134Const CMAX_LIMIT = 10000 135 136Const CISSUE_DETDOCNAME = 1 137Const CISSUE_DETDOCAPPLICATION = CISSUE_DETDOCNAME + 1 138Const CISSUE_DETTYPE = CISSUE_DETDOCAPPLICATION + 1 139Const CISSUE_DETSUBTYPE = CISSUE_DETTYPE + 1 140Const CISSUE_DETLOCATION = CISSUE_DETSUBTYPE + 1 141Const CISSUE_DETSUBLOCATION = CISSUE_DETLOCATION + 1 142Const CISSUE_DETLINE = CISSUE_DETSUBLOCATION + 1 143Const CISSUE_DETCOLUMN = CISSUE_DETLINE + 1 144Const CISSUE_DETATTRIBUTES = CISSUE_DETCOLUMN + 1 145Const CISSUE_DETNAMEANDPATH = CISSUE_DETATTRIBUTES + 1 146 147Const CREF_DETDOCNAME = 1 148Const CREF_DETDOCAPPLICATION = CREF_DETDOCNAME + 1 149Const CREF_DETREFERENCE = CREF_DETDOCAPPLICATION + 1 150Const CREF_DETDESCRIPTION = CREF_DETREFERENCE + 1 151Const CREF_DETLOCATION = CREF_DETDESCRIPTION + 1 152Const CREF_DETATTRIBUTES = CREF_DETLOCATION + 1 153Const CREF_DETNAMEANDPATH = CREF_DETATTRIBUTES + 1 154 155Const CINPUT_DIR = "indir" 156Const COUTPUT_DIR = "outdir" 157Const CRESULTS_FILE = "resultsfile" 158Const CLOG_FILE = "logfile" 159Const CRESULTS_TEMPLATE = "resultstemplate" 160Const CRESULTS_EXIST = "resultsexist" 161Const COVERWRITE_FILE = "overwritefile" 162Const CNEW_RESULTS_FILE = "newresultsfile" 163Const CINCLUDE_SUBDIRS = "includesubdirs" 164Const CDEBUG_LEVEL = "debuglevel" 165Const COUTPUT_TYPE = "outputtype" 166Const COUTPUT_TYPE_XLS = "xls" 167Const COUTPUT_TYPE_XML = "xml" 168Const COUTPUT_TYPE_BOTH = "both" 169Const COVERVIEW_TITLE_LABEL = "OV_Document_Analysis_Overview_lbl" 170Const CDEFAULT_PASSWORD = "defaultpassword" 171Const CVERSION = "version" 172Const CTITLE = "title" 173Const CDOPREPARE = "prepare" 174Const CISSUES_LIMIT = "issuesmonthlimit" 175Const CSINGLE_FILE = "singlefile" 176Const CFILE_LIST = "filelist" 177Const CSTAT_FILE = "statfilename" 178Const C_ABORT_ANALYSIS = "abortanalysis" 179Const C_DOCS_LESS_3_MONTH = "DocumentsYoungerThan3Month" 180Const C_DOCS_LESS_6_MONTH = "DocumentsYoungerThan6Month" 181Const C_DOCS_LESS_12_MONTH = "DocumentsYoungerThan12Month" 182Const C_DOCS_MORE_12_MONTH = "DocumentsOlderThan12Month" 183 184Private Const C_ANALYSIS As String = "Analysis" 185Private Const C_LAST_CHECKPOINT As String = "LastCheckpoint" 186Private Const C_NEXT_FILE As String = "NextFile" 187Private Const C_MAX_CHECK_INI As String = "FilesBeforeSave" 188Private Const C_MAX_WAIT_BEFORE_WRITE_INI As String = "SecondsBeforeSave" 189Private Const C_MAX_RANGE_PROCESS_TIME_INI As String = "ExcelMaxRangeProcessTime" 190Private Const C_ERROR_HANDLING_DOC As String = "_ERROR_HANDLING_DOC_" 191Private Const C_MAX_CHECK As Long = 100 192Private Const C_MAX_WAIT_BEFORE_WRITE As Long = 300 ' sec 193Private Const C_MAX_RANGE_PROCESS_TIME As Integer = 30 'sec 194 195Private Const C_STAT_STARTING As Integer = 1 196Private Const C_STAT_DONE As Integer = 2 197Private Const C_STAT_FINISHED As Integer = 3 198 199Private Type DocumentCount 200 numDocsAnalyzed As Long 201 numDocsAnalyzedWithIssues As Long 202 numMinorIssues As Long 203 numComplexIssues As Long 204 numMacroIssues As Long 205 numPreparableIssues As Long 206 totalMacroCosts As Long 207 totalDocIssuesCosts As Long 208 totalPreparableIssuesCosts As Long 209End Type 210 211Private Type DocModificationDates 212 lessThanThreemonths As Long 213 threeToSixmonths As Long 214 sixToTwelvemonths As Long 215 greaterThanOneYear As Long 216End Type 217 218Private Type DocMacroClassifications 219 None As Long 220 Simple As Long 221 Medium As Long 222 complex As Long 223End Type 224 225Private Type DocIssueClassifications 226 None As Long 227 Minor As Long 228 complex As Long 229End Type 230 231Const CCOST_COL_OFFSET = -1 232 233Private mLogFilePath As String 234Private mDocIndex As String 235Private mDebugLevel As Long 236Private mIniFilePath As String 237Private mUserFormTypesDict As Scripting.Dictionary 238Private mIssuesDict As Scripting.Dictionary 239Private mMacroDict As Scripting.Dictionary 240Private mPreparedIssuesDict As Scripting.Dictionary 241Private mIssuesClassificationDict As Scripting.Dictionary 242Private mIssuesCostDict As Scripting.Dictionary 243Private mIssuesLimit As Date 244 245Public Const CWORD_DRIVER_FILE = "_OOoDocAnalysisWordDriver.doc" 246Public Const CEXCEL_DRIVER_FILE = "_OOoDocAnalysisExcelDriver.xls" 247Public Const CPP_DRIVER_FILE = "_OOoDocAnalysisPPTDriver.ppt" 248Public Const CWORD_DRIVER_FILE_TEMP = "~$OoDocAnalysisWordDriver.doc" 249Public Const CEXCEL_DRIVER_FILE_TEMP = "~$OoDocAnalysisExcelDriver.xls" 250Public Const CPP_DRIVER_FILE_TEMP = "~$OoDocAnalysisPPTDriver.ppt" 251 252'Doc Properties Offsets - used in WriteDocProperties and GetPreparableFilesFromDocProps 253Const CDOCINFONAME = 1 254Const CDOCINFOAPPLICATION = CDOCINFONAME + 1 255 256Const CDOCINFOISSUE_CLASS = CDOCINFOAPPLICATION + 1 257Const CDOCINFOCOMPLEXISSUES = CDOCINFOISSUE_CLASS + 1 258Const CDOCINFOMINORISSUES = CDOCINFOCOMPLEXISSUES + 1 259Const CDOCINFOPREPAREDISSUES = CDOCINFOMINORISSUES + 1 260 261Const CDOCINFOMACRO_CLASS = CDOCINFOPREPAREDISSUES + 1 262Const CDOCINFOMACRO_USERFORMS = CDOCINFOMACRO_CLASS + 1 263Const CDOCINFOMACRO_LINESOFCODE = CDOCINFOMACRO_USERFORMS + 1 264 265Const CDOCINFODOCISSUECOSTS = CDOCINFOMACRO_LINESOFCODE + 1 266Const CDOCINFOPREPARABLEISSUECOSTS = CDOCINFODOCISSUECOSTS + 1 267Const CDOCINFOMACROISSUECOSTS = CDOCINFOPREPARABLEISSUECOSTS + 1 268 269Const CDOCINFONUMBERPAGES = CDOCINFOMACROISSUECOSTS + 1 270Const CDOCINFOCREATED = CDOCINFONUMBERPAGES + 1 271Const CDOCINFOLASTMODIFIED = CDOCINFOCREATED + 1 272Const CDOCINFOLASTACCESSED = CDOCINFOLASTMODIFIED + 1 273Const CDOCINFOLASTPRINTED = CDOCINFOLASTACCESSED + 1 274Const CDOCINFOLASTSAVEDBY = CDOCINFOLASTPRINTED + 1 275Const CDOCINFOREVISION = CDOCINFOLASTSAVEDBY + 1 276Const CDOCINFOTEMPLATE = CDOCINFOREVISION + 1 277Const CDOCINFONAMEANDPATH = CDOCINFOTEMPLATE + 1 278 279'Overview shapes 280Const COV_DOC_MOD_DATES_CHART = "Chart 21" 281Const COV_DOC_MACRO_CHART = "Chart 22" 282Const COV_DOC_ANALYSIS_CHART = "Chart 23" 283 284Const COV_DOC_MOD_DATES_COMMENT_TXB = "Text Box 25" 285Const COV_DOC_MOD_DATES_LEGEND_TXB = "Text Box 12" 286 287Const COV_DOC_MACRO_COMMENT_TXB = "Text Box 26" 288Const COV_DOC_MACRO_LEGEND_TXB = "Text Box 16" 289 290Const COV_DOC_ANALYSIS_COMMENT_TXB = "Text Box 27" 291Const COV_DOC_ANALYSIS_LEGEND_DAW_TXB = "Text Box 28" 292Const COV_DOC_ANALYSIS_LEGEND_PAW_TXB = "Text Box 18" 293 294Const COV_HIGH_LEVEL_ANALYSIS_RANGE = "OV_High_Level_Analysis_Range" 295Const COV_COST_RANGE = "OV_Cost_Range" 296 297'Sheet labels 298Const COV_HIGH_LEVEL_ANALYSIS_LBL = "OV_High_level_analysis_lbl" 299Const COV_DP_PREPISSUES_COL_LBL = "DocProperties_PreparedIssues_Column" 300Const COV_COSTS_PREPISSUE_COUNT_COL_LBL = "Costs_PreparedIssueCount_Column" 301Const CDP_DAW_HIDDEN_COLS_LBL = "DP_DAW_HIDDEN_COLS_RANGE" 302Const CDP_DAW_HIDDEN_COLS2_LBL = "DP_DAW_HIDDEN_COLS_RANGE2" 303Const CDP_DAW_HIDDEN_ROW_LBL = "DP_DAW_HIDDEN_ROW_RANGE" 304 305Const COV_DAW_SETUP_SHEETS_RUN_LBL = "OV_DAW_SETUP_SHEETS_RUN" 306Const COV_PAW_SETUP_SHEETS_RUN_LBL = "OV_PAW_SETUP_SHEETS_RUN" 307Const COV_Internal_Attributes_Cols_LBL = "OV_Internal_Attributes_Cols" 308 309Const CR_STR = "<CR>" 310Const CR_TOPIC = "<TOPIC>" 311Const CR_PRODUCT = "<PRODUCT>" 312 313Const CLEGEND_FONT_SIZE = 8 314Const CCOMMENTS_FONT_SIZE = 10 315 316Dim mTstart As Single 317Dim mTend As Single 318Public gExcelMaxRangeProcessTime As Integer 319 320Sub AnalyseDirectory() 321 On Error GoTo HandleErrors 322 Dim currentFunctionName As String 323 currentFunctionName = "AnalyseDirectory" 324 325 Dim iniFilePath As String 326 Dim startDir As String 327 Dim fileList As String 328 Dim storeToDir As String 329 Dim resultsFile As String 330 Dim resultsTemplate As String 331 Dim statFileName As String 332 Dim bOverwriteResultsFile As Boolean 333 Dim bNewResultsFile As Boolean 334 Dim outputType As String 335 Dim singleFile As String 336 Dim nTimeNeeded As Long 337 Dim nIncrementFileCounter As Long 338 Dim nMaxWaitBeforeWrite As Long 339 Dim fso As Scripting.FileSystemObject 340 Set fso = New Scripting.FileSystemObject 341 342 SetAppToMinimized 343 344 If InDocPreparation Then 345 mDocPropRowOffset = CDOCPROP_PAW_ROWOFFSET 346 Else 347 mDocPropRowOffset = CROWOFFSET 348 End If 349 350 'Get Wizard input variables 351 SetupWizardVariables fileList, storeToDir, resultsFile, _ 352 mLogFilePath, resultsTemplate, bOverwriteResultsFile, bNewResultsFile, _ 353 statFileName, mDebugLevel, outputType, singleFile 354 355 startDir = ProfileGetItem("Analysis", CINPUT_DIR, "", mIniFilePath) 356 357 nIncrementFileCounter = CLng(ProfileGetItem("Analysis", _ 358 C_MAX_CHECK_INI, C_MAX_CHECK, mIniFilePath)) 359 nMaxWaitBeforeWrite = CLng(ProfileGetItem("Analysis", _ 360 C_MAX_WAIT_BEFORE_WRITE_INI, C_MAX_WAIT_BEFORE_WRITE, mIniFilePath)) 361 gExcelMaxRangeProcessTime = CInt(ProfileGetItem("Analysis", _ 362 C_MAX_RANGE_PROCESS_TIME_INI, C_MAX_RANGE_PROCESS_TIME, mIniFilePath)) 363 LocalizeResources 364 365 'Setup File List 366 'For Prepare - get list from results spreadsheet with docs analysis found as preparable 367 'If no results spreadsheet then just try to prepare all the docs - run over full analysis list 368 Dim myFiles As Collection 369 Set myFiles = New Collection 370 Dim sAnalysisOrPrep As String 371 If InDocPreparation And CheckDoPrepare Then 372 sAnalysisOrPrep = "Prepared" 373 If fso.FileExists(storeToDir & "\" & resultsFile) Then 374 If Not GetPrepareFilesToAnalyze(storeToDir & "\" & resultsFile, myFiles, fso) Then 375 SetPrepareToNone 376 WriteDebug currentFunctionName & ": No files to analyse!" 377 GoTo FinalExit 'No files to prepare - exit 378 End If 379 Else 380 If Not GetFilesToAnalyze(fileList, singleFile, myFiles) Then 381 SetPrepareToNone 382 WriteDebug currentFunctionName & ": No files to analyse! Filelist (" & fileList & ") empty?" 383 GoTo FinalExit 'No files to prepare - exit 384 End If 385 End If 386 Else 387 sAnalysisOrPrep = "Analyzed" 388 If Not GetFilesToAnalyze(fileList, singleFile, myFiles) Then 389 WriteDebug currentFunctionName & ": No files to analyse! Filelist (" & fileList & ") empty?" 390 GoTo FinalExit 391 End If 392 End If 393 394 Dim index As Long 395 Dim numFiles As Long 396 Dim nextSave As Long 397 Dim startIndex As Long 398 Dim bResultsWaiting As Boolean 399 Dim AnalysedDocs As Collection 400 Dim startDate As Date 401 Dim currentDate As Date 402 403 Set AnalysedDocs = New Collection 404 numFiles = myFiles.count 405 bResultsWaiting = False 406 407 If (singleFile <> "") Then 408 ' No recovery handling for single file analysis and the value in the 409 ' ini file should be used for bNewResultsFile 410 startIndex = 1 411 Else 412 bNewResultsFile = bNewResultsFile And GetIndexValues(startIndex, nextSave, myFiles) 413 End If 414 415 startDate = Now() 416 417 ' Analyse all files 418 For index = startIndex To numFiles 419 Set mIssuesClassificationDict = New Scripting.Dictionary 420 mIssuesClassificationDict.CompareMode = TextCompare 421 Set mIssuesCostDict = New Scripting.Dictionary 422 'mIssuesCostDict.CompareMode = TextCompare 423 424 Set mUserFormTypesDict = New Scripting.Dictionary 425 Set mIssuesDict = New Scripting.Dictionary 426 Set mMacroDict = New Scripting.Dictionary 427 Set mPreparedIssuesDict = New Scripting.Dictionary 428 429 'Write to Application log 430 Dim myAnalyser As MigrationAnalyser 431 Set myAnalyser = New MigrationAnalyser 432 433 If (CheckForAbort) Then GoTo FinalExit 434 435 'Log Analysis 436 WriteToStatFile statFileName, C_STAT_STARTING, myFiles.item(index), fso 437 WriteToLog "Analyzing", myFiles.item(index) 438 WriteToIni C_NEXT_FILE, myFiles.item(index) 439 mDocIndex = index 440 441 'Do Analysis 442 myAnalyser.DoAnalyse myFiles.item(index), mUserFormTypesDict, startDir, storeToDir, fso 443 444 AnalysedDocs.Add myAnalyser.Results 445 bResultsWaiting = True 446 447 WriteToLog sAnalysisOrPrep, index & "of" & numFiles & _ 448 " " & getAppSpecificApplicationName & " Documents" 449 WriteToLog "Analyzing", "Done" 450 WriteToLog sAnalysisOrPrep & "Doc" & index, myFiles.item(index) 451 Set myAnalyser = Nothing 452 453 If (CheckForAbort) Then GoTo FinalExit 454 455 'No need to output results spreadsheet, just doing prepare 456 If CheckDoPrepare Then GoTo CONTINUE_FOR 457 458 nTimeNeeded = val(DateDiff("s", startDate, Now())) 459 If ((nTimeNeeded > nMaxWaitBeforeWrite) Or _ 460 (index >= nextSave)) Then 461 If WriteResults(storeToDir, resultsFile, resultsTemplate, _ 462 bOverwriteResultsFile, bNewResultsFile, _ 463 outputType, AnalysedDocs, fso) Then 464 nextSave = index + C_MAX_CHECK 465 bResultsWaiting = False 466 Set AnalysedDocs = New Collection 467 WriteToIni C_LAST_CHECKPOINT, myFiles.item(index) 468 startDate = Now() 469 Else 470 'write error 471 End If 472 End If 473 WriteToStatFile statFileName, C_STAT_DONE, myFiles.item(index), fso 474CONTINUE_FOR: 475 Next index 476 477 If (bResultsWaiting) Then 478 If WriteResults(storeToDir, resultsFile, resultsTemplate, _ 479 bOverwriteResultsFile, bNewResultsFile, _ 480 outputType, AnalysedDocs, fso) Then 481 WriteToIni C_LAST_CHECKPOINT, myFiles.item(index - 1) 482 Else 483 'write error 484 End If 485 End If 486 WriteToStatFile statFileName, C_STAT_FINISHED, "", fso 487 488FinalExit: 489 490 Set fso = Nothing 491 Set myFiles = Nothing 492 Set mIssuesClassificationDict = Nothing 493 Set mIssuesCostDict = Nothing 494 Set mUserFormTypesDict = Nothing 495 Set mIssuesDict = Nothing 496 Set mMacroDict = Nothing 497 Set mPreparedIssuesDict = Nothing 498 499 Set AnalysedDocs = Nothing 500 501 Exit Sub 502 503HandleErrors: 504 WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source 505 Resume FinalExit 506End Sub 507 508Function WriteResults(storeToDir As String, resultsFile As String, resultsTemplate As String, _ 509 bOverwriteResultsFile As Boolean, bNewResultsFile As Boolean, _ 510 outputType As String, AnalysedDocs As Collection, _ 511 fso As FileSystemObject) As Boolean 512 513 On Error GoTo HandleErrors 514 Dim currentFunctionName As String 515 currentFunctionName = "WriteResults" 516 517 If InDocPreparation Then 518 If outputType = COUTPUT_TYPE_XML Or outputType = COUTPUT_TYPE_BOTH Then 519 WriteXMLOutput storeToDir, resultsFile, _ 520 bOverwriteResultsFile, bNewResultsFile, AnalysedDocs, fso 521 End If 522 End If 523 524 If outputType = COUTPUT_TYPE_XLS Or outputType = COUTPUT_TYPE_BOTH Then 525 WriteXLSOutput storeToDir, resultsFile, fso.GetAbsolutePathName(resultsTemplate), _ 526 bOverwriteResultsFile, bNewResultsFile, AnalysedDocs, fso 527 End If 528 529 WriteResults = True 530 bNewResultsFile = False 531 532FinalExit: 533 Exit Function 534 535HandleErrors: 536 WriteResults = False 537 WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source 538 Resume FinalExit 539End Function 540 541Function GetFilesToAnalyze_old(startDir As String, bIncludeSubdirs As Boolean, _ 542 myFiles As Collection) As Boolean 543 On Error GoTo HandleErrors 544 Dim currentFunctionName As String 545 currentFunctionName = "GetFilesToAnalyze" 546 Dim fso As New FileSystemObject 547 Dim theResultsFile As String 548 theResultsFile = ProfileGetItem("Analysis", CINPUT_DIR, "c:\", mIniFilePath) & "\" & ProfileGetItem("Analysis", CRESULTS_FILE, "", mIniFilePath) 549 550 GetFilesToAnalyze = False 551 552 Dim searchTypes As Collection 553 Set searchTypes = New Collection 554 SetupSearchTypes searchTypes 555 If searchTypes.count = 0 Then 556 GoTo FinalExit 557 End If 558 559 Dim myDocFiles As CollectedFiles 560 Set myDocFiles = New CollectedFiles 561 With myDocFiles 562 .BannedList.Add fso.GetAbsolutePathName(getAppSpecificPath & "\" & CWORD_DRIVER_FILE) 563 .BannedList.Add fso.GetAbsolutePathName(getAppSpecificPath & "\" & CEXCEL_DRIVER_FILE) 564 .BannedList.Add fso.GetAbsolutePathName(getAppSpecificPath & "\" & CPP_DRIVER_FILE) 565 .BannedList.Add fso.GetAbsolutePathName(getAppSpecificPath & "\" & CWORD_DRIVER_FILE_TEMP) 566 .BannedList.Add fso.GetAbsolutePathName(getAppSpecificPath & "\" & CEXCEL_DRIVER_FILE_TEMP) 567 .BannedList.Add fso.GetAbsolutePathName(getAppSpecificPath & "\" & CPP_DRIVER_FILE_TEMP) 568 .BannedList.Add theResultsFile 569 End With 570 myDocFiles.Search rootDir:=startDir, FileSpecs:=searchTypes, _ 571 IncludeSubdirs:=bIncludeSubdirs 572 573 If getAppSpecificApplicationName = CAPPNAME_WORD Then 574 Set myFiles = myDocFiles.WordFiles 575 ElseIf getAppSpecificApplicationName = CAPPNAME_EXCEL Then 576 Set myFiles = myDocFiles.ExcelFiles 577 ElseIf getAppSpecificApplicationName = CAPPNAME_POWERPOINT Then 578 Set myFiles = myDocFiles.PowerPointFiles 579 Else 580 WriteDebug currentFunctionName & " : invalid application " & getAppSpecificApplicationName 581 GoTo FinalExit 582 End If 583 584 GetFilesToAnalyze = True 585 586FinalExit: 587 Set searchTypes = Nothing 588 Set myDocFiles = Nothing 589 590 Exit Function 591 592HandleErrors: 593 WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source 594 Resume FinalExit 595End Function 596 597Function GetFilesToAnalyze(fileList As String, startFile As String, _ 598 myFiles As Collection) As Boolean 599 600 On Error GoTo HandleErrors 601 Dim currentFunctionName As String 602 currentFunctionName = "GetFilesToAnalyze" 603 604 Dim fso As New FileSystemObject 605 Dim fileContent As TextStream 606 Dim fileName As String 607 608 GetFilesToAnalyze = False 609 610 If (startFile = "") Then 611 If (fso.FileExists(fileList)) Then 612 Set fileContent = fso.OpenTextFile(fileList, ForReading, False, TristateTrue) 613 While (Not fileContent.AtEndOfStream) 614 fileName = fileContent.ReadLine 615 fileName = Trim(fileName) 616 If (fileName <> "") Then 617 myFiles.Add (fileName) 618 End If 619 Wend 620 fileContent.Close 621 End If 622 Else 623 myFiles.Add (startFile) 624 End If 625 626 If (myFiles.count <> 0) Then GetFilesToAnalyze = True 627 628FinalExit: 629 Set fileContent = Nothing 630 Set fso = Nothing 631 Exit Function 632 633HandleErrors: 634 WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source 635 Resume FinalExit 636End Function 637 638Function GetPrepareFilesToAnalyze(resultsFilePath As String, myFiles As Collection, _ 639 fso As FileSystemObject) As Boolean 640 On Error GoTo HandleErrors 641 Dim currentFunctionName As String 642 currentFunctionName = "GetPrepareFilesToAnalyze" 643 644 GetPrepareFilesToAnalyze = False 645 646 If Not fso.FileExists(resultsFilePath) Then 647 WriteDebug currentFunctionName & ": results file does not exist : " & resultsFilePath 648 GoTo FinalExit 649 End If 650 651 'Open results spreadsheet 652 Dim xl As Excel.Application 653 If getAppSpecificApplicationName = CAPPNAME_EXCEL Then 654 Set xl = Application 655 xl.Visible = True 656 Else 657 Set xl = GetExcelInstance 658 xl.Visible = False 659 End If 660 Dim logWb As WorkBook 661 Set logWb = xl.Workbooks.Open(resultsFilePath) 662 663 Dim wsDocProp As Worksheet 664 Set wsDocProp = logWb.Sheets(RID_STR_COMMON_RESULTS_SHEET_NAME_DOCPROP) 665 666 Dim startRow As Long 667 Dim endRow As Long 668 startRow = mDocPropRowOffset + 1 669 endRow = GetWorkbookNameValueAsLong(logWb, CTOTAL_DOCS_ANALYZED) + mDocPropRowOffset 670 671 GetPreparableFilesFromDocProps wsDocProp, startRow, endRow, fso, myFiles 672 673 GetPrepareFilesToAnalyze = (myFiles.count > 0) 674 675FinalExit: 676 Set wsDocProp = Nothing 677 If Not logWb Is Nothing Then logWb.Close 678 Set logWb = Nothing 679 680 If getAppSpecificApplicationName <> CAPPNAME_EXCEL Then 681 If Not xl Is Nothing Then 682 If xl.Workbooks.count = 0 Then 683 xl.Quit 684 End If 685 End If 686 End If 687 Set xl = Nothing 688 689 Exit Function 690 691HandleErrors: 692 WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source 693 Resume FinalExit 694End Function 695 696Function GetPreparableFilesFromDocProps(wsDocProp As Worksheet, startRow As Long, _ 697 endRow As Long, fso As FileSystemObject, myFiles As Collection) As Boolean 698 On Error GoTo HandleErrors 699 Dim currentFunctionName As String 700 currentFunctionName = "GetPreparableFilesFromDocProps" 701 GetPreparableFilesFromDocProps = False 702 703 Dim index As Long 704 Dim fileName As String 705 Dim fileExt As String 706 Dim docExt As String 707 Dim templateExt As String 708 709 docExt = getAppSpecificDocExt 710 templateExt = getAppSpecificTemplateExt 711 712 For index = startRow To endRow 713 If GetWorksheetCellValueAsLong(wsDocProp, index, CDOCINFOPREPAREDISSUES) > 0 Then 714 fileName = GetWorksheetCellValueAsString(wsDocProp, index, CDOCINFONAME) 715 fileExt = "." & fso.GetExtensionName(fileName) 716 'Don't have to worry about search types - just looking at existing results 717 'so just check both legal extensions for this application 718 If fileExt = docExt Or fileExt = templateExt Then 719 myFiles.Add GetWorksheetCellValueAsString(wsDocProp, index, CDOCINFONAMEANDPATH) 720 End If 721 End If 722 Next index 723 724 GetPreparableFilesFromDocProps = myFiles.count > 0 725FinalExit: 726 Exit Function 727 728HandleErrors: 729 GetPreparableFilesFromDocProps = False 730 WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source 731 Resume FinalExit 732End Function 733 734Sub OpenXLSResultFile(resultsFile As String, _ 735 resultsTemplate As String, _ 736 bNewResultsFile As Boolean, _ 737 excelApp As Excel.Application, _ 738 resultSheet As Excel.WorkBook) 739 740 On Error GoTo HandleErrors 741 Dim currentFunctionName As String 742 currentFunctionName = "OpenXLSResultFile" 743 744 If getAppSpecificApplicationName = CAPPNAME_EXCEL Then 745 Set excelApp = Application 746 excelApp.Visible = True 747 Else 748 Set excelApp = GetExcelInstance 749 excelApp.Visible = False 750 End If 751 752 If bNewResultsFile Then 753 Set resultSheet = excelApp.Workbooks.Add(Template:=resultsTemplate) 754 Localize_WorkBook resultSheet 755 Else 756 Set resultSheet = excelApp.Workbooks.Open(resultsFile) 757 End If 758 759FinalExit: 760 Exit Sub 761 762HandleErrors: 763 excelApp.DisplayAlerts = False 764 WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source 765 Resume FinalExit 766End Sub 767 768Sub CloseXLSResultFile(excelApp As Excel.Application, _ 769 resultSheet As Excel.WorkBook) 770 771 On Error Resume Next 772 773 If Not resultSheet Is Nothing Then resultSheet.Close 774 Set resultSheet = Nothing 775 776 If getAppSpecificApplicationName <> CAPPNAME_EXCEL Then 777 If Not excelApp Is Nothing Then 778 excelApp.Visible = True 779 If excelApp.Workbooks.count = 0 Then 780 excelApp.Quit 781 End If 782 End If 783 End If 784 Set excelApp = Nothing 785 786 Exit Sub 787End Sub 788 789Sub WriteXLSOutput(storeToDir As String, resultsFile As String, resultsTemplate As String, _ 790 bOverwriteResultsFile As Boolean, bNewResultsFile As Boolean, AnalysedDocs As Collection, _ 791 fso As Scripting.FileSystemObject) 792 793 On Error GoTo HandleErrors 794 Dim currentFunctionName As String 795 currentFunctionName = "WriteXLSOutput" 796 797 Dim offsetDocPropRow As Long 798 Dim offsetDocIssuesRow As Long 799 Dim offsetDocIssueDetailsRow As Long 800 Dim offsetDocRefDetailsRow As Long 801 802 Const COVERVIEW_SHEET_IDX = 1 803 Const CDOCLIST_SHEET_IDX = 2 804 Const CISSUES_ANALYSED_SHEET = 3 805 Const CISSUE_DETAILS_SHEET = 4 806 Const CWORD_ISSUES_SHEET = 5 807 Const CEXCEL_ISSUES_SHEET = 6 808 Const CPOWERPOINT_ISSUES_SHEET = 7 809 Const CREFERENCE_ISSUES_SHEET = 8 810 811 'Begin writing stats to excel 812 Dim xl As Excel.Application 813 If getAppSpecificApplicationName = CAPPNAME_EXCEL Then 814 Set xl = Application 815 xl.Visible = True 816 Else 817 Set xl = GetExcelInstance 818 xl.Visible = False 819 End If 820 821 Dim logWb As WorkBook 822 823 If bNewResultsFile Then 824 Set logWb = xl.Workbooks.Add(Template:=resultsTemplate) 825 Localize_WorkBook logWb 826 Else 827 Set logWb = xl.Workbooks.Open(storeToDir & "\" & resultsFile) 828 End If 829 830 SetupAnalysisResultsVariables logWb, offsetDocPropRow, _ 831 offsetDocIssuesRow, offsetDocIssueDetailsRow, offsetDocRefDetailsRow 832 833 ' Iterate through results and write info 834 Dim aAnalysis As DocumentAnalysis 835 Dim row As Long 836 Dim docCounts As DocumentCount 837 Dim templateCounts As DocumentCount 838 839 Dim issuesRow As Long 840 Dim issueDetailsRow As Long 841 Dim refDetailsRow As Long 842 843 Dim wsOverview As Worksheet 844 Dim wsCosts As Worksheet 845 Dim wsPgStats As Worksheet 846 Dim wsIssues As Worksheet 847 Dim wsIssueDetails As Worksheet 848 Dim wsRefDetails As Worksheet 849 850 Set wsOverview = logWb.Sheets(COVERVIEW_SHEET_IDX) 851 Set wsPgStats = logWb.Sheets(CDOCLIST_SHEET_IDX) 852 853 'Some localized names might be longer than 31 chars, excel doesn't 854 'allow such names! 855 On Error Resume Next 856 wsOverview.name = RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW 857 wsPgStats.name = RID_STR_COMMON_RESULTS_SHEET_NAME_DOCPROP 858 On Error GoTo HandleErrors 859 860 If InDocPreparation Then 861 Set wsCosts = logWb.Sheets(CISSUES_ANALYSED_SHEET) 862 Dim appName As String 863 appName = getAppSpecificApplicationName 864 Select Case appName 865 Case "Word" 866 Set wsIssues = logWb.Worksheets(CWORD_ISSUES_SHEET) 867 Case "Excel" 868 Set wsIssues = logWb.Worksheets(CEXCEL_ISSUES_SHEET) 869 Case "PowerPoint" 870 Set wsIssues = logWb.Worksheets(CPOWERPOINT_ISSUES_SHEET) 871 Case Default 872 Err.Raise Number:=-1, Description:="BadAppName" 873 End Select 874 Set wsIssueDetails = logWb.Sheets(CISSUE_DETAILS_SHEET) 875 Set wsRefDetails = logWb.Sheets(CREFERENCE_ISSUES_SHEET) 876 issuesRow = 1 + CROWOFFSET + offsetDocIssuesRow 877 issueDetailsRow = 1 + CROWOFFSET + offsetDocIssueDetailsRow 878 refDetailsRow = 1 + CROWOFFSET + offsetDocRefDetailsRow 879 ' localize PAW worksheets 880 Dim wsWordIssues As Worksheet 881 Dim wsExcelIssues As Worksheet 882 Dim wsPowerPointIssues As Worksheet 883 Set wsWordIssues = logWb.Worksheets(CWORD_ISSUES_SHEET) 884 Set wsExcelIssues = logWb.Worksheets(CEXCEL_ISSUES_SHEET) 885 Set wsPowerPointIssues = logWb.Worksheets(CPOWERPOINT_ISSUES_SHEET) 886 887 On Error Resume Next 888 wsCosts.name = RID_STR_COMMON_RESULTS_SHEET_NAME_COSTS 889 wsIssueDetails.name = RID_STR_COMMON_RESULTS_SHEET_NAME_DOCISSUE_DETAILS 890 wsRefDetails.name = RID_STR_COMMON_RESULTS_SHEET_NAME_DOCREF_DETAILS 891 wsWordIssues.name = RID_STR_COMMON_RESULTS_SHEET_NAME_DOCISSUES_WORD 892 wsExcelIssues.name = RID_STR_COMMON_RESULTS_SHEET_NAME_DOCISSUES_EXCEL 893 wsPowerPointIssues.name = RID_STR_COMMON_RESULTS_SHEET_NAME_DOCISSUES_POWERPOINT 894 On Error GoTo HandleErrors 895 End If 896 897 Dim fileName As String 898 Dim macroClasses As DocMacroClassifications 899 Dim issueClasses As DocIssueClassifications 900 901 For row = 1 To AnalysedDocs.count 'Need Row count - so not using Eor Each 902 Set aAnalysis = AnalysedDocs.item(row) 903 fileName = fso.GetFileName(aAnalysis.name) 904 905 If InDocPreparation Then 906 issuesRow = WriteDocIssues(wsIssues, issuesRow, aAnalysis, fileName) 907 issueDetailsRow = _ 908 ProcessIssuesAndWriteDocIssueDetails(logWb, wsIssueDetails, issueDetailsRow, aAnalysis, fileName) 909 refDetailsRow = _ 910 WriteDocRefDetails(wsRefDetails, refDetailsRow, aAnalysis, fileName) 911 aAnalysis.MacroCosts = getMacroIssueCosts(logWb, aAnalysis) 912 WriteDocProperties wsPgStats, row + offsetDocPropRow, aAnalysis, fileName 913 Else 914 ProcessIssuesForDAW logWb, aAnalysis, fileName 915 WriteDocProperties wsPgStats, row + offsetDocPropRow, aAnalysis, fileName 916 End If 917 918 UpdateAllCounts aAnalysis, docCounts, templateCounts, macroClasses, issueClasses, fso 919 920 Set aAnalysis = Nothing 921 Next row 922 923 ' We change the font used for text box shapes here for the japanese 924 ' version, because office 2000 sometimes displays squares instead of 925 ' chars 926 Dim langStr As String 927 Dim userLCID As Long 928 Dim textSize As Long 929 Dim fontName As String 930 931 userLCID = GetUserDefaultLangID() 932 langStr = GetUserLocaleInfo(userLCID, LOCALE_SISO639LANGNAME) 933 934 If (langStr = "ja") Then 935 WriteDebug currentFunctionName & " : Setting font to MS PGothic for 'ja' locale" 936 fontName = "MS PGothic" 937 textSize = 10 938 Else 939 fontName = "Arial" 940 textSize = CLEGEND_FONT_SIZE 941 End If 942 943 'DAW - PAW switches 944 If InDocPreparation Then 945 SaveAnalysisResultsVariables logWb, issueDetailsRow - (1 + CROWOFFSET), _ 946 refDetailsRow - (1 + CROWOFFSET) 947 948 WriteOverview logWb, docCounts, templateCounts, macroClasses, issueClasses 949 950 SetupPAWResultsSpreadsheet logWb, fontName, textSize 951 WriteIssueCounts logWb 952 Else 953 WriteOverview logWb, docCounts, templateCounts, macroClasses, issueClasses 954 955 'StartTiming 956 SetupDAWResultsSpreadsheet logWb, fontName, textSize 957 'EndTiming "SetupDAWResultsSpreadsheet" 958 End If 959 960 SetupPrintRanges logWb, row, issuesRow, issueDetailsRow, refDetailsRow 961 962 If resultsFile <> "" Then 963 'Overwrite existing results file without prompting 964 If bOverwriteResultsFile Or (Not bNewResultsFile) Then 965 xl.DisplayAlerts = False 966 End If 967 968 logWb.SaveAs fileName:=storeToDir & "\" & resultsFile 969 xl.DisplayAlerts = True 970 End If 971 972FinalExit: 973 If Not xl Is Nothing Then 974 xl.Visible = True 975 End If 976 977 Set wsOverview = Nothing 978 Set wsPgStats = Nothing 979 980 If InDocPreparation Then 981 Set wsCosts = Nothing 982 Set wsIssues = Nothing 983 Set wsIssueDetails = Nothing 984 Set wsRefDetails = Nothing 985 End If 986 987 If Not logWb Is Nothing Then logWb.Close 988 Set logWb = Nothing 989 990 If getAppSpecificApplicationName <> CAPPNAME_EXCEL Then 991 If Not xl Is Nothing Then 992 If xl.Workbooks.count = 0 Then 993 xl.Quit 994 End If 995 End If 996 End If 997 Set xl = Nothing 998 999 Exit Sub 1000 1001HandleErrors: 1002 xl.DisplayAlerts = False 1003 1004 WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source 1005 Resume FinalExit 1006End Sub 1007 1008Public Sub StartTiming() 1009 mTstart = 0 1010 mTend = 0 1011 mTstart = GetTickCount() 1012End Sub 1013Public Sub EndTiming(what As String) 1014 mTend = GetTickCount() 1015 WriteDebug "Timing: " & what & ": " & (FormatNumber((mTend - mTstart) / 1000, 0) & " seconds") 1016 mTstart = 0 1017 mTend = 0 1018End Sub 1019Sub WriteIssueCounts(logWb As WorkBook) 1020 On Error GoTo HandleErrors 1021 Dim currentFunctionName As String 1022 currentFunctionName = "WriteIssueCounts" 1023 1024 Dim Str As String 1025 Dim str1 As String 1026 Dim val1 As Long 1027 Dim count As Long 1028 Dim vKeyArray As Variant 1029 Dim vItemArray As Variant 1030 Dim vPrepKeyArray As Variant 1031 Dim vPrepItemArray As Variant 1032 1033 vKeyArray = mIssuesDict.Keys 1034 vItemArray = mIssuesDict.Items 1035 1036 vPrepKeyArray = mPreparedIssuesDict.Keys 1037 vPrepItemArray = mPreparedIssuesDict.Items 1038 1039 'Write Issue Counts across all Documents 1040 For count = 0 To mIssuesDict.count - 1 1041 str1 = vKeyArray(count) 1042 val1 = CInt(vItemArray(count)) 1043 logWb.Names(str1).RefersToRange.Cells(1, 1) = _ 1044 logWb.Names(str1).RefersToRange.Cells(1, 1).value + vItemArray(count) 1045 'DEBUG: str = str & "Key: " & str1 & " Value: " & val1 & vbLf 1046 Next count 1047 1048 'Write Prepared Issues Counts across all Documents 1049 For count = 0 To mPreparedIssuesDict.count - 1 1050 str1 = vPrepKeyArray(count) 1051 val1 = CInt(vPrepItemArray(count)) 1052 AddVariantToWorkbookNameValue logWb, str1, vPrepItemArray(count) 1053 'DEBUG: str = str & "Key: " & str1 & " Value: " & val1 & vbLf 1054 Next count 1055 1056 'User Form control type count across all analyzed documents of this type 1057 str1 = getAppSpecificApplicationName & "_" & _ 1058 CSTR_ISSUE_VBA_MACROS & "_" & _ 1059 CSTR_SUBISSUE_PROPERTIES & "_" & _ 1060 CSTR_SUBISSUE_VBA_MACROS_USERFORMS_CONTROLTYPE_COUNT 1061 SetWorkbookNameValueToLong logWb, str1, mUserFormTypesDict.count 1062 1063 'Add list of User Form controls and counts to ...USERFORMS_CONTROLTYPE_COUNT field 1064 If mUserFormTypesDict.count > 0 Then 1065 vKeyArray = mUserFormTypesDict.Keys 1066 vItemArray = mUserFormTypesDict.Items 1067 1068 Str = RID_STR_COMMON_ATTRIBUTE_CONTROLS & ": " 1069 For count = 0 To mUserFormTypesDict.count - 1 1070 Str = Str & vbLf & vKeyArray(count) & " " & vItemArray(count) 1071 Next count 1072 WriteUserFromControlTypesComment logWb, str1, Str 1073 End If 1074 'DEBUG: MsgBox str & vbLf & mIssuesDict.count 1075 1076 WriteUniqueModuleCount logWb 1077 1078FinalExit: 1079 Exit Sub 1080 1081HandleErrors: 1082 WriteDebug currentFunctionName & _ 1083 " : logging costs : " & _ 1084 Err.Number & " " & Err.Description & " " & Err.Source 1085 Resume FinalExit 1086End Sub 1087Sub WriteUniqueModuleCount(logWb As WorkBook) 1088 On Error GoTo HandleErrors 1089 Dim currentFunctionName As String 1090 currentFunctionName = "WriteUniqueModuleCount" 1091 1092 Dim strLabel As String 1093 Dim uniqueLineCount As Long 1094 Dim uniqueModuleCount As Long 1095 Dim count As Long 1096 Dim vItemArray As Variant 1097 1098 vItemArray = mMacroDict.Items 1099 1100 'Write Issues Costs 1101 uniqueLineCount = 0 1102 For count = 0 To mMacroDict.count - 1 1103 uniqueLineCount = uniqueLineCount + CInt(vItemArray(count)) 1104 Next count 1105 uniqueModuleCount = mMacroDict.count 1106 1107 1108 strLabel = getAppSpecificApplicationName & "_" & _ 1109 CSTR_ISSUE_VBA_MACROS & "_" & _ 1110 CSTR_SUBISSUE_PROPERTIES & "_" & _ 1111 CSTR_SUBISSUE_VBA_MACROS_UNIQUE_MODULE_COUNT 1112 SetWorkbookNameValueToLong logWb, strLabel, uniqueModuleCount 1113 1114 strLabel = getAppSpecificApplicationName & "_" & _ 1115 CSTR_ISSUE_VBA_MACROS & "_" & _ 1116 CSTR_SUBISSUE_PROPERTIES & "_" & _ 1117 CSTR_SUBISSUE_VBA_MACROS_UNIQUE_LINE_COUNT 1118 SetWorkbookNameValueToLong logWb, strLabel, uniqueLineCount 1119 1120FinalExit: 1121 Exit Sub 1122 1123HandleErrors: 1124 WriteDebug currentFunctionName & _ 1125 " : logging Unique Module/ Line Counts : " & _ 1126 Err.Number & " " & Err.Description & " " & Err.Source 1127 Resume FinalExit 1128End Sub 1129 1130Sub WriteUserFromControlTypesComment(logWb As WorkBook, name As String, comment As String) 1131 On Error GoTo HandleErrors 1132 Dim currentFunctionName As String 1133 currentFunctionName = "WriteUserFromControlTypesComment" 1134 1135 On Error Resume Next 'Ignore error if trying to add comment again - would happen on append to results 1136 logWb.Names(name).RefersToRange.Cells(1, 1).AddComment 1137 1138 On Error GoTo HandleErrors 1139 logWb.Names(name).RefersToRange.Cells(1, 1).comment.Text Text:=comment 1140 'Autosize not supported - Office 2000 1141 'logWb.Names(name).RefersToRange.Cells(1, 1).comment.AutoSize = True 1142 logWb.Names(name).RefersToRange.Cells(1, 1).comment.Visible = False 1143 1144FinalExit: 1145 Exit Sub 1146 1147HandleErrors: 1148 WriteDebug currentFunctionName & _ 1149 " : name : " & name & _ 1150 " : comment : " & comment & _ 1151 Err.Number & " " & Err.Description & " " & Err.Source 1152 Resume FinalExit 1153End Sub 1154 1155Sub UpdateAllCounts(aAnalysis As DocumentAnalysis, counts As DocumentCount, templateCounts As DocumentCount, _ 1156 macroClasses As DocMacroClassifications, issueClasses As DocIssueClassifications, _ 1157 fso As FileSystemObject) 1158 Const CMODDATE_LESS3MONTHS = 91 1159 Const CMODDATE_LESS6MONTHS = 182 1160 Const CMODDATE_LESS12MONTHS = 365 1161 1162 On Error GoTo HandleErrors 1163 Dim currentFunctionName As String 1164 currentFunctionName = "UpdateAllCounts" 1165 'DocIssue Classification occurs in setDocOverallIssueClassification under 1166 ' ProcessIssuesAndWriteDocIssueDetails when all DocIssues are being traversed. 1167 'MacroClass for the Doc is setup at the end of the Analyze_Macros in DoAnalysis 1168 'Mod Dates are determined in SetDocProperties in DoAnalysis 1169 1170 'DocMacroClassifications 1171 Select Case aAnalysis.MacroOverallClass 1172 Case enMacroComplex 1173 macroClasses.complex = macroClasses.complex + 1 1174 Case enMacroMedium 1175 macroClasses.Medium = macroClasses.Medium + 1 1176 Case enMacroSimple 1177 macroClasses.Simple = macroClasses.Simple + 1 1178 Case Else 1179 macroClasses.None = macroClasses.None + 1 1180 End Select 1181 1182 'DocIssueClassifications 1183 aAnalysis.BelowIssuesLimit = True 1184 Select Case aAnalysis.DocOverallIssueClass 1185 Case enComplex 1186 issueClasses.complex = issueClasses.complex + 1 1187 Case enMinor 1188 issueClasses.Minor = issueClasses.Minor + 1 1189 Case Else 1190 issueClasses.None = issueClasses.None + 1 1191 End Select 1192 1193 'DocumentCounts 1194 Dim extStr As String 1195 extStr = "." & LCase(fso.GetExtensionName(aAnalysis.name)) 1196 If extStr = getAppSpecificDocExt Then 1197 UpdateDocCounts counts, aAnalysis 1198 ElseIf extStr = getAppSpecificTemplateExt Then 1199 UpdateDocCounts templateCounts, aAnalysis 1200 Else 1201 WriteDebug currentFunctionName & " : path " & aAnalysis.name & _ 1202 ": unhandled file extesnion " & extStr & " : " & Err.Number & " " & Err.Description & " " & Err.Source 1203 End If 1204 1205FinalExit: 1206 Exit Sub 1207 1208HandleErrors: 1209 WriteDebug currentFunctionName & " : path " & aAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1210 Resume FinalExit 1211End Sub 1212Sub UpdateDocCounts(counts As DocumentCount, aAnalysis As DocumentAnalysis) 1213 On Error GoTo HandleErrors 1214 Dim currentFunctionName As String 1215 currentFunctionName = "UpdateDocCounts" 1216 1217 counts.numDocsAnalyzed = counts.numDocsAnalyzed + 1 1218 If aAnalysis.IssuesCount > 0 Then 'During Analysis incremented 1219 counts.numDocsAnalyzedWithIssues = counts.numDocsAnalyzedWithIssues + 1 1220 1221 If aAnalysis.BelowIssuesLimit Then 1222 counts.numMinorIssues = _ 1223 counts.numMinorIssues + aAnalysis.MinorIssuesCount 1224 'MinorIssuesCount incemented as all DocIssues are being traversed are being written out - ProcessIssuesAndWriteDocIssueDetails 1225 counts.numComplexIssues = counts.numComplexIssues + aAnalysis.ComplexIssuesCount 'Calculated 1226 counts.totalDocIssuesCosts = counts.totalDocIssuesCosts + _ 1227 aAnalysis.DocIssuesCosts 1228 counts.totalPreparableIssuesCosts = counts.totalPreparableIssuesCosts + _ 1229 aAnalysis.PreparableIssuesCosts 1230 End If 1231 1232 counts.numMacroIssues = counts.numMacroIssues + aAnalysis.MacroIssuesCount 'During Analysis incremented 1233 counts.totalMacroCosts = counts.totalMacroCosts + aAnalysis.MacroCosts 1234 End If 1235 1236FinalExit: 1237 Exit Sub 1238 1239HandleErrors: 1240 WriteDebug currentFunctionName & " : path " & aAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1241 Resume FinalExit 1242End Sub 1243 1244 1245Sub WriteDocProperties(wsPgStats As Worksheet, row As Long, aAnalysis As DocumentAnalysis, _ 1246 fileName As String) 1247 On Error GoTo HandleErrors 1248 Dim currentFunctionName As String 1249 currentFunctionName = "WriteDocProperties" 1250 1251 Dim rowIndex As Long 1252 rowIndex = row + mDocPropRowOffset 1253 1254 If aAnalysis.Application = RID_STR_COMMON_CANNOT_OPEN Then 1255 SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFONAME, fileName 1256 SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFOAPPLICATION, aAnalysis.Application 1257 SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFONAMEANDPATH, aAnalysis.name 1258 1259 GoTo FinalExit 1260 End If 1261 1262 If InDocPreparation Then 1263 SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFONAME, fileName 1264 SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFOAPPLICATION, aAnalysis.Application 1265 1266 SetWorksheetCellValueToLong wsPgStats, rowIndex, CDOCINFODOCISSUECOSTS, aAnalysis.DocIssuesCosts 1267 SetWorksheetCellValueToLong wsPgStats, rowIndex, CDOCINFOPREPARABLEISSUECOSTS, aAnalysis.PreparableIssuesCosts 1268 SetWorksheetCellValueToLong wsPgStats, rowIndex, CDOCINFOMACROISSUECOSTS, aAnalysis.MacroCosts 1269 1270 SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFOISSUE_CLASS, _ 1271 getDocOverallIssueClassificationAsString(aAnalysis.DocOverallIssueClass) 1272 SetWorksheetCellValueToLong wsPgStats, rowIndex, CDOCINFOCOMPLEXISSUES, aAnalysis.ComplexIssuesCount 1273 SetWorksheetCellValueToLong wsPgStats, rowIndex, CDOCINFOMINORISSUES, aAnalysis.MinorIssuesCount 1274 SetWorksheetCellValueToLong wsPgStats, rowIndex, CDOCINFOPREPAREDISSUES, aAnalysis.PreparableIssuesCount 1275 1276 SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFOMACRO_CLASS, _ 1277 getDocOverallMacroClassAsString(aAnalysis.MacroOverallClass) 1278 SetWorksheetCellValueToLong wsPgStats, rowIndex, CDOCINFOMACRO_USERFORMS, aAnalysis.MacroNumUserForms 1279 SetWorksheetCellValueToLong wsPgStats, rowIndex, CDOCINFOMACRO_LINESOFCODE, aAnalysis.MacroTotalNumLines 1280 1281 SetWorksheetCellValueToLong wsPgStats, rowIndex, CDOCINFONUMBERPAGES, aAnalysis.PageCount 1282 SetWorksheetCellValueToVariant wsPgStats, rowIndex, CDOCINFOCREATED, CheckDate(aAnalysis.Created) 1283 SetWorksheetCellValueToVariant wsPgStats, rowIndex, CDOCINFOLASTMODIFIED, CheckDate(aAnalysis.Modified) 1284 SetWorksheetCellValueToVariant wsPgStats, rowIndex, CDOCINFOLASTACCESSED, CheckDate(aAnalysis.Accessed) 1285 SetWorksheetCellValueToVariant wsPgStats, rowIndex, CDOCINFOLASTPRINTED, CheckDate(aAnalysis.Printed) 1286 1287 SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFOLASTSAVEDBY, aAnalysis.SavedBy 1288 SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFOREVISION, aAnalysis.Revision 1289 SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFOTEMPLATE, aAnalysis.Template 1290 SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFONAMEANDPATH, aAnalysis.name 1291 Else 1292 SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFONAME, fileName 1293 SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFOAPPLICATION, aAnalysis.Application 1294 SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFOISSUE_CLASS, _ 1295 getDocOverallIssueClassificationAsString(aAnalysis.DocOverallIssueClass) 1296 SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFOMACRO_CLASS, _ 1297 getDocOverallMacroClassAsString(aAnalysis.MacroOverallClass) 1298 SetWorksheetCellValueToVariant wsPgStats, rowIndex, CDOCINFOLASTMODIFIED, CheckDate(aAnalysis.Modified) 1299 SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFONAMEANDPATH, aAnalysis.name 1300 End If 1301 1302FinalExit: 1303 Exit Sub 1304 1305HandleErrors: 1306 WriteDebug currentFunctionName & " : path " & aAnalysis.name & " : " & Err.Number & " " & Err.Description & " " & Err.Source 1307 Resume FinalExit 1308End Sub 1309Function CheckDate(myDate As Date) As Variant 1310 On Error GoTo HandleErrors 1311 Dim currentFunctionName As String 1312 currentFunctionName = "CheckDate" 1313 1314 Dim lowerNTDateLimit As Date 1315 If Not IsDate(myDate) Then 1316 CheckDate = RID_STR_COMMON_NA 1317 Exit Function 1318 End If 1319 1320 lowerNTDateLimit = DateSerial(1980, 1, 1) 1321 CheckDate = IIf(myDate < lowerNTDateLimit, RID_STR_COMMON_NA, myDate) 1322FinalExit: 1323 Exit Function 1324 1325HandleErrors: 1326 WriteDebug currentFunctionName & " : date " & myDate & " : " & Err.Number & " " & Err.Description & " " & Err.Source 1327 Resume FinalExit 1328End Function 1329 1330Function WriteDocIssues(wsIssues As Worksheet, row As Long, _ 1331 aAnalysis As DocumentAnalysis, fileName As String) As Long 1332 On Error GoTo HandleErrors 1333 Dim currentFunctionName As String 1334 currentFunctionName = "WriteDocIssues" 1335 1336 Const CNAME = 1 1337 Const CAPPLICATION = CNAME + 1 1338 Const CISSUE_COLUMNOFFSET = CAPPLICATION 1339 1340 If aAnalysis.IssuesCount = 0 Then 1341 WriteDocIssues = row 1342 Exit Function 1343 End If 1344 SetWorksheetCellValueToString wsIssues, row, CNAME, fileName 1345 SetWorksheetCellValueToString wsIssues, row, CAPPLICATION, aAnalysis.Application 1346 1347 Dim index As Integer 1348 For index = 1 To aAnalysis.TotalIssueTypes 1349 If aAnalysis.IssuesCountArray(index) > 0 Then 1350 SetWorksheetCellValueToString wsIssues, row, CISSUE_COLUMNOFFSET + index, aAnalysis.IssuesCountArray(index) 1351 End If 1352 Next index 1353 SetWorksheetCellValueToString wsIssues, row, CISSUE_COLUMNOFFSET + aAnalysis.TotalIssueTypes + 1, aAnalysis.name 1354 1355 WriteDocIssues = row + 1 1356FinalExit: 1357 Exit Function 1358 1359HandleErrors: 1360 WriteDebug currentFunctionName & " : path " & aAnalysis.name & " : " & Err.Number & " " & Err.Description & " " & Err.Source 1361 Resume FinalExit 1362End Function 1363Sub ProcessIssuesForDAW(logWb As WorkBook, aAnalysis As DocumentAnalysis, fileName As String) 1364 On Error GoTo HandleErrors 1365 Dim currentFunctionName As String 1366 currentFunctionName = "ProcessIssuesForDAW" 1367 1368 Dim myIssue As IssueInfo 1369 Dim issueClass As EnumDocOverallIssueClass 1370 1371 Dim index As Integer 1372 For index = 1 To aAnalysis.Issues.count 1373 Set myIssue = aAnalysis.Issues(index) 1374 1375 If Not isMacroIssue(myIssue) Then 1376 issueClass = getDocIssueClassification(logWb, myIssue) 1377 CountDocIssuesForDoc issueClass, aAnalysis 1378 SetOverallDocIssueClassification issueClass, aAnalysis 1379 End If 1380 1381 Set myIssue = Nothing 1382 Next index 1383 1384FinalExit: 1385 Exit Sub 1386 1387HandleErrors: 1388 WriteDebug currentFunctionName & " : path " & aAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1389 Resume FinalExit 1390End Sub 1391 1392Function ProcessIssuesAndWriteDocIssueDetails(logWb As WorkBook, wsIssueDetails As Worksheet, DetailsRow As Long, _ 1393 aAnalysis As DocumentAnalysis, fileName As String) As Long 1394 On Error GoTo HandleErrors 1395 Dim currentFunctionName As String 1396 currentFunctionName = "ProcessIssueAndWriteDocIssueDetails" 1397 1398 Dim myIssue As IssueInfo 1399 Dim rowIndex As Long 1400 Dim issueClass As EnumDocOverallIssueClass 1401 Dim issueCost As Long 1402 1403 rowIndex = DetailsRow 1404 1405 Dim index As Integer 1406 For index = 1 To aAnalysis.Issues.count 1407 Set myIssue = aAnalysis.Issues(index) 1408 1409 ' Process Document Issues and Costs for the Document 1410 ' Will be output to List of Documents sheet by WriteDocProperties( ) 1411 If Not isMacroIssue(myIssue) Then 1412 issueClass = getDocIssueClassification(logWb, myIssue) 1413 CountDocIssuesForDoc issueClass, aAnalysis 1414 SetOverallDocIssueClassification issueClass, aAnalysis 1415 issueCost = getDocIssueCost(logWb, aAnalysis, myIssue) 1416 aAnalysis.DocIssuesCosts = aAnalysis.DocIssuesCosts + issueCost 1417 If myIssue.Preparable Then 1418 aAnalysis.PreparableIssuesCosts = aAnalysis.PreparableIssuesCosts + issueCost 1419 End If 1420 End If 1421 1422 'Collate Issue and Factor counts across all Documents 1423 'Will be output to the Issues Analyzed sheet by WriteIssueCounts( ) 1424 CollateIssueAndFactorCountsAcrossAllDocs aAnalysis, myIssue, fileName 1425 1426 OutputCommonIssueDetails wsIssueDetails, rowIndex, aAnalysis, myIssue, fileName 1427 OutputCommonIssueAttributes wsIssueDetails, rowIndex, myIssue 1428 rowIndex = rowIndex + 1 1429 Set myIssue = Nothing 1430 Next index 1431 1432 ProcessIssuesAndWriteDocIssueDetails = rowIndex 1433 1434FinalExit: 1435 Exit Function 1436 1437HandleErrors: 1438 WriteDebug currentFunctionName & " : path " & aAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1439 Resume FinalExit 1440End Function 1441 1442Function getDocIssueCost(logWb As WorkBook, aAnalysis As DocumentAnalysis, myIssue As IssueInfo) As Long 1443 On Error GoTo HandleErrors 1444 Dim currentFunctionName As String 1445 currentFunctionName = "getDocIssueCost" 1446 1447 Dim issueKey As String 1448 Dim ret As Long 1449 ret = 0 1450 1451 issueKey = getAppSpecificApplicationName & "_" & myIssue.IssueTypeXML & "_" & myIssue.SubTypeXML 1452 1453 ret = getIssueValueFromXLSorDict(logWb, aAnalysis, mIssuesCostDict, issueKey, 1, CCOST_COL_OFFSET) 1454 1455FinalExit: 1456 getDocIssueCost = ret 1457 Exit Function 1458 1459HandleErrors: 1460 ret = 0 1461 WriteDebug currentFunctionName & " : path " & aAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1462 Resume FinalExit 1463End Function 1464Function getMacroIssueCosts(logWb As WorkBook, aAnalysis As DocumentAnalysis) As Long 1465 'Error handling not required 1466 getMacroIssueCosts = getVBAMacroIssueCost(logWb, aAnalysis) '+ getMacroExtRefIssueCost(logWb, aAnalysis) 1467 'NOTE: Currently not counting External Refs as Macro Cost 1468 'could be added if porting off Windows 1469 1470End Function 1471 1472Function getVBAMacroIssueCost(logWb As WorkBook, aAnalysis As DocumentAnalysis) As Long 1473 Const CMACRO_ROW_OFFSET_UNIQUE_LINES_COST = 4 1474 Const CMACRO_ROW_OFFSET_USER_FORMS_COUNT_COST = 5 1475 Const CMACRO_ROW_OFFSET_USER_FORMS_CONTROL_COUNT_COST = 6 1476 Const CMACRO_ROW_OFFSET_USER_FORMS_CONTROL_TYPE_COUNT_COST = 7 1477 1478 Const CMACRO_NUM_OF_LINES_FACTOR_KEY = "_UniqueLineCount" 1479 Const CMACRO_USER_FORMS_COUNT_FACTOR_KEY = "_UserFormsCount" 1480 Const CMACRO_USER_FORMS_CONTROL_COUNT_FACTOR_KEY = "_UserFormsControlCount" 1481 Const CMACRO_USER_FORMS_CONTROL_TYPE_COUNT_FACTOR_KEY = "_UserFormsControlTypeCount" 1482 1483 On Error GoTo HandleErrors 1484 Dim currentFunctionName As String 1485 currentFunctionName = "getVBAMacroIssueCost" 1486 1487 Dim baseIssueKey As String 1488 Dim ret As Long 1489 ret = 0 1490 1491 If Not aAnalysis.HasMacros Then GoTo FinalExit 1492 1493 'Fetch VBA Macro Cost Factors - if required 1494 baseIssueKey = getAppSpecificApplicationName & "_" & CSTR_ISSUE_VBA_MACROS & "_" & CSTR_SUBISSUE_PROPERTIES 1495 1496 'Num Lines - Costing taken from "Lines in Unique Modules" 1497 If aAnalysis.MacroTotalNumLines > 0 Then 1498 ret = ret + aAnalysis.MacroTotalNumLines * _ 1499 getValueFromXLSorDict(logWb, aAnalysis, mIssuesCostDict, _ 1500 baseIssueKey & CMACRO_NUM_OF_LINES_FACTOR_KEY, baseIssueKey, _ 1501 CMACRO_ROW_OFFSET_UNIQUE_LINES_COST, CCOST_COL_OFFSET) 1502 End If 1503 'User Forms Count 1504 If aAnalysis.MacroNumUserForms > 0 Then 1505 ret = ret + aAnalysis.MacroNumUserForms * _ 1506 getValueFromXLSorDict(logWb, aAnalysis, mIssuesCostDict, _ 1507 baseIssueKey & CMACRO_USER_FORMS_COUNT_FACTOR_KEY, baseIssueKey, _ 1508 CMACRO_ROW_OFFSET_USER_FORMS_COUNT_COST, CCOST_COL_OFFSET) 1509 End If 1510 'User Forms Control Count 1511 If aAnalysis.MacroNumUserFormControls > 0 Then 1512 ret = ret + aAnalysis.MacroNumUserFormControls * _ 1513 getValueFromXLSorDict(logWb, aAnalysis, mIssuesCostDict, _ 1514 baseIssueKey & CMACRO_USER_FORMS_CONTROL_COUNT_FACTOR_KEY, baseIssueKey, _ 1515 CMACRO_ROW_OFFSET_USER_FORMS_CONTROL_COUNT_COST, CCOST_COL_OFFSET) 1516 End If 1517 'User Forms Control Type Count 1518 If aAnalysis.MacroNumUserFormControlTypes > 0 Then 1519 ret = ret + aAnalysis.MacroNumUserFormControlTypes * getValueFromXLSorDict(logWb, aAnalysis, mIssuesCostDict, _ 1520 baseIssueKey & CMACRO_USER_FORMS_CONTROL_TYPE_COUNT_FACTOR_KEY, baseIssueKey, CMACRO_ROW_OFFSET_USER_FORMS_CONTROL_TYPE_COUNT_COST, CCOST_COL_OFFSET) 1521 End If 1522 1523 1524FinalExit: 1525 getVBAMacroIssueCost = ret 1526 Exit Function 1527 1528HandleErrors: 1529 ret = 0 1530 WriteDebug currentFunctionName & " : path " & aAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1531 Resume FinalExit 1532End Function 1533Function getMacroExtRefIssueCost(logWb As WorkBook, aAnalysis As DocumentAnalysis) As Long 1534 Const CMACRO_ROW_OFFSET_NUM_EXTERNAL_REFS_COST = 2 1535 Const CMACRO_NUM_EXTERNAL_REFS_FACTOR_KEY = "_ExternalRefs" 1536 1537 On Error GoTo HandleErrors 1538 Dim currentFunctionName As String 1539 currentFunctionName = "getMacroExtRefIssueCost" 1540 Dim baseIssueKey As String 1541 Dim ret As Long 1542 ret = 0 1543 1544 If aAnalysis.MacroNumExternalRefs <= 0 Then GoTo FinalExit 1545 1546 'Fetch External Ref Cost Factors 1547 baseIssueKey = getAppSpecificApplicationName & "_" & CSTR_ISSUE_PORTABILITY & "_" & _ 1548 CSTR_SUBISSUE_EXTERNAL_REFERENCES_IN_MACRO 1549 ret = ret + aAnalysis.MacroNumExternalRefs * _ 1550 getValueFromXLSorDict(logWb, aAnalysis, mIssuesCostDict, _ 1551 baseIssueKey & CMACRO_NUM_EXTERNAL_REFS_FACTOR_KEY, baseIssueKey, _ 1552 CMACRO_ROW_OFFSET_NUM_EXTERNAL_REFS_COST, CCOST_COL_OFFSET) 1553 1554FinalExit: 1555 getMacroExtRefIssueCost = ret 1556 Exit Function 1557 1558HandleErrors: 1559 ret = 0 1560 WriteDebug currentFunctionName & " : path " & aAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1561 Resume FinalExit 1562End Function 1563Function getIssueValueFromXLSorDict(logWb As WorkBook, aAnalysis As DocumentAnalysis, dict As Scripting.Dictionary, _ 1564 key As String, row As Long, column As Long) As Long 1565 'Error handling not required 1566 getIssueValueFromXLSorDict = getValueFromXLSorDict(logWb, aAnalysis, dict, key, key, row, column) 1567End Function 1568 1569Function getValueFromXLSorDict(logWb As WorkBook, aAnalysis As DocumentAnalysis, dict As Scripting.Dictionary, _ 1570 dictKey As String, xlsKey As String, row As Long, column As Long) As Long 1571 On Error GoTo HandleErrors 1572 Dim currentFunctionName As String 1573 currentFunctionName = "getValueFromXLSorDict" 1574 1575 Dim ret As Long 1576 ret = 0 1577 1578 If dict.Exists(dictKey) Then 1579 ret = dict.item(dictKey) 1580 Else 1581 On Error Resume Next 1582 ret = logWb.Names(xlsKey).RefersToRange.Cells(row, column).value 1583 'Log as error missing key 1584 If Err.Number <> 0 Then 1585 WriteDebug currentFunctionName & _ 1586 " : Issue Cost Key - " & xlsKey & ": label missing from results.xlt Costs sheet, check sheet and add/ check spelling label" & Err.Number & " " & Err.Description & " " & Err.Source 1587 WriteDebug currentFunctionName & " : dictKey " & dictKey & " : xlsKey " & xlsKey & " : " & Err.Number & " " & Err.Description & " " & Err.Source 1588 ret = 0 1589 End If 1590 On Error GoTo HandleErrors 1591 dict.Add dictKey, ret 1592 End If 1593 1594FinalExit: 1595 getValueFromXLSorDict = ret 1596 Exit Function 1597 1598HandleErrors: 1599 ret = 0 1600 WriteDebug currentFunctionName & " : path " & aAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1601 Resume FinalExit 1602End Function 1603Function isMacroIssue(myIssue As IssueInfo) 1604 'Error handling not required 1605 isMacroIssue = False 1606 1607 If myIssue.IssueTypeXML = CSTR_ISSUE_VBA_MACROS Or _ 1608 (myIssue.IssueTypeXML = CSTR_ISSUE_PORTABILITY And _ 1609 myIssue.SubTypeXML = CSTR_SUBISSUE_EXTERNAL_REFERENCES_IN_MACRO) Then 1610 isMacroIssue = True 1611 End If 1612End Function 1613Sub CountDocIssuesForDoc(issueClass As EnumDocOverallIssueClass, aAnalysis As DocumentAnalysis) 1614 'Error handling not required 1615 1616 If issueClass = enMinor Then 1617 aAnalysis.MinorIssuesCount = aAnalysis.MinorIssuesCount + 1 1618 End If 1619 ' Macro issues are counted during analysis 1620 ' Complex issues is calculated from: mIssues.count - mMinorIssuesCount - mMacroIssuesCount 1621End Sub 1622Sub SetOverallDocIssueClassification(issueClass As EnumDocOverallIssueClass, aAnalysis As DocumentAnalysis) 1623 'Error handling not required 1624 1625 If aAnalysis.DocOverallIssueClass = enComplex Then Exit Sub 1626 1627 If issueClass = enComplex Then 1628 aAnalysis.DocOverallIssueClass = enComplex 1629 Else 1630 aAnalysis.DocOverallIssueClass = enMinor 1631 End If 1632End Sub 1633Function getDocIssueClassification(logWb As WorkBook, myIssue As IssueInfo) As EnumDocOverallIssueClass 1634 On Error GoTo HandleErrors 1635 Dim currentFunctionName As String 1636 currentFunctionName = "getDocIssueClassification" 1637 Dim issueKey As String 1638 Dim bRet As Boolean 1639 bRet = False 1640 getDocIssueClassification = enMinor 1641 1642 issueKey = getAppSpecificApplicationName & "_" & myIssue.IssueTypeXML & "_" & myIssue.SubTypeXML 1643 If mIssuesClassificationDict.Exists(issueKey) Then 1644 bRet = mIssuesClassificationDict.item(issueKey) 1645 Else 1646 On Error Resume Next 1647 bRet = logWb.Names(issueKey).RefersToRange.Cells(1, 0).value 1648 'Log as error missing key 1649 If Err.Number <> 0 Then 1650 WriteDebug currentFunctionName & _ 1651 " : Issue Cost Key - " & issueKey & ": label missing from results.xlt Costs sheet, check sheet and add/ check spelling label" & Err.Number & " " & Err.Description & " " & Err.Source 1652 bRet = False 1653 End If 1654 On Error GoTo HandleErrors 1655 mIssuesClassificationDict.Add issueKey, bRet 1656 End If 1657 1658 1659FinalExit: 1660 If bRet Then 1661 getDocIssueClassification = enComplex 1662 End If 1663 Exit Function 1664 1665HandleErrors: 1666 bRet = False 1667 WriteDebug currentFunctionName & " : issueKey " & issueKey & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1668 Resume FinalExit 1669End Function 1670 1671Function getDocOverallIssueClassificationAsString(docIssueClass As EnumDocOverallIssueClass) As String 1672 Dim Str As String 1673 'Error handling not required 1674 1675 Select Case docIssueClass 1676 Case enComplex 1677 Str = RID_STR_COMMON_ISSUE_CLASS_COMPLEX 1678 Case enMinor 1679 Str = RID_STR_COMMON_ISSUE_CLASS_MINOR 1680 Case Else 1681 Str = RID_STR_COMMON_ISSUE_CLASS_NONE 1682 End Select 1683 1684 getDocOverallIssueClassificationAsString = Str 1685End Function 1686 1687Public Function getDocOverallMacroClassAsString(docMacroClass As EnumDocOverallMacroClass) As String 1688 Dim Str As String 1689 'Error handling not required 1690 1691 Select Case docMacroClass 1692 Case enMacroComplex 1693 Str = RID_STR_COMMON_MACRO_CLASS_COMPLEX 1694 Case enMacroMedium 1695 Str = RID_STR_COMMON_MACRO_CLASS_MEDIUM 1696 Case enMacroSimple 1697 Str = RID_STR_COMMON_MACRO_CLASS_SIMPLE 1698 Case Else 1699 Str = RID_STR_COMMON_MACRO_CLASS_NONE 1700 End Select 1701 1702 getDocOverallMacroClassAsString = Str 1703End Function 1704 1705Function WriteDocRefDetails(wsRefDetails As Worksheet, DetailsRow As Long, _ 1706 aAnalysis As DocumentAnalysis, fileName As String) As Long 1707 On Error GoTo HandleErrors 1708 Dim currentFunctionName As String 1709 currentFunctionName = "WriteDocRefDetails" 1710 1711 Dim myIssue As IssueInfo 1712 Dim rowIndex As Long 1713 rowIndex = DetailsRow 1714 1715 Dim index As Integer 1716 1717 'Output References for Docs with Macros 1718 If aAnalysis.HasMacros And (aAnalysis.References.count > 0) Then 1719 For index = 1 To aAnalysis.References.count 1720 Set myIssue = aAnalysis.References(index) 1721 OutputReferenceAttributes wsRefDetails, rowIndex, aAnalysis, myIssue, fileName 1722 rowIndex = rowIndex + 1 1723 Set myIssue = Nothing 1724 Next index 1725 End If 1726 1727 WriteDocRefDetails = rowIndex 1728 1729FinalExit: 1730 Exit Function 1731 1732HandleErrors: 1733 WriteDebug currentFunctionName & _ 1734 " : path " & aAnalysis.name & ": " & _ 1735 " : row " & DetailsRow & ": " & _ 1736 Err.Number & " " & Err.Description & " " & Err.Source 1737 Resume FinalExit 1738End Function 1739Sub OutputReferenceAttributes(wsIssueDetails As Worksheet, rowIndex As Long, _ 1740 aAnalysis As DocumentAnalysis, myIssue As IssueInfo, fileName As String) 1741 On Error GoTo HandleErrors 1742 Dim currentFunctionName As String 1743 currentFunctionName = "OutputReferenceAttributes" 1744 1745 Dim strAttributes As String 1746 1747 With myIssue 1748 SetWorksheetCellValueToString wsIssueDetails, rowIndex, CREF_DETDOCNAME, fileName 1749 SetWorksheetCellValueToString wsIssueDetails, rowIndex, CREF_DETDOCAPPLICATION, aAnalysis.Application 1750 1751 strAttributes = .Values(RID_STR_COMMON_ATTRIBUTE_MAJOR) & "." & .Values(RID_STR_COMMON_ATTRIBUTE_MINOR) 1752 strAttributes = IIf(strAttributes = "0.0" Or strAttributes = ".", .Values(RID_STR_COMMON_ATTRIBUTE_NAME), _ 1753 .Values(RID_STR_COMMON_ATTRIBUTE_NAME) & " " & .Values(RID_STR_COMMON_ATTRIBUTE_MAJOR) & _ 1754 "." & .Values(RID_STR_COMMON_ATTRIBUTE_MINOR)) 1755 SetWorksheetCellValueToString wsIssueDetails, rowIndex, CREF_DETREFERENCE, strAttributes 1756 1757 If .Values(RID_STR_COMMON_ATTRIBUTE_TYPE) = RID_STR_COMMON_ATTRIBUTE_PROJECT Then 1758 SetWorksheetCellValueToString wsIssueDetails, rowIndex, CREF_DETDESCRIPTION, RID_STR_COMMON_ATTRIBUTE_PROJECT 1759 Else 1760 SetWorksheetCellValueToString wsIssueDetails, rowIndex, CREF_DETDESCRIPTION, _ 1761 IIf(.Values(RID_STR_COMMON_ATTRIBUTE_DESCRIPTION) <> "", .Values(RID_STR_COMMON_ATTRIBUTE_DESCRIPTION), RID_STR_COMMON_NA) 1762 End If 1763 1764 1765 If .Values(RID_STR_COMMON_ATTRIBUTE_ISBROKEN) <> RID_STR_COMMON_ATTRIBUTE_BROKEN Then 1766 SetWorksheetCellValueToString wsIssueDetails, rowIndex, CREF_DETLOCATION, _ 1767 .Values(RID_STR_COMMON_ATTRIBUTE_FILE) 1768 Else 1769 SetWorksheetCellValueToString wsIssueDetails, rowIndex, CREF_DETLOCATION, _ 1770 RID_STR_COMMON_NA 1771 End If 1772 1773 'Reference Details 1774 strAttributes = RID_STR_COMMON_ATTRIBUTE_TYPE & ": " & .Values(RID_STR_COMMON_ATTRIBUTE_TYPE) & vbLf 1775 strAttributes = strAttributes & RID_STR_COMMON_ATTRIBUTE_PROPERTIES & ": " & _ 1776 .Values(RID_STR_COMMON_ATTRIBUTE_BUILTIN) & " " & .Values(RID_STR_COMMON_ATTRIBUTE_ISBROKEN) 1777 strAttributes = IIf(.Values(RID_STR_COMMON_ATTRIBUTE_GUID) <> "", _ 1778 strAttributes & vbLf & RID_STR_COMMON_ATTRIBUTE_GUID & ": " & .Values(RID_STR_COMMON_ATTRIBUTE_GUID), _ 1779 strAttributes) 1780 SetWorksheetCellValueToString wsIssueDetails, rowIndex, CREF_DETATTRIBUTES, strAttributes 1781 1782 SetWorksheetCellValueToString wsIssueDetails, rowIndex, CREF_DETNAMEANDPATH, aAnalysis.name 1783 End With 1784FinalExit: 1785 Exit Sub 1786 1787HandleErrors: 1788 WriteDebug currentFunctionName & _ 1789 " : path " & aAnalysis.name & ": " & _ 1790 " : rowIndex " & rowIndex & ": " & _ 1791 " : myIssue " & myIssue.IssueTypeXML & "_" & myIssue.SubTypeXML & ": " & _ 1792 Err.Number & " " & Err.Description & " " & Err.Source 1793 Resume FinalExit 1794End Sub 1795Sub OutputCommonIssueAttributes(wsIssueDetails As Worksheet, rowIndex As Long, _ 1796 myIssue As IssueInfo) 1797 On Error GoTo HandleErrors 1798 Dim currentFunctionName As String 1799 currentFunctionName = "OutputCommonIssueAttributes" 1800 1801 Dim index As Integer 1802 Dim strAttributes As String 1803 1804 strAttributes = "" 1805 For index = 1 To myIssue.Attributes.count 1806 strAttributes = strAttributes & myIssue.Attributes(index) & " - " & _ 1807 myIssue.Values(index) 1808 strAttributes = strAttributes & IIf(index <> myIssue.Attributes.count, vbLf, "") 1809 1810 Next index 1811 SetWorksheetCellValueToString wsIssueDetails, rowIndex, CISSUE_DETATTRIBUTES, strAttributes 1812 1813FinalExit: 1814 Exit Sub 1815 1816HandleErrors: 1817 WriteDebug currentFunctionName & _ 1818 " : rowIndex " & rowIndex & ": " & _ 1819 " : myIssue " & myIssue.IssueTypeXML & "_" & myIssue.SubTypeXML & ": " & _ 1820 Err.Number & " " & Err.Description & " " & Err.Source 1821 Resume FinalExit 1822End Sub 1823'Store issue cost and factor costs across all documents 1824Sub CollateIssueAndFactorCountsAcrossAllDocs(aAnalysis As DocumentAnalysis, myIssue As IssueInfo, fileName As String) 1825 Const CSTR_USER_FORM = "User Form" 1826 On Error GoTo HandleErrors 1827 Dim currentFunctionName As String 1828 currentFunctionName = "CollateIssueAndFactorCountsAcrossAllDocs" 1829 1830 'Don't want to cost ISSUE_INFORMATION issues 1831 If myIssue.IssueTypeXML = CSTR_ISSUE_INFORMATION Then Exit Sub 1832 1833 Dim issueKey As String 1834 issueKey = getAppSpecificApplicationName & "_" & myIssue.IssueTypeXML & "_" & myIssue.SubTypeXML 1835 1836 'Store costing metrics for Issue 1837 AddIssueAndOneToDict issueKey 1838 1839 'Store prepeared issue for costing metrics 1840 If myIssue.Preparable Then 1841 AddPreparedIssueAndOneToDict issueKey & "_Prepared" 1842 End If 1843 1844 'Additional costing Factors output for VB macros 1845 If (myIssue.IssueTypeXML = CSTR_ISSUE_VBA_MACROS) And _ 1846 (myIssue.SubTypeXML <> CSTR_SUBISSUE_MACRO_PASSWORD_PROTECTION) Then 1847 1848 'Unique Macro Module and Line count 1849 AddMacroModuleHashToMacroDict myIssue 1850 1851 'Line count 1852 AddIssueAndValToDict issueKey & "_" & CSTR_SUBISSUE_VBA_MACROS_NUMLINES, myIssue, _ 1853 RID_STR_COMMON_ATTRIBUTE_NUMBER_OF_LINES 1854 1855 'User From info 1856 If myIssue.SubLocation = CSTR_USER_FORM Then 1857 AddIssueAndOneToDict issueKey & "_" & CSTR_SUBISSUE_VBA_MACROS_USERFORMS_COUNT 1858 1859 AddIssueAndValToDict issueKey & "_" & CSTR_SUBISSUE_VBA_MACROS_USERFORMS_CONTROL_COUNT, myIssue, _ 1860 RID_STR_COMMON_ATTRIBUTE_CONTROLS 1861 End If 1862 'Additional costing Factors output for External References 1863 ElseIf (myIssue.IssueTypeXML = CSTR_ISSUE_PORTABILITY And _ 1864 myIssue.SubTypeXML = CSTR_SUBISSUE_EXTERNAL_REFERENCES_IN_MACRO) Then 1865 1866 AddIssueAndValToDict issueKey & "_" & CSTR_SUBISSUE_EXTERNAL_REFERENCES_IN_MACRO_COUNT, myIssue, _ 1867 RID_STR_COMMON_ATTRIBUTE_NON_PORTABLE_EXTERNAL_REFERENCES_COUNT 1868 End If 1869 1870FinalExit: 1871 Exit Sub 1872 1873HandleErrors: 1874 WriteDebug currentFunctionName & _ 1875 " : path " & aAnalysis.name & ": " & _ 1876 " : myIssue " & myIssue.IssueTypeXML & "_" & myIssue.SubTypeXML & ": " & _ 1877 Err.Number & " " & Err.Description & " " & Err.Source 1878 Resume FinalExit 1879End Sub 1880 1881Sub OutputCommonIssueDetails(wsIssueDetails As Worksheet, rowIndex As Long, _ 1882 aAnalysis As DocumentAnalysis, myIssue As IssueInfo, fileName As String) 1883 Const CSTR_USER_FORM = "User Form" 1884 On Error GoTo HandleErrors 1885 Dim currentFunctionName As String 1886 currentFunctionName = "OutputCommonIssueDetails" 1887 1888 SetWorksheetCellValueToString wsIssueDetails, rowIndex, CISSUE_DETDOCNAME, fileName 1889 SetWorksheetCellValueToString wsIssueDetails, rowIndex, CISSUE_DETDOCAPPLICATION, aAnalysis.Application 1890 SetWorksheetCellValueToString wsIssueDetails, rowIndex, CISSUE_DETTYPE, myIssue.IssueType 1891 SetWorksheetCellValueToString wsIssueDetails, rowIndex, CISSUE_DETSUBTYPE, myIssue.SubType 1892 SetWorksheetCellValueToString wsIssueDetails, rowIndex, CISSUE_DETLOCATION, myIssue.Location 1893 SetWorksheetCellValueToString wsIssueDetails, rowIndex, CISSUE_DETSUBLOCATION, _ 1894 IIf(myIssue.SubLocation = "", RID_STR_COMMON_NA, myIssue.SubLocation) 1895 SetWorksheetCellValueToVariant wsIssueDetails, rowIndex, CISSUE_DETLINE, _ 1896 IIf(myIssue.Line = -1, RID_STR_COMMON_NA, myIssue.Line) 1897 SetWorksheetCellValueToString wsIssueDetails, rowIndex, CISSUE_DETCOLUMN, _ 1898 IIf(myIssue.column = "", RID_STR_COMMON_NA, myIssue.column) 1899 SetWorksheetCellValueToString wsIssueDetails, rowIndex, CISSUE_DETNAMEANDPATH, aAnalysis.name 1900 1901 1902FinalExit: 1903 Exit Sub 1904 1905HandleErrors: 1906 WriteDebug currentFunctionName & _ 1907 " : path " & aAnalysis.name & ": " & _ 1908 " : rowIndex " & rowIndex & ": " & _ 1909 " : myIssue " & myIssue.IssueTypeXML & "_" & myIssue.SubTypeXML & ": " & _ 1910 Err.Number & " " & Err.Description & " " & Err.Source 1911 Resume FinalExit 1912End Sub 1913 1914Sub AddIssueAndBoolValToDict(issueKey As String, issue As IssueInfo, valKey As String) 1915 On Error GoTo HandleErrors 1916 Dim currentFunctionName As String 1917 currentFunctionName = "AddIssueAndBoolValToDict" 1918 1919 If mIssuesDict.Exists(issueKey) Then 1920 mIssuesDict.item(issueKey) = mIssuesDict.item(issueKey) + _ 1921 IIf(issue.Values(valKey) > 0, 1, 0) 1922 Else 1923 mIssuesDict.Add issueKey, IIf(issue.Values(valKey) > 0, 1, 0) 1924 End If 1925FinalExit: 1926 Exit Sub 1927 1928HandleErrors: 1929 WriteDebug currentFunctionName & _ 1930 " : issueKey " & issueKey & ": " & _ 1931 " : valKey " & valKey & ": " & _ 1932 Err.Number & " " & Err.Description & " " & Err.Source 1933 Resume FinalExit 1934End Sub 1935Sub AddIssueAndValToDict(issueKey As String, issue As IssueInfo, valKey As String) 1936 On Error GoTo HandleErrors 1937 Dim currentFunctionName As String 1938 currentFunctionName = "AddIssueAndValToDict" 1939 1940 If mIssuesDict.Exists(issueKey) Then 1941 mIssuesDict.item(issueKey) = mIssuesDict.item(issueKey) + issue.Values(valKey) 1942 Else 1943 mIssuesDict.Add issueKey, issue.Values(valKey) 1944 End If 1945FinalExit: 1946 Exit Sub 1947 1948HandleErrors: 1949 WriteDebug currentFunctionName & _ 1950 " : issueKey " & issueKey & ": " & _ 1951 " : valKey " & valKey & ": " & _ 1952 Err.Number & " " & Err.Description & " " & Err.Source 1953 Resume FinalExit 1954End Sub 1955 1956Sub AddMacroModuleHashToMacroDict(issue As IssueInfo) 1957 On Error GoTo HandleErrors 1958 Dim currentFunctionName As String 1959 Dim issueKey As String 1960 Dim issueVal As String 1961 currentFunctionName = "AddMacroModuleHashToMacroDict" 1962 1963 issueKey = issue.Values(RID_STR_COMMON_ATTRIBUTE_SIGNATURE) 1964 If issueKey = RID_STR_COMMON_NA Then Exit Sub 1965 1966 If Not mMacroDict.Exists(issueKey) Then 1967 mMacroDict.Add issueKey, issue.Values(RID_STR_COMMON_ATTRIBUTE_NUMBER_OF_LINES) 1968 End If 1969FinalExit: 1970 Exit Sub 1971 1972HandleErrors: 1973 WriteDebug currentFunctionName & _ 1974 " : issueKey " & issueKey & ": " & _ 1975 Err.Number & " " & Err.Description & " " & Err.Source 1976 Resume FinalExit 1977End Sub 1978 1979Sub AddIssueAndOneToDict(key As String) 1980 On Error GoTo HandleErrors 1981 Dim currentFunctionName As String 1982 currentFunctionName = "AddIssueAndOneToDict" 1983 1984 If mIssuesDict.Exists(key) Then 1985 mIssuesDict.item(key) = mIssuesDict.item(key) + 1 1986 Else 1987 mIssuesDict.Add key, 1 1988 End If 1989FinalExit: 1990 Exit Sub 1991 1992HandleErrors: 1993 WriteDebug currentFunctionName & " : key " & key & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1994 Resume FinalExit 1995End Sub 1996 1997Sub AddPreparedIssueAndOneToDict(key As String) 1998 On Error GoTo HandleErrors 1999 Dim currentFunctionName As String 2000 currentFunctionName = "AddPreparedIssueAndOneToDict" 2001 2002 If mPreparedIssuesDict.Exists(key) Then 2003 mPreparedIssuesDict.item(key) = mPreparedIssuesDict.item(key) + 1 2004 Else 2005 mPreparedIssuesDict.Add key, 1 2006 End If 2007FinalExit: 2008 Exit Sub 2009 2010HandleErrors: 2011 WriteDebug currentFunctionName & " : key " & key & ": " & Err.Number & " " & Err.Description & " " & Err.Source 2012 Resume FinalExit 2013End Sub 2014 2015Function GetExcelInstance() As Excel.Application 2016 On Error GoTo HandleErrors 2017 Dim currentFunctionName As String 2018 currentFunctionName = "GetExcelInstance" 2019 2020 Dim xl As Excel.Application 2021 On Error Resume Next 2022 'Try and get an existing instance 2023 Set xl = GetObject(, "Excel.Application") 2024 If Err.Number = 429 Then 2025 Set xl = CreateObject("Excel.Application") 2026 ElseIf Err.Number <> 0 Then 2027 Set xl = Nothing 2028 MsgBox "Error: " & Err.Description 2029 Exit Function 2030 End If 2031 Set GetExcelInstance = xl 2032 Set xl = Nothing 2033FinalExit: 2034 Exit Function 2035 2036HandleErrors: 2037 WriteDebug currentFunctionName & ": " & Err.Number & " " & Err.Description & " " & Err.Source 2038 Resume FinalExit 2039End Function 2040 2041Sub WriteOverview(logWb As WorkBook, DocCount As DocumentCount, templateCount As DocumentCount, _ 2042 macroClasses As DocMacroClassifications, issueClasses As DocIssueClassifications) 2043 Const COV_ISSUECLASS_COMPLEX = "MAW_ISSUECLASS_COMPLEX" 2044 Const COV_ISSUECLASS_MINOR = "MAW_ISSUECLASS_MINOR" 2045 Const COV_ISSUECLASS_NONE = "MAW_ISSUECLASS_NONE" 2046 2047 Const COV_MACROCLASS_COMPLEX = "MAW_MACROCLASS_COMPLEX" 2048 Const COV_MACROCLASS_MEDIUM = "MAW_MACROCLASS_MEDIUM" 2049 Const COV_MACROCLASS_SIMPLE = "MAW_MACROCLASS_SIMPLE" 2050 Const COV_MACROCLASS_NONE = "MAW_MACROCLASS_NONE" 2051 2052 Const COV_ISSUECOUNT_COMPLEX = "MAW_ISSUECOUNT_COMPLEX" 2053 Const COV_ISSUECOUNT_MINOR = "MAW_ISSUECOUNT_MINOR" 2054 2055 Const COV_MODDATES_LESS3MONTHS = "MAW_MODDATES_LESS3MONTHS" 2056 Const COV_MODDATES_3TO6MONTHS = "MAW_MODDATES_3TO6MONTHS" 2057 Const COV_MODDATES_6TO12MONTHS = "MAW_MODDATES_6TO12MONTHS" 2058 Const COV_MODDATES_MORE12MONTHS = "MAW_MODDATES_MORE12MONTHS" 2059 2060 Const COV_DOC_MIGRATION_COSTS = "Document_Migration_Costs" 2061 Const COV_DOC_PREPARABLE_COSTS = "Document_Migration_Preparable_Costs" 2062 Const COV_MACRO_MIGRATION_COSTS = "Macro_Migration_Costs" 2063 2064 On Error GoTo HandleErrors 2065 Dim currentFunctionName As String 2066 currentFunctionName = "WriteOverview" 2067 2068 Dim appName As String 2069 appName = getAppSpecificApplicationName 2070 2071 'OV - Title 2072 SetWorkbookNameValueToString logWb, COVERVIEW_TITLE_LABEL, GetTitle 2073 SetWorkbookNameValueToVariant logWb, "AnalysisDate", Now 2074 SetWorkbookNameValueToString logWb, "AnalysisVersion", _ 2075 RID_STR_COMMON_OV_VERSION_STR & ": " & GetTitle & " " & GetVersion 2076 2077 'OV - Number of Documents Analyzed 2078 AddLongToWorkbookNameValue logWb, CNUMBERDOC_ALL & getAppSpecificDocExt, DocCount.numDocsAnalyzed 2079 AddLongToWorkbookNameValue logWb, CNUMBERDOC_ALL & getAppSpecificTemplateExt, templateCount.numDocsAnalyzed 2080 2081 'OV - Documents with Document Migration Issues (excludes macro issues) 2082 AddLongToWorkbookNameValue logWb, appName & "_" & COV_ISSUECLASS_COMPLEX, issueClasses.complex 2083 AddLongToWorkbookNameValue logWb, appName & "_" & COV_ISSUECLASS_MINOR, issueClasses.Minor 2084 AddLongToWorkbookNameValue logWb, appName & "_" & COV_ISSUECLASS_NONE, issueClasses.None 2085 2086 'OV - Documents with Macro Migration Issues 2087 AddLongToWorkbookNameValue logWb, appName & "_" & COV_MACROCLASS_COMPLEX, macroClasses.complex 2088 AddLongToWorkbookNameValue logWb, appName & "_" & COV_MACROCLASS_MEDIUM, macroClasses.Medium 2089 AddLongToWorkbookNameValue logWb, appName & "_" & COV_MACROCLASS_SIMPLE, macroClasses.Simple 2090 AddLongToWorkbookNameValue logWb, appName & "_" & COV_MACROCLASS_NONE, macroClasses.None 2091 2092 'OV - Document Modification Dates 2093 Dim modDates As DocModificationDates 2094 Call GetDocModificationDates(modDates) 2095 2096 SetWorkbookNameValueToLong logWb, COV_MODDATES_LESS3MONTHS, modDates.lessThanThreemonths 2097 SetWorkbookNameValueToLong logWb, COV_MODDATES_3TO6MONTHS, modDates.threeToSixmonths 2098 SetWorkbookNameValueToLong logWb, COV_MODDATES_6TO12MONTHS, modDates.sixToTwelvemonths 2099 SetWorkbookNameValueToLong logWb, COV_MODDATES_MORE12MONTHS, modDates.greaterThanOneYear 2100 2101 2102 If InDocPreparation Then 2103 'OV - Document Migration Issues(excludes macro issues) 2104 AddLongToWorkbookNameValue logWb, appName & "_" & COV_ISSUECOUNT_COMPLEX, _ 2105 DocCount.numComplexIssues + templateCount.numComplexIssues 2106 AddLongToWorkbookNameValue logWb, appName & "_" & COV_ISSUECOUNT_MINOR, _ 2107 DocCount.numMinorIssues + templateCount.numMinorIssues 2108 2109 'OV - Document Migration Costs 2110 AddLongToWorkbookNameValue logWb, appName & "_" & COV_DOC_MIGRATION_COSTS, _ 2111 DocCount.totalDocIssuesCosts + templateCount.totalDocIssuesCosts 2112 2113 'OV - Document Migration Preparable Costs 2114 AddLongToWorkbookNameValue logWb, COV_DOC_PREPARABLE_COSTS, _ 2115 DocCount.totalPreparableIssuesCosts + templateCount.totalPreparableIssuesCosts 2116 2117 'OV - Macro Migration Costs 2118 AddLongToWorkbookNameValue logWb, appName & "_" & COV_MACRO_MIGRATION_COSTS, _ 2119 DocCount.totalMacroCosts + templateCount.totalMacroCosts 2120 End If 2121 2122 'OV - Internal Attributes 2123 AddLongToWorkbookNameValue logWb, appName & "_" & "TotalDocsAnalysedWithIssues", _ 2124 DocCount.numDocsAnalyzedWithIssues + templateCount.numDocsAnalyzedWithIssues 2125 2126FinalExit: 2127 Exit Sub 2128 2129HandleErrors: 2130 WriteDebug currentFunctionName & " : Problem writing overview: " & Err.Number & " " & Err.Description & " " & Err.Source 2131 Resume FinalExit 2132End Sub 2133 2134Sub SetupDAWResultsSpreadsheet(logWb As WorkBook, fontName As String, fontSize As Long) 2135 On Error GoTo HandleErrors 2136 Dim currentFunctionName As String 2137 currentFunctionName = "SetupDAWResultsSpreadsheet" 2138 Dim bSetupRun As Boolean 2139 bSetupRun = CBool(GetWorkbookNameValueAsLong(logWb, COV_DAW_SETUP_SHEETS_RUN_LBL)) 2140 2141 If bSetupRun Then Exit Sub 2142 2143 'Setup Text Boxes 2144 SetupSheetTextBox logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_MOD_DATES_COMMENT_TXB, _ 2145 RID_STR_COMMON_OV_DOC_MOD_DATES_COMMENT_TITLE, RID_STR_COMMON_OV_DOC_MOD_DATES_COMMENT_BODY, _ 2146 CCOMMENTS_FONT_SIZE, fontName 2147 SetupSheetTextBox logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_MOD_DATES_LEGEND_TXB, _ 2148 RID_STR_COMMON_OV_LEGEND_TITLE, RID_STR_COMMON_OV_DOC_MOD_DATES_LEGEND_BODY, fontSize, fontName 2149 SetupSheetTextBox logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_MACRO_COMMENT_TXB, _ 2150 RID_STR_COMMON_OV_DOC_MACRO_COMMENT_TITLE, RID_STR_COMMON_OV_DOC_MACRO_COMMENT_BODY, _ 2151 CCOMMENTS_FONT_SIZE, fontName 2152 SetupSheetTextBox logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_MACRO_LEGEND_TXB, _ 2153 RID_STR_COMMON_OV_LEGEND_TITLE, RID_STR_COMMON_OV_DOC_MACRO_LEGEND_BODY, fontSize, fontName 2154 Dim monthLimit As Long 2155 monthLimit = GetIssuesLimitInDays / CNUMDAYS_IN_MONTH 2156 SetWorkbookNameValueToString logWb, COV_HIGH_LEVEL_ANALYSIS_LBL, _ 2157 IIf(monthLimit <> CMAX_LIMIT, _ 2158 ReplaceTopicTokens(RID_STR_COMMON_OV_HIGH_LEVEL_ANALYSIS_DAW, CR_TOPIC, CStr(monthLimit)), _ 2159 RID_STR_COMMON_OV_HIGH_LEVEL_ANALYSIS_PAW_NO_LIMIT) 2160 2161 SetupSheetTextBox logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_ANALYSIS_COMMENT_TXB, _ 2162 RID_STR_COMMON_OV_DOC_ANALYSIS_COMMENT_TITLE, RID_STR_COMMON_OV_DOC_ANALYSIS_COMMENT_BODY, _ 2163 CCOMMENTS_FONT_SIZE, fontName 2164 SetupSheetTextBox logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_ANALYSIS_LEGEND_DAW_TXB, _ 2165 RID_STR_COMMON_OV_LEGEND_TITLE, RID_STR_COMMON_OV_DOC_ANALYSIS_DAW_LEGEND_BODY, fontSize, fontName 2166 2167 'Setup Chart Titles 2168 SetupSheetChartTitles logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_MOD_DATES_CHART, _ 2169 RID_STR_COMMON_OV_DOC_MOD_DATES_CHART_TITLE 2170 SetupSheetChartTitles logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_MACRO_CHART, _ 2171 RID_STR_COMMON_OV_DOC_MACRO_CHART_TITLE 2172 SetupSheetChartTitles logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_ANALYSIS_CHART, _ 2173 RID_STR_COMMON_OV_DOC_ANALYSIS_CHART_TITLE 2174 2175 'Set selection to top cell of Overview 2176 logWb.Sheets(RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW).Range("A1").Select 2177 2178 bSetupRun = True 2179 SetWorkbookNameValueToBoolean logWb, COV_DAW_SETUP_SHEETS_RUN_LBL, bSetupRun 2180FinalExit: 2181 Exit Sub 2182 2183HandleErrors: 2184 WriteDebug currentFunctionName & " : Problem setting up spreadsheet for DAW: " & Err.Number & " " & Err.Description & " " & Err.Source 2185 Resume FinalExit 2186End Sub 2187 2188Sub SetupPAWResultsSpreadsheet(logWb As WorkBook, fontName As String, fontSize As Long) 2189 On Error GoTo HandleErrors 2190 Dim currentFunctionName As String 2191 currentFunctionName = "SetupPAWResultsSpreadsheet" 2192 Dim bSetupRun As Boolean 2193 bSetupRun = CBool(GetWorkbookNameValueAsLong(logWb, COV_PAW_SETUP_SHEETS_RUN_LBL)) 2194 2195 If bSetupRun Then Exit Sub 2196 2197 'Costs 2198 logWb.Names(COV_COSTS_PREPISSUE_COUNT_COL_LBL).RefersToRange.EntireColumn.Hidden = False 2199 2200 'Setup Text Boxes 2201 SetupSheetTextBox logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_MOD_DATES_LEGEND_TXB, _ 2202 RID_STR_COMMON_OV_LEGEND_TITLE, RID_STR_COMMON_OV_DOC_MOD_DATES_LEGEND_BODY, fontSize, fontName 2203 SetupSheetTextBox logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_MACRO_LEGEND_TXB, _ 2204 RID_STR_COMMON_OV_LEGEND_TITLE, RID_STR_COMMON_OV_DOC_MACRO_LEGEND_BODY, fontSize, fontName 2205 SetWorkbookNameValueToString logWb, COV_HIGH_LEVEL_ANALYSIS_LBL, _ 2206 RID_STR_COMMON_OV_HIGH_LEVEL_ANALYSIS_PAW_NO_LIMIT 2207 SetupSheetTextBox logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_ANALYSIS_LEGEND_PAW_TXB, _ 2208 RID_STR_COMMON_OV_LEGEND_TITLE, RID_STR_COMMON_OV_DOC_ANALYSIS_PAW_LEGEND_BODY, fontSize, fontName 2209 2210 'Setup Chart Titles 2211 SetupSheetChartTitles logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_MOD_DATES_CHART, _ 2212 RID_STR_COMMON_OV_DOC_MOD_DATES_CHART_TITLE 2213 SetupSheetChartTitles logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_MACRO_CHART, _ 2214 RID_STR_COMMON_OV_DOC_MACRO_CHART_TITLE 2215 SetupSheetChartTitles logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_ANALYSIS_CHART, _ 2216 RID_STR_COMMON_OV_DOC_ANALYSIS_CHART_TITLE 2217 2218 'Set selection to top cell of Overview 2219 logWb.Sheets(RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW).Range("A1").Select 2220 2221 bSetupRun = True 2222 SetWorkbookNameValueToBoolean logWb, COV_PAW_SETUP_SHEETS_RUN_LBL, bSetupRun 2223 2224FinalExit: 2225 Exit Sub 2226 2227HandleErrors: 2228 WriteDebug currentFunctionName & " : Problem setting up spreadsheet for PAW: " & Err.Number & " " & Err.Description & " " & Err.Source 2229 Resume FinalExit 2230End Sub 2231 2232Sub SetupPrintRanges(logWb As WorkBook, docPropRow As Long, appIssuesRow As Long, issueDetailsRow As Long, _ 2233 refDetailsRow As Long) 2234 On Error GoTo HandleErrors 2235 Dim currentFunctionName As String 2236 currentFunctionName = "SetupPrintRanges" 2237 2238 'Set Print Ranges 2239 If InDocPreparation Then 2240 2241 logWb.Worksheets(RID_STR_COMMON_RESULTS_SHEET_NAME_DOCPROP).PageSetup.PrintArea = "$A1:$U" & (docPropRow + mDocPropRowOffset) 2242 logWb.Worksheets(RID_STR_COMMON_RESULTS_SHEET_NAME_DOCISSUE_DETAILS).PageSetup.PrintArea = "$A1:$J" & issueDetailsRow 2243 logWb.Worksheets(RID_STR_COMMON_RESULTS_SHEET_NAME_DOCREF_DETAILS).PageSetup.PrintArea = "$A1:$G" & refDetailsRow 2244 If getAppSpecificApplicationName = CAPPNAME_WORD Then 2245 logWb.Worksheets(RID_STR_COMMON_RESULTS_SHEET_NAME_DOCISSUES_WORD).PageSetup.PrintArea = _ 2246 "$A1:$N" & appIssuesRow 2247 ElseIf getAppSpecificApplicationName = CAPPNAME_EXCEL Then 2248 logWb.Worksheets(RID_STR_COMMON_RESULTS_SHEET_NAME_DOCISSUES_EXCEL).PageSetup.PrintArea = _ 2249 "$A1:$M" & appIssuesRow 2250 Else 2251 logWb.Worksheets(RID_STR_COMMON_RESULTS_SHEET_NAME_DOCISSUES_POWERPOINT).PageSetup.PrintArea = _ 2252 "$A1:$K" & appIssuesRow 2253 End If 2254 Else 2255 logWb.Worksheets(RID_STR_COMMON_RESULTS_SHEET_NAME_DOCPROP).PageSetup.PrintArea = "$A1:$U" & (docPropRow + mDocPropRowOffset) 2256 End If 2257 2258FinalExit: 2259 Exit Sub 2260 2261HandleErrors: 2262 WriteDebug currentFunctionName & " : Problem setting print ranges: " & Err.Number & " " & Err.Description & " " & Err.Source 2263 Resume FinalExit 2264End Sub 2265 2266Sub SetupSheetChartTitles(logWb As WorkBook, namedWorksheet As String, namedChart As String, _ 2267 chartTitle As String) 2268 Const CCHART_TITLE_FONT_SIZE = 11 2269 On Error GoTo HandleErrors 2270 Dim currentFunctionName As String 2271 currentFunctionName = "SetupSheetChartTitles" 2272 2273 With logWb.Sheets(namedWorksheet).ChartObjects(namedChart).Chart 2274 .HasTitle = True 2275 .chartTitle.Characters.Text = chartTitle 2276 .chartTitle.Font.Size = CCHART_TITLE_FONT_SIZE 2277 End With 2278 2279FinalExit: 2280 Exit Sub 2281 2282HandleErrors: 2283 WriteDebug currentFunctionName & _ 2284 " namedWorkSheet: " & namedWorksheet & _ 2285 " namedChart: " & namedChart & _ 2286 " chartTitle: " & chartTitle & _ 2287 Err.Number & " " & Err.Description & " " & Err.Source 2288 Resume FinalExit 2289End Sub 2290 2291Sub SetupSheetTextBox(logWb As WorkBook, namedWorksheet As String, _ 2292 textBoxName As String, textBoxTitle As String, textBoxBody As String, _ 2293 textSize As Long, fontName As String) 2294 2295 Const CMAX_INSERTABLE_STRING_LEN = 255 2296 On Error GoTo HandleErrors 2297 Dim currentFunctionName As String 2298 currentFunctionName = "SetupSheetTextBox" 2299 2300 Dim strTextBody As String 2301 Dim allText As String 2302 strTextBody = ReplaceTopic2Tokens(textBoxBody, CR_STR, Chr(10), CR_PRODUCT, RID_STR_COMMON_OV_PRODUCT_STR) 2303 2304 'Setup Text Boxes 2305 logWb.Sheets(namedWorksheet).Activate 2306 logWb.Sheets(namedWorksheet).Shapes(textBoxName).Select 2307 2308 '*** Workaround Excel bug: 213841 XL: Passed Strings Longer Than 255 Characters Are Truncated 2309 Dim I As Long 2310 logWb.Application.Selection.Text = "" 2311 2312 logWb.Application.Selection.Characters.Text = textBoxTitle & Chr(10) 2313 2314 With logWb.Application.Selection 2315 For I = 0 To Int(Len(strTextBody) / CMAX_INSERTABLE_STRING_LEN) 2316 .Characters(.Characters.count + 1).Text = Mid(strTextBody, _ 2317 (I * CMAX_INSERTABLE_STRING_LEN) + 1, CMAX_INSERTABLE_STRING_LEN) 2318 Next 2319 End With 2320 2321 'Highlight title only 2322 With logWb.Application.Selection.Characters(start:=1, Length:=Len(textBoxTitle)).Font 2323 .name = fontName 2324 .FontStyle = "Bold" 2325 .Size = textSize 2326 End With 2327 With logWb.Application.Selection.Characters(start:=Len(textBoxTitle) + 1, _ 2328 Length:=Len(strTextBody) + 1).Font 2329 .name = fontName 2330 .FontStyle = "Regular" 2331 .Size = textSize 2332 End With 2333 2334FinalExit: 2335 Exit Sub 2336 2337HandleErrors: 2338 WriteDebug currentFunctionName & _ 2339 " namedWorkSheet: " & namedWorksheet & _ 2340 " textBoxName: " & textBoxName & _ 2341 " textBoxTitle: " & textBoxTitle & _ 2342 " textBoxBody: " & textBoxBody & _ 2343 " textSize: " & textSize & _ 2344 Err.Number & " " & Err.Description & " " & Err.Source 2345 Resume FinalExit 2346End Sub 2347Function GetWorkbookNameValueAsLong(logWb As WorkBook, name As String) As Long 2348 On Error GoTo HandleErrors 2349 Dim currentFunctionName As String 2350 currentFunctionName = "GetWorkbookNameValueAsLong" 2351 2352 GetWorkbookNameValueAsLong = logWb.Names(name).RefersToRange.Cells(1, 1).value 2353 2354FinalExit: 2355 Exit Function 2356 2357HandleErrors: 2358 GetWorkbookNameValueAsLong = 0 2359 WriteDebug currentFunctionName & " : name " & name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 2360 Resume FinalExit 2361End Function 2362 2363Function GetWorksheetCellValueAsLong(logWs As Worksheet, row As Long, col As Long) As Long 2364 On Error GoTo HandleErrors 2365 Dim currentFunctionName As String 2366 currentFunctionName = "GetWorksheetCellValueAsLong" 2367 2368 GetWorksheetCellValueAsLong = logWs.Cells(row, col).value 2369 2370FinalExit: 2371 Exit Function 2372 2373HandleErrors: 2374 WriteDebug currentFunctionName & _ 2375 " : row " & row & _ 2376 " : col " & col & _ 2377 Err.Number & " " & Err.Description & " " & Err.Source 2378 Resume FinalExit 2379End Function 2380 2381Function GetWorksheetCellValueAsString(logWs As Worksheet, row As Long, col As Long) As String 2382 On Error GoTo HandleErrors 2383 Dim currentFunctionName As String 2384 currentFunctionName = "GetWorksheetCellValueToString" 2385 2386 GetWorksheetCellValueAsString = logWs.Cells(row, col).value 2387 2388FinalExit: 2389 Exit Function 2390 2391HandleErrors: 2392 GetWorksheetCellValueAsString = "" 2393 2394 WriteDebug currentFunctionName & _ 2395 " : row " & row & _ 2396 " : col " & col & _ 2397 Err.Number & " " & Err.Description & " " & Err.Source 2398 Resume FinalExit 2399End Function 2400 2401Sub SetWorksheetCellValueToLong(logWs As Worksheet, row As Long, col As Long, val As Long) 2402 On Error GoTo HandleErrors 2403 Dim currentFunctionName As String 2404 currentFunctionName = "SetWorksheetCellValueToLong" 2405 2406 logWs.Cells(row, col) = val 2407 2408FinalExit: 2409 Exit Sub 2410 2411HandleErrors: 2412 WriteDebug currentFunctionName & _ 2413 " : row " & row & _ 2414 " : col " & col & _ 2415 " : val " & val & ": " & _ 2416 Err.Number & " " & Err.Description & " " & Err.Source 2417 Resume FinalExit 2418End Sub 2419Sub SetWorksheetCellValueToInteger(logWs As Worksheet, row As Long, col As Long, intVal As Integer) 2420 On Error GoTo HandleErrors 2421 Dim currentFunctionName As String 2422 currentFunctionName = "SetWorksheetCellValueToInteger" 2423 2424 logWs.Cells(row, col) = intVal 2425 2426FinalExit: 2427 Exit Sub 2428 2429HandleErrors: 2430 WriteDebug currentFunctionName & _ 2431 " : row " & row & _ 2432 " : col " & col & _ 2433 " : intVal " & intVal & ": " & _ 2434 Err.Number & " " & Err.Description & " " & Err.Source 2435 Resume FinalExit 2436End Sub 2437 2438Sub SetWorksheetCellValueToVariant(logWs As Worksheet, row As Long, col As Long, varVal As Variant) 2439 On Error GoTo HandleErrors 2440 Dim currentFunctionName As String 2441 currentFunctionName = "SetWorksheetCellValueToInteger" 2442 2443 logWs.Cells(row, col) = varVal 2444 2445FinalExit: 2446 Exit Sub 2447 2448HandleErrors: 2449 WriteDebug currentFunctionName & _ 2450 " : row " & row & _ 2451 " : col " & col & _ 2452 " : varVal " & varVal & ": " & _ 2453 Err.Number & " " & Err.Description & " " & Err.Source 2454 Resume FinalExit 2455End Sub 2456 2457Sub SetWorksheetCellValueToString(logWs As Worksheet, row As Long, col As Long, strVal As String) 2458 On Error GoTo HandleErrors 2459 Dim currentFunctionName As String 2460 currentFunctionName = "SetWorksheetCellValueToString" 2461 2462 logWs.Cells(row, col) = strVal 2463 2464FinalExit: 2465 Exit Sub 2466 2467HandleErrors: 2468 WriteDebug currentFunctionName & _ 2469 " : row " & row & _ 2470 " : col " & col & _ 2471 " : strVal " & strVal & ": " & _ 2472 Err.Number & " " & Err.Description & " " & Err.Source 2473 Resume FinalExit 2474End Sub 2475 2476Sub SetWorkbookNameValueToBoolean(logWb As WorkBook, name As String, bVal As Boolean) 2477 On Error GoTo HandleErrors 2478 Dim currentFunctionName As String 2479 currentFunctionName = "SetWorkbookNameValueToBoolean" 2480 2481 logWb.Names(name).RefersToRange.Cells(1, 1) = bVal 2482 2483FinalExit: 2484 Exit Sub 2485 2486HandleErrors: 2487 WriteDebug currentFunctionName & " : name " & name & " : boolean value " & bVal & ": " & Err.Number & " " & Err.Description & " " & Err.Source 2488 Resume FinalExit 2489End Sub 2490 2491Sub SetWorkbookNameValueToString(logWb As WorkBook, name As String, val As String) 2492 On Error GoTo HandleErrors 2493 Dim currentFunctionName As String 2494 currentFunctionName = "SetWorkbookNameValueToString" 2495 2496 logWb.Names(name).RefersToRange.Cells(1, 1) = val 2497 2498FinalExit: 2499 Exit Sub 2500 2501HandleErrors: 2502 WriteDebug currentFunctionName & " : name " & name & " : value " & val & ": " & Err.Number & " " & Err.Description & " " & Err.Source 2503 Resume FinalExit 2504End Sub 2505 2506Sub SetWorkbookNameValueToLong(logWb As WorkBook, name As String, val As Long) 2507 On Error GoTo HandleErrors 2508 Dim currentFunctionName As String 2509 currentFunctionName = "SetWorkbookNameValueToLong" 2510 2511 logWb.Names(name).RefersToRange.Cells(1, 1) = val 2512 2513FinalExit: 2514 Exit Sub 2515 2516HandleErrors: 2517 WriteDebug currentFunctionName & " : name " & name & " : value " & val & ": " & Err.Number & " " & Err.Description & " " & Err.Source 2518 Resume FinalExit 2519End Sub 2520 2521Sub SetWorkbookNameValueToVariant(logWb As WorkBook, name As String, val As Variant) 2522 On Error GoTo HandleErrors 2523 Dim currentFunctionName As String 2524 currentFunctionName = "SetWorkbookNameValueToVariant" 2525 2526 logWb.Names(name).RefersToRange.Cells(1, 1) = val 2527 2528FinalExit: 2529 Exit Sub 2530 2531HandleErrors: 2532 WriteDebug currentFunctionName & " : name " & name & " : value " & val & ": " & Err.Number & " " & Err.Description & " " & Err.Source 2533 Resume FinalExit 2534End Sub 2535 2536Sub AddLongToWorkbookNameValue(logWb As WorkBook, name As String, val As Long) 2537 On Error GoTo HandleErrors 2538 Dim currentFunctionName As String 2539 currentFunctionName = "AddLongToWorkbookNameValue" 2540 2541 logWb.Names(name).RefersToRange.Cells(1, 1) = logWb.Names(name).RefersToRange.Cells(1, 1).value + val 2542 2543FinalExit: 2544 Exit Sub 2545 2546HandleErrors: 2547 WriteDebug currentFunctionName & " : name " & name & " : value " & val & ": " & Err.Number & " " & Err.Description & " " & Err.Source 2548 Resume FinalExit 2549End Sub 2550Sub AddVariantToWorkbookNameValue(logWb As WorkBook, name As String, varVal As Variant) 2551 On Error GoTo HandleErrors 2552 Dim currentFunctionName As String 2553 currentFunctionName = "AddVariantToWorkbookNameValue" 2554 2555 logWb.Names(name).RefersToRange.Cells(1, 1) = logWb.Names(name).RefersToRange.Cells(1, 1).value + varVal 2556 2557FinalExit: 2558 Exit Sub 2559 2560HandleErrors: 2561 WriteDebug currentFunctionName & " : name " & name & " : value " & varVal & ": " & Err.Number & " " & Err.Description & " " & Err.Source 2562 Resume FinalExit 2563End Sub 2564 2565Sub SaveAnalysisResultsVariables(logWb As WorkBook, offsetDocIssueDetailsRow As Long, _ 2566 offsetDocRefDetailsRow As Long) 2567 On Error GoTo HandleErrors 2568 Dim currentFunctionName As String 2569 currentFunctionName = "SaveAnalysisResultsVariables" 2570 2571 'OV - Internal Attributes 2572 SetWorkbookNameValueToLong logWb, "TotalIssuesAnalysed", offsetDocIssueDetailsRow 2573 SetWorkbookNameValueToLong logWb, "TotalRefsAnalysed", offsetDocRefDetailsRow 2574FinalExit: 2575 Exit Sub 2576 2577HandleErrors: 2578 WriteDebug currentFunctionName & " : offsetDocIssueDetailsRow " & offsetDocIssueDetailsRow & _ 2579 " : offsetDocRefDetailsRow " & offsetDocRefDetailsRow & ": " & Err.Number & " " & Err.Description & " " & Err.Source 2580 Resume FinalExit 2581End Sub 2582 2583Sub SetupAnalysisResultsVariables(logWb As WorkBook, _ 2584 offsetDocPropRow As Long, offsetDocIssuesRow As Long, _ 2585 offsetDocIssueDetailsRow As Long, offsetDocRefDetailsRow As Long) 2586 On Error GoTo HandleErrors 2587 Dim currentFunctionName As String 2588 currentFunctionName = "SetupAnalysisResultsVariables" 2589 2590 offsetDocPropRow = GetWorkbookNameValueAsLong(logWb, CTOTAL_DOCS_ANALYZED) 2591 offsetDocIssueDetailsRow = GetWorkbookNameValueAsLong(logWb, "TotalIssuesAnalysed") 2592 offsetDocRefDetailsRow = GetWorkbookNameValueAsLong(logWb, "TotalRefsAnalysed") 2593 offsetDocIssuesRow = GetWorkbookNameValueAsLong(logWb, getAppSpecificApplicationName & "_" & "TotalDocsAnalysedWithIssues") 2594FinalExit: 2595 Exit Sub 2596 2597HandleErrors: 2598 WriteDebug currentFunctionName & _ 2599 " : offsetDocPropRow " & offsetDocPropRow & _ 2600 " : offsetDocIssueDetailsRow " & offsetDocIssueDetailsRow & _ 2601 " : offsetDocRefDetailsRow " & offsetDocRefDetailsRow & _ 2602 " : offsetDocIssuesRow " & offsetDocIssuesRow & _ 2603 Err.Number & " " & Err.Description & " " & Err.Source 2604 Resume FinalExit 2605End Sub 2606 2607Sub WriteToIni(key As String, value As String) 2608 On Error GoTo HandleErrors 2609 Dim currentFunctionName As String 2610 currentFunctionName = "WriteToIni" 2611 2612 If mIniFilePath = "" Then Exit Sub 2613 2614 Call WritePrivateProfileString("Analysis", key, value, mIniFilePath) 2615FinalExit: 2616 Exit Sub 2617 2618HandleErrors: 2619 WriteDebug currentFunctionName & " : key " & key & " : value " & value & ": " & Err.Number & " " & Err.Description & " " & Err.Source 2620 Resume FinalExit 2621End Sub 2622 2623Sub WriteToLog(key As String, value As String) 2624 On Error GoTo HandleErrors 2625 Dim currentFunctionName As String 2626 currentFunctionName = "WriteToLog" 2627 2628 If mLogFilePath = "" Then Exit Sub 2629 2630 Dim sSection As String 2631 sSection = getAppSpecificApplicationName 2632 2633 Call WritePrivateProfileString(sSection, key, value, mLogFilePath) 2634FinalExit: 2635 Exit Sub 2636 2637HandleErrors: 2638 WriteDebug currentFunctionName & " : key " & key & " : value " & value & ": " & Err.Number & " " & Err.Description & " " & Err.Source 2639 Resume FinalExit 2640End Sub 2641Sub WriteDebug(value As String) 2642 On Error Resume Next 'Ignore errors in our error writing routines - could get circular dependency otherwise 2643 Static ErrCount As Long 2644 2645 If mLogFilePath = "" Then Exit Sub 2646 2647 Dim sSection As String 2648 sSection = getAppSpecificApplicationName & "Debug" 2649 2650 If mDebugLevel > 0 Then 2651 Call WritePrivateProfileString(sSection, "Doc" & mDocIndex & "_debug" & ErrCount, value, mLogFilePath) 2652 ErrCount = ErrCount + 1 2653 Else 2654 Debug.Print 2655 End If 2656End Sub 2657Sub WriteDebugLevelTwo(value As String) 2658 On Error Resume Next 'Ignore errors in our error writing routines - could get circular dependency otherwise 2659 Static ErrCountTwo As Long 2660 2661 If mLogFilePath = "" Then Exit Sub 2662 2663 Dim sSection As String 2664 sSection = getAppSpecificApplicationName & "Debug" 2665 2666 If mDebugLevel > 1 Then 2667 Call WritePrivateProfileString(sSection, "Doc" & mDocIndex & "_debug" & ErrCountTwo, "Level2: " & value, mLogFilePath) 2668 ErrCountTwo = ErrCountTwo + 1 2669 Else 2670 Debug.Print 2671 End If 2672End Sub 2673 2674Public Function ProfileLoadDict(dict As Scripting.Dictionary, _ 2675 lpSectionName As String, _ 2676 inifile As String) As Long 2677 On Error GoTo HandleErrors 2678 Dim currentFunctionName As String 2679 currentFunctionName = "ProfileLoadDict" 2680 Dim success As Long 2681 Dim c As Long 2682 Dim nSize As Long 2683 Dim KeyData As String 2684 Dim lpKeyName As String 2685 Dim ret As String 2686 2687 ret = Space$(2048) 2688 nSize = Len(ret) 2689 success = GetPrivateProfileString( _ 2690 lpSectionName, vbNullString, "", ret, nSize, inifile) 2691 2692 If success Then 2693 ret = Left$(ret, success) 2694 2695 Do Until ret = "" 2696 lpKeyName = StripNulls(ret) 2697 KeyData = ProfileGetItem( _ 2698 lpSectionName, lpKeyName, "", inifile) 2699 dict.Add lpKeyName, KeyData 2700 Loop 2701 End If 2702 ProfileLoadDict = dict.count 2703FinalExit: 2704 Exit Function 2705 2706HandleErrors: 2707 WriteDebug currentFunctionName & _ 2708 " : dict.Count " & dict.count & _ 2709 " : lpSectionName " & lpSectionName & _ 2710 " : inifile " & inifile & _ 2711 Err.Number & " " & Err.Description & " " & Err.Source 2712 Resume FinalExit 2713End Function 2714Private Function StripNulls(startStrg As String) As String 2715 On Error GoTo HandleErrors 2716 Dim currentFunctionName As String 2717 currentFunctionName = "StripNulls" 2718 Dim pos As Long 2719 Dim item As String 2720 2721 pos = InStr(1, startStrg, Chr$(0)) 2722 2723 If pos Then 2724 2725 item = Mid$(startStrg, 1, pos - 1) 2726 startStrg = Mid$(startStrg, pos + 1, Len(startStrg)) 2727 StripNulls = item 2728 2729 End If 2730 2731FinalExit: 2732 Exit Function 2733 2734HandleErrors: 2735 WriteDebug currentFunctionName & " : startStrg " & startStrg & " : " & Err.Number & " " & Err.Description & " " & Err.Source 2736 Resume FinalExit 2737End Function 2738 2739Public Function ProfileGetItem(lpSectionName As String, _ 2740 lpKeyName As String, _ 2741 defaultValue As String, _ 2742 inifile As String) As String 2743 On Error GoTo HandleErrors 2744 Dim currentFunctionName As String 2745 currentFunctionName = "ProfileGetItem" 2746 2747 Dim success As Long 2748 Dim nSize As Long 2749 Dim ret As String 2750 ret = Space$(2048) 2751 nSize = Len(ret) 2752 success = GetPrivateProfileString(lpSectionName, _ 2753 lpKeyName, _ 2754 defaultValue, _ 2755 ret, _ 2756 nSize, _ 2757 inifile) 2758 If success Then 2759 ProfileGetItem = Left$(ret, success) 2760 Else 2761 ProfileGetItem = defaultValue 2762 End If 2763 2764FinalExit: 2765 Exit Function 2766 2767HandleErrors: 2768 WriteDebug currentFunctionName & _ 2769 " : lpSectionName " & lpSectionName & _ 2770 " : lpKeyName " & lpKeyName & _ 2771 " : defaultValue " & defaultValue & _ 2772 " : inifile " & inifile & _ 2773 Err.Number & " " & Err.Description & " " & Err.Source 2774 Resume FinalExit 2775End Function 2776 2777Public Function GetDefaultPassword() As String 2778 On Error GoTo HandleErrors 2779 Dim currentFunctionName As String 2780 currentFunctionName = "GetDefaultPassword" 2781 2782 Static myPassword As String 2783 2784 If myPassword = "" Then 2785 myPassword = ProfileGetItem("Analysis", CDEFAULT_PASSWORD, "", mIniFilePath) 2786 End If 2787 2788 GetDefaultPassword = myPassword 2789FinalExit: 2790 Exit Function 2791 2792HandleErrors: 2793 WriteDebug currentFunctionName & Err.Number & " " & Err.Description & " " & Err.Source 2794 Resume FinalExit 2795End Function 2796 2797Public Function GetVersion() As String 2798 On Error GoTo HandleErrors 2799 Dim currentFunctionName As String 2800 currentFunctionName = "GetVersion" 2801 2802 Static myVersion As String 2803 2804 If myVersion = "" Then 2805 myVersion = ProfileGetItem("Analysis", CVERSION, "", mIniFilePath) 2806 End If 2807 2808 GetVersion = myVersion 2809FinalExit: 2810 Exit Function 2811 2812HandleErrors: 2813 WriteDebug currentFunctionName & Err.Number & " " & Err.Description & " " & Err.Source 2814 Resume FinalExit 2815End Function 2816Public Function GetTitle() As String 2817 On Error GoTo HandleErrors 2818 Dim currentFunctionName As String 2819 currentFunctionName = "GetTitle" 2820 2821 Static myTitle As String 2822 2823 If myTitle = "" Then 2824 myTitle = ProfileGetItem("Analysis", CTITLE, RID_STR_COMMON_ANALYSIS_STR, mIniFilePath) 2825 End If 2826 2827 GetTitle = myTitle 2828FinalExit: 2829 Exit Function 2830 2831HandleErrors: 2832 WriteDebug currentFunctionName & Err.Number & " " & Err.Description & " " & Err.Source 2833 Resume FinalExit 2834End Function 2835 2836Sub SetPrepareToNone() 2837 On Error GoTo HandleErrors 2838 Dim currentFunctionName As String 2839 currentFunctionName = "SetPrepareToNone" 2840 2841 Call WritePrivateProfileString("Analysis", CDOPREPARE, CStr(0), mIniFilePath) 2842 2843FinalExit: 2844 Exit Sub 2845 2846HandleErrors: 2847 WriteDebug currentFunctionName & Err.Number & " " & Err.Description & " " & Err.Source 2848 Resume FinalExit 2849End Sub 2850 2851Function CheckForAbort() As Boolean 2852 Dim currentFunctionName As String 2853 Dim bAbort As Boolean 2854 2855 currentFunctionName = "CheckForAbort" 2856 bAbort = False 2857 2858 On Error GoTo HandleErrors 2859 2860 bAbort = CBool(ProfileGetItem("Analysis", C_ABORT_ANALYSIS, "false", mIniFilePath)) 2861 2862 'reset the flag 2863 If (bAbort) Then Call WriteToIni(C_ABORT_ANALYSIS, "false") 2864 2865FinalExit: 2866 CheckForAbort = bAbort 2867 Exit Function 2868 2869HandleErrors: 2870 WriteDebug currentFunctionName & Err.Number & " " & Err.Description & " " & Err.Source 2871 Resume FinalExit 2872End Function 2873 2874Function CheckDoPrepare() As Boolean 2875 On Error GoTo HandleErrors 2876 Dim currentFunctionName As String 2877 currentFunctionName = "CheckDoPrepare" 2878 2879 Static bDoPrepare As Boolean 2880 Static myDoPrepare As String 2881 2882 If myDoPrepare = "" Then 2883 bDoPrepare = CBool(ProfileGetItem("Analysis", _ 2884 CDOPREPARE, "False", mIniFilePath)) 2885 myDoPrepare = "OK" 2886 End If 2887 2888 CheckDoPrepare = bDoPrepare 2889FinalExit: 2890 Exit Function 2891 2892HandleErrors: 2893 WriteDebug currentFunctionName & Err.Number & " " & Err.Description & " " & Err.Source 2894 Resume FinalExit 2895End Function 2896 2897Function GetIssuesLimitInDays() As Long 2898 On Error GoTo HandleErrors 2899 Dim currentFunctionName As String 2900 2901 currentFunctionName = "GetIssuesLimitInDays" 2902 2903 Static issuesLimit As Long 2904 Static myDoPrepare As String 2905 2906 If issuesLimit = 0 Then 2907 issuesLimit = CLng(ProfileGetItem("Analysis", _ 2908 CISSUES_LIMIT, CMAX_LIMIT, mIniFilePath)) * CNUMDAYS_IN_MONTH 2909 End If 2910 2911 GetIssuesLimitInDays = issuesLimit 2912FinalExit: 2913 Exit Function 2914 2915HandleErrors: 2916 WriteDebug currentFunctionName & Err.Number & " " & Err.Description & " " & Err.Source 2917 Resume FinalExit 2918End Function 2919 2920Public Sub AddIssueDetailsNote(myIssue As IssueInfo, noteNum As Long, noteStr As String, _ 2921 Optional preStr As String) 2922 On Error GoTo HandleErrors 2923 Dim currentFunctionName As String 2924 currentFunctionName = "AddIssueDetailsNote" 2925 2926 If IsMissing(preStr) Then 2927 preStr = RID_STR_COMMON_NOTE_PRE 2928 End If 2929 myIssue.Attributes.Add preStr & "[" & noteNum & "]" 2930 myIssue.Values.Add noteStr 2931 2932FinalExit: 2933 Exit Sub 2934 2935HandleErrors: 2936 WriteDebug currentFunctionName & " : noteNum " & noteNum & " : noteStr " & noteStr & ": " & Err.Number & " " & Err.Description & " " & Err.Source 2937 Resume FinalExit 2938End Sub 2939 2940Public Sub SetupWizardVariables( _ 2941 fileList As String, storeToDir As String, resultsFile As String, _ 2942 logFile As String, resultsTemplate As String, bOverwriteFile As Boolean, _ 2943 bNewResultsFile As Boolean, statFileName As String, debugLevel As Long, _ 2944 outputType As String, singleFile As String) 2945 On Error GoTo HandleErrors 2946 Dim currentFunctionName As String 2947 currentFunctionName = "SetupWizardVariables" 2948 2949 If mIniFilePath = "" Then 2950 mIniFilePath = GetAppDataFolder & "\Sun\AnalysisWizard\" & CWIZARD & ".ini" 2951 End If 2952 2953 statFileName = ProfileGetItem("Analysis", CSTAT_FILE, "", mIniFilePath) 2954 fileList = ProfileGetItem("Analysis", CFILE_LIST, "", mIniFilePath) 2955 storeToDir = ProfileGetItem("Analysis", COUTPUT_DIR, "", mIniFilePath) 2956 resultsFile = ProfileGetItem("Analysis", CRESULTS_FILE, "", mIniFilePath) 2957 logFile = ProfileGetItem("Analysis", CLOG_FILE, "", mIniFilePath) 2958 resultsTemplate = ProfileGetItem("Analysis", CRESULTS_TEMPLATE, "", mIniFilePath) 2959 bOverwriteFile = IIf(ProfileGetItem("Analysis", CRESULTS_EXIST, COVERWRITE_FILE, mIniFilePath) = COVERWRITE_FILE, _ 2960 True, False) 2961 bNewResultsFile = CBool(ProfileGetItem("Analysis", CNEW_RESULTS_FILE, "True", mIniFilePath)) 2962 debugLevel = CLng(ProfileGetItem("Analysis", CDEBUG_LEVEL, "1", mIniFilePath)) 2963 outputType = ProfileGetItem("Analysis", COUTPUT_TYPE, COUTPUT_TYPE_XLS, mIniFilePath) 2964 singleFile = ProfileGetItem("Analysis", CSINGLE_FILE, "", mIniFilePath) 2965FinalExit: 2966 Exit Sub 2967 2968HandleErrors: 2969 WriteDebug currentFunctionName & _ 2970 ": mIniFilePath " & mIniFilePath & ": " & _ 2971 Err.Number & " " & Err.Description & " " & Err.Source 2972 Resume FinalExit 2973End Sub 2974 2975Public Sub SetupSearchTypes(searchTypes As Collection) 2976 On Error GoTo HandleErrors 2977 Dim currentFunctionName As String 2978 currentFunctionName = "SetupSearchTypes" 2979 2980 Dim bDocument As Boolean 2981 Dim bTemplate As Boolean 2982 2983 bDocument = CBool(ProfileGetItem("Analysis", LCase("type" & getAppSpecificApplicationName & "doc"), "False", mIniFilePath)) 2984 bTemplate = CBool(ProfileGetItem("Analysis", LCase("type" & getAppSpecificApplicationName & "dot"), "False", mIniFilePath)) 2985 If bDocument = True Then searchTypes.Add "*" & getAppSpecificDocExt 2986 If bTemplate = True Then searchTypes.Add "*" & getAppSpecificTemplateExt 2987FinalExit: 2988 Exit Sub 2989 2990HandleErrors: 2991 WriteDebug currentFunctionName & ": searchTypes.Count " & searchTypes.count & ": " & Err.Number & " " & Err.Description & " " & Err.Source 2992 Resume FinalExit 2993End Sub 2994 2995Sub WriteXMLHeader(out As TextStream) 2996 On Error GoTo HandleErrors 2997 Dim currentFunctionName As String 2998 currentFunctionName = "WriteXMLHeader" 2999 3000 out.WriteLine "<?xml version=""1.0"" encoding=""ISO-8859-1""?>" 3001 out.WriteLine "<!DOCTYPE results SYSTEM 'analysis.dtd'>" 3002 3003FinalExit: 3004 Exit Sub 3005 3006HandleErrors: 3007 WriteDebug currentFunctionName & ": " & Err.Number & " " & Err.Description & " " & Err.Source 3008 Resume FinalExit 3009End Sub 3010Sub WriteXMLResultsStartTag(out As TextStream) 3011 On Error GoTo HandleErrors 3012 Dim currentFunctionName As String 3013 currentFunctionName = "WriteXMLResultsStartTag" 3014 3015 out.WriteLine "<results generated-by=""" & IIf(InDocPreparation, "documentanalysis_preparation", "documentanalysis") & """" 3016 out.WriteLine " version=""" & GetVersion & """ timestamp=""" & Now & """" 3017 out.WriteLine " type=""" & getAppSpecificApplicationName & """ >" 3018 3019FinalExit: 3020 Exit Sub 3021 3022HandleErrors: 3023 WriteDebug currentFunctionName & ": " & Err.Number & " " & Err.Description & " " & Err.Source 3024 Resume FinalExit 3025End Sub 3026Sub WriteXMLResultsEndTag(out As TextStream) 3027 On Error GoTo HandleErrors 3028 Dim currentFunctionName As String 3029 currentFunctionName = "WriteXMLResultsEndTag" 3030 3031 out.WriteLine "</results>" 3032 3033FinalExit: 3034 Exit Sub 3035 3036HandleErrors: 3037 WriteDebug currentFunctionName & ": " & Err.Number & " " & Err.Description & " " & Err.Source 3038 Resume FinalExit 3039End Sub 3040 3041Sub WriteXMLDocProperties(out As TextStream, aAnalysis As DocumentAnalysis) 3042 On Error GoTo HandleErrors 3043 Dim currentFunctionName As String 3044 currentFunctionName = "WriteXMLDocProperties" 3045 3046 out.WriteLine "<document location=""" & EncodeXML(aAnalysis.name) & """" 3047 out.WriteLine " application=""" & aAnalysis.Application & """" 3048 out.WriteLine " issues-count=""" & (aAnalysis.IssuesCount) & """" 3049 out.WriteLine " pages=""" & aAnalysis.PageCount & """" 3050 out.WriteLine " created=""" & CheckDate(aAnalysis.Created) & """" 3051 out.WriteLine " modified=""" & CheckDate(aAnalysis.Modified) & """" 3052 out.WriteLine " accessed=""" & CheckDate(aAnalysis.Accessed) & """" 3053 out.WriteLine " printed=""" & CheckDate(aAnalysis.Printed) & """" 3054 out.WriteLine " last-save-by=""" & aAnalysis.SavedBy & """" 3055 out.WriteLine " revision=""" & aAnalysis.Revision & """" 3056 out.WriteLine " based-on-template=""" & EncodeXML(aAnalysis.Template) & """" 3057 out.WriteLine ">" 3058 3059FinalExit: 3060 Exit Sub 3061 3062HandleErrors: 3063 WriteDebug currentFunctionName & " : path " & aAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 3064 Resume FinalExit 3065End Sub 3066 3067Sub WriteXMLDocPropertiesEndTag(out As TextStream) 3068 On Error GoTo HandleErrors 3069 Dim currentFunctionName As String 3070 currentFunctionName = "WriteXMLDocPropertiesEndTag" 3071 3072 out.WriteLine "</document>" 3073 3074FinalExit: 3075 Exit Sub 3076 3077HandleErrors: 3078 WriteDebug currentFunctionName & ": " & Err.Number & " " & Err.Description & " " & Err.Source 3079 Resume FinalExit 3080End Sub 3081 3082Sub WriteXMLDocRefDetails(out As TextStream, aAnalysis As DocumentAnalysis) 3083 On Error GoTo HandleErrors 3084 Dim currentFunctionName As String 3085 currentFunctionName = "WriteXMLDocRefDetails" 3086 Dim myIssue As IssueInfo 3087 3088 'Output References for Docs with Macros 3089 If aAnalysis.HasMacros And (aAnalysis.References.count > 0) Then 3090 out.WriteLine "<references>" 3091 For Each myIssue In aAnalysis.References 3092 OutputXMLReferenceAttributes out, aAnalysis, myIssue 3093 Next myIssue 3094 out.WriteLine "</references>" 3095 End If 3096 3097FinalExit: 3098 Exit Sub 3099 3100HandleErrors: 3101 WriteDebug currentFunctionName & " : path " & aAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 3102 Resume FinalExit 3103End Sub 3104 3105Sub OutputXMLReferenceAttributes(out As TextStream, aAnalysis As DocumentAnalysis, myIssue As IssueInfo) 3106 On Error GoTo HandleErrors 3107 Dim currentFunctionName As String 3108 currentFunctionName = "OutputXMLReferenceAttributes" 3109 Dim strAttributes As String 3110 3111 With myIssue 3112 out.WriteLine "<reference" 3113 3114 strAttributes = .Values("Major") & "." & .Values("Minor") 3115 strAttributes = IIf(strAttributes = "0.0" Or strAttributes = ".", .Values("Name"), _ 3116 .Values("Name") & " " & .Values("Major") & "." & .Values("Minor")) 3117 out.WriteLine " name=""" & EncodeXML(strAttributes) & """" 3118 3119 If .Values("Type") = "Project" Then 3120 strAttributes = "Project reference" 3121 Else 3122 strAttributes = IIf(.Values("Description") <> "", .Values("Description"), RID_STR_COMMON_NA) 3123 End If 3124 out.WriteLine " description=""" & EncodeXML(strAttributes) & """" 3125 If .Values("IsBroken") <> RID_STR_COMMON_ATTRIBUTE_BROKEN Then 3126 out.WriteLine " location=""" & .Values("File") & """" 3127 End If 3128 out.WriteLine " type=""" & .Values("Type") & """" 3129 strAttributes = IIf(.Values("GUID") <> "", .Values("GUID"), RID_STR_COMMON_NA) 3130 out.WriteLine " GUID=""" & strAttributes & """" 3131 out.WriteLine " is-broken=""" & .Values("IsBroken") & """" 3132 out.WriteLine " builtin=""" & .Values("BuiltIn") & """" 3133 3134 out.WriteLine " />" 3135 End With 3136 3137FinalExit: 3138 Exit Sub 3139 3140HandleErrors: 3141 WriteDebug currentFunctionName & " : path " & aAnalysis.name & " : myIssue " & myIssue.IssueTypeXML & "_" & myIssue.SubTypeXML & ": " & Err.Number & " " & Err.Description & " " & Err.Source 3142 Resume FinalExit 3143End Sub 3144 3145Sub WriteXMLDocIssueDetails(out As TextStream, aAnalysis As DocumentAnalysis) 3146 On Error GoTo HandleErrors 3147 Dim currentFunctionName As String 3148 currentFunctionName = "WriteXMLDocIssueDetails" 3149 3150 Dim myIssue As IssueInfo 3151 3152 If aAnalysis.Issues.count = 0 Then Exit Sub 3153 3154 out.WriteLine "<issues>" 3155 For Each myIssue In aAnalysis.Issues 3156 OutputXMLCommonIssueDetails out, aAnalysis, myIssue 3157 OutputXMLCommonIssueAttributes out, myIssue 3158 out.WriteLine "</issue>" 3159 Next myIssue 3160 out.WriteLine "</issues>" 3161 3162FinalExit: 3163 Exit Sub 3164 3165HandleErrors: 3166 WriteDebug currentFunctionName & " : path " & aAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 3167 Resume FinalExit 3168End Sub 3169 3170Sub OutputXMLCommonIssueDetails(out As TextStream, aAnalysis As DocumentAnalysis, myIssue As IssueInfo) 3171 On Error GoTo HandleErrors 3172 Dim currentFunctionName As String 3173 currentFunctionName = "OutputXMLCommonIssueDetails" 3174 3175 out.WriteLine "<issue category=""" & myIssue.IssueTypeXML & """" 3176 out.WriteLine " type=""" & myIssue.SubTypeXML & """" 3177 3178 'NOTE: Dropping severity - now stored in results.xlt, do not want to open it to fetch this data 3179 'out.WriteLine " severity=""" & IIf(CheckForMinorIssue(aAnalysis, myIssue), "Minor", "Major") & """" 3180 out.WriteLine " prepared=""" & IIf((myIssue.Preparable), "True", "False") & """ >" 3181 3182 out.WriteLine "<location type=""" & myIssue.locationXML & """ >" 3183 3184 If myIssue.SubLocation <> "" Then 3185 out.WriteLine "<property name=""sublocation"" value=""" & myIssue.SubLocation & """ />" 3186 End If 3187 If myIssue.Line <> -1 Then 3188 out.WriteLine "<property name=""line"" value=""" & myIssue.Line & """ />" 3189 End If 3190 If myIssue.column <> "" Then 3191 out.WriteLine "<property name=""column"" value=""" & myIssue.column & """ />" 3192 End If 3193 out.WriteLine "</location>" 3194 3195FinalExit: 3196 Exit Sub 3197 3198HandleErrors: 3199 WriteDebug currentFunctionName & " : path " & aAnalysis.name & " : myIssue " & myIssue.IssueTypeXML & "_" & myIssue.SubTypeXML & ": " & Err.Number & " " & Err.Description & " " & Err.Source 3200 Resume FinalExit 3201End Sub 3202 3203Sub OutputXMLCommonIssueAttributes(out As TextStream, myIssue As IssueInfo) 3204 On Error GoTo HandleErrors 3205 Dim currentFunctionName As String 3206 currentFunctionName = "OutputXMLCommonIssueAttributes" 3207 3208 Dim index As Integer 3209 Dim valStr As String 3210 Dim attStr As String 3211 3212 If myIssue.Attributes.count = 0 Then Exit Sub 3213 3214 out.WriteLine "<details>" 3215 For index = 1 To myIssue.Attributes.count 3216 attStr = myIssue.Attributes(index) 3217 If InStr(attStr, RID_STR_COMMON_NOTE_PRE & "[") = 1 Then 3218 attStr = Right$(attStr, Len(attStr) - Len(RID_STR_COMMON_NOTE_PRE & "[")) 3219 attStr = Left$(attStr, Len(attStr) - 1) 3220 out.WriteLine "<note index=""" & attStr & """ value=""" & EncodeXML(myIssue.Values(index)) & """ />" 3221 Else 3222 out.WriteLine "<property name=""" & EncodeXML(myIssue.Attributes(index)) & """ value=""" & EncodeXML(myIssue.Values(index)) & """ />" 3223 End If 3224 Next index 3225 3226 out.WriteLine "</details>" 3227 3228FinalExit: 3229 Exit Sub 3230 3231HandleErrors: 3232 WriteDebug currentFunctionName & " : myIssue " & myIssue.IssueTypeXML & "_" & myIssue.SubTypeXML & ": " & Err.Number & " " & Err.Description & " " & Err.Source 3233 Resume FinalExit 3234End Sub 3235 3236 3237Sub WriteXMLOutput(storeToDir As String, resultsFile As String, _ 3238 bOverwriteResultsFile As Boolean, bNewResultsFile As Boolean, AnalysedDocs As Collection, _ 3239 fso As Scripting.FileSystemObject) 3240 3241 On Error GoTo HandleErrors 3242 Dim currentFunctionName As String 3243 currentFunctionName = "WriteXMLOutput" 3244 3245 Dim xmlOutput As TextStream 3246 Dim xmlOrigOutput As TextStream 3247 Dim origOutput As String 3248 Dim analysis As DocumentAnalysis 3249 Dim outFilePath As String 3250 3251 outFilePath = storeToDir & "\" & fso.GetBaseName(resultsFile) & "_" & _ 3252 getAppSpecificApplicationName & ".xml" 3253 3254 Set xmlOutput = fso.CreateTextFile(outFilePath, True) 3255 WriteXMLHeader xmlOutput 3256 3257 'Set xmlOrigOutput = fso.OpenTextFile(outFilePath, ForReading) 3258 'Set xmlOutput = fso.OpenTextFile(outFilePath, ForWriting) 3259 3260 WriteXMLResultsStartTag xmlOutput 3261 For Each analysis In AnalysedDocs 3262 WriteXMLDocProperties xmlOutput, analysis 3263 WriteXMLDocRefDetails xmlOutput, analysis 3264 WriteXMLDocIssueDetails xmlOutput, analysis 3265 WriteXMLDocPropertiesEndTag xmlOutput 3266 Next analysis 3267 WriteXMLResultsEndTag xmlOutput 3268 3269FinalExit: 3270 xmlOutput.Close 3271 Set xmlOutput = Nothing 3272 Exit Sub 3273 3274HandleErrors: 3275 WriteDebug currentFunctionName & " : path " & outFilePath & ": " & Err.Number & " " & Err.Description & " " & Err.Source 3276 Resume FinalExit 3277End Sub 3278 3279Private Function EncodeUrl(ByVal sUrl As String) As String 3280 Const MAX_PATH As Long = 260 3281 Const ERROR_SUCCESS As Long = 0 3282 Const URL_DONT_SIMPLIFY As Long = &H8000000 3283 On Error GoTo HandleErrors 3284 Dim currentFunctionName As String 3285 currentFunctionName = "EncodeUrl" 3286 3287 Dim sUrlEsc As String 3288 Dim dwSize As Long 3289 Dim dwFlags As Long 3290 3291 If Len(sUrl) > 0 Then 3292 3293 sUrlEsc = Space$(MAX_PATH) 3294 dwSize = Len(sUrlEsc) 3295 dwFlags = URL_DONT_SIMPLIFY 3296 3297 If UrlEscape(sUrl, _ 3298 sUrlEsc, _ 3299 dwSize, _ 3300 dwFlags) = ERROR_SUCCESS Then 3301 3302 EncodeUrl = Left$(sUrlEsc, dwSize) 3303 3304 End If 'If UrlEscape 3305 End If 'If Len(sUrl) > 0 3306 3307FinalExit: 3308 Exit Function 3309 3310HandleErrors: 3311 WriteDebug currentFunctionName & " : sUrl " & sUrl & ": " & Err.Number & " " & Err.Description & " " & Err.Source 3312 Resume FinalExit 3313End Function 3314 3315Private Function EncodeXML(Str As String) As String 3316 On Error GoTo HandleErrors 3317 Dim currentFunctionName As String 3318 currentFunctionName = "EncodeXML" 3319 3320 Str = Replace(Str, "^", "^") 3321 Str = Replace(Str, "&", "&") 3322 Str = Replace(Str, "`", "'") 3323 Str = Replace(Str, "{", "{") 3324 Str = Replace(Str, "}", "}") 3325 Str = Replace(Str, "|", "|") 3326 Str = Replace(Str, "]", "]") 3327 Str = Replace(Str, "[", "[") 3328 Str = Replace(Str, """", """) 3329 Str = Replace(Str, "<", "<") 3330 Str = Replace(Str, ">", ">") 3331 3332 'str = Replace(str, "\", "\") 3333 'str = Replace(str, "#", "#") 3334 'str = Replace(str, "?", "?") 3335 'str = Replace(str, "/", "/") 3336 3337 EncodeXML = Str 3338 3339FinalExit: 3340 Exit Function 3341 3342HandleErrors: 3343 WriteDebug currentFunctionName & " : string " & Str & ": " & Err.Number & " " & Err.Description & " " & Err.Source 3344 Resume FinalExit 3345End Function 3346 3347 3348Function ReplaceTopicTokens(sString As String, _ 3349 sToken As String, _ 3350 sReplacement As String) As String 3351 On Error Resume Next 3352 3353 Dim p As Integer 3354 Dim sTmp As String 3355 3356 sTmp = sString 3357 Do 3358 p = InStr(sTmp, sToken) 3359 If p Then 3360 sTmp = Left(sTmp, p - 1) + sReplacement + Mid(sTmp, p + Len(sToken)) 3361 End If 3362 Loop While p > 0 3363 3364 3365 ReplaceTopicTokens = sTmp 3366 3367End Function 3368 3369Function ReplaceTopic2Tokens(sString As String, _ 3370 sToken1 As String, _ 3371 sReplacement1 As String, _ 3372 sToken2 As String, _ 3373 sReplacement2 As String) As String 3374 On Error Resume Next 3375 3376 ReplaceTopic2Tokens = _ 3377 ReplaceTopicTokens(ReplaceTopicTokens(sString, sToken1, sReplacement1), _ 3378 sToken2, sReplacement2) 3379End Function 3380 3381'Language setting functions 3382Function GetResourceDataFileName(thisDir As String) As String 3383 On Error GoTo HandleErrors 3384 Dim currentFunctionName As String 3385 currentFunctionName = "GetResourceDataFileName" 3386 3387 Dim fso As FileSystemObject 3388 Set fso = New FileSystemObject 3389 3390 'A debug method - if a file called debug.dat exists load it. 3391 If fso.FileExists(fso.GetAbsolutePathName(thisDir & "\debug.dat")) Then 3392 GetResourceDataFileName = fso.GetAbsolutePathName(thisDir & "\debug.dat") 3393 GoTo FinalExit 3394 End If 3395 3396 Dim isoLangStr As String 3397 Dim isoCountryStr As String 3398 Dim langDir As String 3399 3400 langDir = thisDir & "\" & "lang" 3401 3402 Dim userLCID As Long 3403 userLCID = GetUserDefaultLangID() 3404 Dim sysLCID As Long 3405 sysLCID = GetSystemDefaultLangID() 3406 3407 isoLangStr = GetUserLocaleInfo(userLCID, LOCALE_SISO639LANGNAME) 3408 isoCountryStr = GetUserLocaleInfo(userLCID, LOCALE_SISO3166CTRYNAME) 3409 3410 'check for locale data in following order: 3411 ' user language 3412 ' isoLangStr & "_" & isoCountryStr & ".dat" 3413 ' isoLangStr & ".dat" 3414 ' system language 3415 ' isoLangStr & "_" & isoCountryStr & ".dat" 3416 ' isoLangStr & ".dat" 3417 ' "en_US" & ".dat" 3418 3419 If fso.FileExists(fso.GetAbsolutePathName(langDir & "\" & isoLangStr & "-" & isoCountryStr & ".dat")) Then 3420 GetResourceDataFileName = fso.GetAbsolutePathName(langDir & "\" & isoLangStr & "-" & isoCountryStr & ".dat") 3421 ElseIf fso.FileExists(fso.GetAbsolutePathName(langDir & "\" & isoLangStr & ".dat")) Then 3422 GetResourceDataFileName = fso.GetAbsolutePathName(langDir & "\" & isoLangStr & ".dat") 3423 Else 3424 isoLangStr = GetUserLocaleInfo(sysLCID, LOCALE_SISO639LANGNAME) 3425 isoCountryStr = GetUserLocaleInfo(sysLCID, LOCALE_SISO3166CTRYNAME) 3426 3427 If fso.FileExists(fso.GetAbsolutePathName(langDir & "\" & isoLangStr & "-" & isoCountryStr & ".dat")) Then 3428 GetResourceDataFileName = fso.GetAbsolutePathName(langDir & "\" & isoLangStr & "-" & isoCountryStr & ".dat") 3429 ElseIf fso.FileExists(fso.GetAbsolutePathName(langDir & "\" & isoLangStr & ".dat")) Then 3430 GetResourceDataFileName = fso.GetAbsolutePathName(langDir & "\" & isoLangStr & ".dat") 3431 Else 3432 GetResourceDataFileName = fso.GetAbsolutePathName(langDir & "\" & "en-US.dat") 3433 End If 3434 End If 3435FinalExit: 3436 Set fso = Nothing 3437 Exit Function 3438 3439HandleErrors: 3440 WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source 3441 Resume FinalExit 3442End Function 3443 3444Public Function GetUserLocaleInfo(ByVal dwLocaleID As Long, ByVal dwLCType As Long) As String 3445 On Error GoTo HandleErrors 3446 Dim currentFunctionName As String 3447 currentFunctionName = "GetUserLocaleInfo" 3448 Dim sReturn As String 3449 Dim r As Long 3450 3451 'call the function passing the Locale type 3452 'variable to retrieve the required size of 3453 'the string buffer needed 3454 r = GetLocaleInfo(dwLocaleID, dwLCType, sReturn, Len(sReturn)) 3455 3456 'if successful.. 3457 If r Then 3458 'pad the buffer with spaces 3459 sReturn = Space$(r) 3460 3461 'and call again passing the buffer 3462 r = GetLocaleInfo(dwLocaleID, dwLCType, sReturn, Len(sReturn)) 3463 3464 'if successful (r > 0) 3465 If r Then 3466 'r holds the size of the string 3467 'including the terminating null 3468 GetUserLocaleInfo = Left$(sReturn, r - 1) 3469 End If 3470 End If 3471 3472FinalExit: 3473 Exit Function 3474 3475HandleErrors: 3476 WriteDebug currentFunctionName & ": " & Err.Number & " " & Err.Description & " " & Err.Source 3477 Resume FinalExit 3478End Function 3479 3480' This function returns the Application Data Folder Path 3481Function GetAppDataFolder() As String 3482 Dim idlstr As Long 3483 Dim sPath As String 3484 Dim IDL As ITEMIDLIST 3485 Const NOERROR = 0 3486 Const MAX_LENGTH = 260 3487 Const CSIDL_APPDATA = &H1A 3488 3489 On Error GoTo Err_GetFolder 3490 3491 ' Fill the idl structure with the specified folder item. 3492 idlstr = SHGetSpecialFolderLocation(0, CSIDL_APPDATA, IDL) 3493 3494 If idlstr = NOERROR Then 3495 ' Get the path from the idl list, and return 3496 ' the folder with a slash at the end. 3497 sPath = Space$(MAX_LENGTH) 3498 idlstr = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath) 3499 If idlstr Then 3500 GetAppDataFolder = Left$(sPath, InStr(sPath, Chr$(0)) - 1) 3501 End If 3502 End If 3503 3504Exit_GetFolder: 3505 Exit Function 3506 3507Err_GetFolder: 3508 MsgBox "An Error was Encountered" & Chr(13) & Err.Description, _ 3509 vbCritical Or vbOKOnly 3510 Resume Exit_GetFolder 3511 3512End Function 3513 3514Sub WriteToStatFile(statFileName As String, statValue As Integer, _ 3515 currDocument As String, fso As Scripting.FileSystemObject) 3516 3517 On Error Resume Next 3518 3519 Dim fileCont As TextStream 3520 3521 Set fileCont = fso.OpenTextFile(statFileName, ForWriting, True, TristateTrue) 3522 If (statValue = C_STAT_STARTING) Then 3523 fileCont.WriteLine ("analysing=" & currDocument) 3524 ElseIf (statValue = C_STAT_DONE) Then 3525 fileCont.WriteLine ("analysed=" & currDocument) 3526 ElseIf (statValue = C_STAT_FINISHED) Then 3527 fileCont.WriteLine ("finished") 3528 End If 3529 3530 fileCont.Close 3531End Sub 3532 3533' The function FindIndex looks for a document in the given document list 3534' starting at the position lastIndex in that list. If the document could 3535' not be found, the function starts searching from the beginning 3536 3537Function FindIndex(myDocument As String, _ 3538 myDocList As Collection, _ 3539 lastIndex As Long) As Long 3540 3541 Dim lastEntry As Long 3542 Dim curIndex As Long 3543 Dim curEntry As String 3544 Dim entryFound As Boolean 3545 3546 entryFound = False 3547 lastEntry = myDocList.count 3548 3549 If (lastIndex > lastEntry) Then lastIndex = lastEntry 3550 3551 If (lastIndex > 1) Then 3552 curIndex = lastIndex 3553 Else 3554 curIndex = 1 3555 End If 3556 3557 While Not entryFound And curIndex <= lastEntry 3558 curEntry = myDocList.item(curIndex) 3559 If (curEntry = myDocument) Then 3560 entryFound = True 3561 Else 3562 curIndex = curIndex + 1 3563 End If 3564 Wend 3565 3566 If (Not entryFound) Then 3567 curIndex = 1 3568 While Not entryFound And curIndex < lastIndex 3569 curEntry = myDocList.item(curIndex) 3570 If (curEntry = myDocument) Then 3571 entryFound = True 3572 Else 3573 curIndex = curIndex + 1 3574 End If 3575 Wend 3576 End If 3577 3578 If entryFound Then 3579 FindIndex = curIndex 3580 Else 3581 FindIndex = 0 3582 End If 3583 3584End Function 3585 3586' The sub GetIndexValues calulates the start index of the analysis and the index 3587' of the file after which the next intermediate reult will be written 3588Function GetIndexValues(startIndex As Long, nextCheck As Long, _ 3589 myFiles As Collection) As Boolean 3590 3591 Dim lastCheckpoint As String 3592 Dim nextFile As String 3593 Dim newResultsFile As Boolean 3594 3595 lastCheckpoint = ProfileGetItem(C_ANALYSIS, C_LAST_CHECKPOINT, "", mIniFilePath) 3596 nextFile = ProfileGetItem(C_ANALYSIS, C_NEXT_FILE, "", mIniFilePath) 3597 newResultsFile = True 3598 3599 If (nextFile = "") Then 3600 ' No Analysis done yet 3601 startIndex = 1 3602 nextCheck = C_MAX_CHECK 3603 Else 3604 If (lastCheckpoint = "") Then 3605 startIndex = 1 3606 Else 3607 startIndex = FindIndex(lastCheckpoint, myFiles, 1) + 1 3608 If (startIndex > 0) Then newResultsFile = False 3609 End If 3610 3611 nextCheck = FindIndex(nextFile, myFiles, startIndex - 1) 3612 3613 If (nextCheck = 0) Then ' Next file not in file list, restarting 3614 startIndex = 1 3615 nextCheck = C_MAX_CHECK 3616 newResultsFile = True 3617 ElseIf (nextCheck < startIndex) Then 'we are done? 3618 nextCheck = startIndex + C_MAX_CHECK 3619 ElseIf (nextCheck = startIndex) Then 'skip this one 3620 WriteToLog C_ERROR_HANDLING_DOC & nextCheck, nextFile 3621 startIndex = startIndex + 1 3622 nextCheck = startIndex + C_MAX_CHECK 3623 Else 'last time an error occured with that file, write before analysing 3624 nextCheck = nextCheck - 1 3625 End If 3626 End If 3627 GetIndexValues = newResultsFile 3628End Function 3629 3630Private Sub GetDocModificationDates(docCounts As DocModificationDates) 3631 3632 On Error GoTo HandleErrors 3633 Dim currentFunctionName As String 3634 currentFunctionName = "GetDocModificationDates" 3635 3636 docCounts.lessThanThreemonths = CLng(ProfileGetItem("Analysis", C_DOCS_LESS_3_MONTH, "0", mIniFilePath)) 3637 docCounts.threeToSixmonths = CLng(ProfileGetItem("Analysis", C_DOCS_LESS_6_MONTH, "0", mIniFilePath)) 3638 docCounts.sixToTwelvemonths = CLng(ProfileGetItem("Analysis", C_DOCS_LESS_12_MONTH, "0", mIniFilePath)) 3639 docCounts.greaterThanOneYear = CLng(ProfileGetItem("Analysis", C_DOCS_MORE_12_MONTH, "0", mIniFilePath)) 3640 3641FinalExit: 3642 Exit Sub 3643HandleErrors: 3644 WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source 3645 Resume FinalExit 3646End Sub 3647