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