| Attribute VB_Name = "AnalysisDriver" | |
| '************************************************************************* | |
| ' | |
| ' Licensed to the Apache Software Foundation (ASF) under one | |
| ' or more contributor license agreements. See the NOTICE file | |
| ' distributed with this work for additional information | |
| ' regarding copyright ownership. The ASF licenses this file | |
| ' to you under the Apache License, Version 2.0 (the | |
| ' "License"); you may not use this file except in compliance | |
| ' with the License. You may obtain a copy of the License at | |
| ' | |
| ' http://www.apache.org/licenses/LICENSE-2.0 | |
| ' | |
| ' Unless required by applicable law or agreed to in writing, | |
| ' software distributed under the License is distributed on an | |
| ' "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY | |
| ' KIND, either express or implied. See the License for the | |
| ' specific language governing permissions and limitations | |
| ' under the License. | |
| ' | |
| '************************************************************************* | |
| Option Explicit | |
| ' Declare Public variables. | |
| Public Type ShortItemId | |
| cb As Long | |
| abID As Byte | |
| End Type | |
| Public Type ITEMIDLIST | |
| mkid As ShortItemId | |
| End Type | |
| Public Declare Function FindWindow Lib "user32" Alias _ | |
| "FindWindowA" (ByVal lpClassName As String, _ | |
| ByVal lpWindowName As Long) As Long | |
| Private Declare Function GetTickCount Lib "kernel32" () As Long | |
| 'This function saves the passed value to the file, | |
| 'under the section and key names specified. | |
| 'If the ini file, lpFileName, does not exist, it is created. | |
| 'If the section, lpSectionName, does not exist, it is created. | |
| 'If the key name, lpKeyName, does not exist, it is created. | |
| 'If the key name exists, it's value, lpString, is replaced. | |
| Private Declare Function WritePrivateProfileString Lib "kernel32" _ | |
| Alias "WritePrivateProfileStringA" _ | |
| (ByVal lpSectionName As String, _ | |
| ByVal lpKeyName As Any, _ | |
| ByVal lpString As Any, _ | |
| ByVal lpFileName As String) As Long | |
| Private Declare Function GetPrivateProfileString Lib "kernel32" _ | |
| Alias "GetPrivateProfileStringA" _ | |
| (ByVal lpSectionName As String, _ | |
| ByVal lpKeyName As Any, _ | |
| ByVal lpDefault As String, _ | |
| ByVal lpReturnedString As String, _ | |
| ByVal nSize As Long, _ | |
| ByVal lpFileName As String) As Long | |
| Private Declare Function UrlEscape Lib "shlwapi" _ | |
| Alias "UrlEscapeA" _ | |
| (ByVal pszURL As String, _ | |
| ByVal pszEscaped As String, _ | |
| pcchEscaped As Long, _ | |
| ByVal dwFlags As Long) As Long | |
| Public Declare Function SHGetPathFromIDList Lib "shell32.dll" _ | |
| (ByVal pidl As Long, ByVal pszPath As String) As Long | |
| Public Declare Function SHGetSpecialFolderLocation Lib _ | |
| "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder _ | |
| As Long, pidl As ITEMIDLIST) As Long | |
| Public Const LOCALE_ILANGUAGE As Long = &H1 'language id | |
| Public Const LOCALE_SLANGUAGE As Long = &H2 'localized name of lang | |
| Public Const LOCALE_SENGLANGUAGE As Long = &H1001 'English name of lang | |
| Public Const LOCALE_SABBREVLANGNAME As Long = &H3 'abbreviated lang name | |
| Public Const LOCALE_SNATIVELANGNAME As Long = &H4 'native name of lang | |
| Public Const LOCALE_ICOUNTRY As Long = &H5 'country code | |
| Public Const LOCALE_SCOUNTRY As Long = &H6 'localized name of country | |
| Public Const LOCALE_SENGCOUNTRY As Long = &H1002 'English name of country | |
| Public Const LOCALE_SABBREVCTRYNAME As Long = &H7 'abbreviated country name | |
| Public Const LOCALE_SNATIVECTRYNAME As Long = &H8 'native name of country | |
| Public Const LOCALE_SINTLSYMBOL As Long = &H15 'intl monetary symbol | |
| Public Const LOCALE_IDEFAULTLANGUAGE As Long = &H9 'def language id | |
| Public Const LOCALE_IDEFAULTCOUNTRY As Long = &HA 'def country code | |
| Public Const LOCALE_IDEFAULTCODEPAGE As Long = &HB 'def oem code page | |
| Public Const LOCALE_IDEFAULTANSICODEPAGE As Long = &H1004 'def ansi code page | |
| Public Const LOCALE_IDEFAULTMACCODEPAGE As Long = &H1011 'def mac code page | |
| Public Const LOCALE_IMEASURE As Long = &HD '0 = metric, 1 = US | |
| Public Const LOCALE_SSHORTDATE As Long = &H1F 'short date format string | |
| '#if(WINVER >= &H0400) | |
| Public Const LOCALE_SISO639LANGNAME As Long = &H59 'ISO abbreviated language name | |
| Public Const LOCALE_SISO3166CTRYNAME As Long = &H5A 'ISO abbreviated country name | |
| '#endif /* WINVER >= as long = &H0400 */ | |
| '#if(WINVER >= &H0500) | |
| Public Const LOCALE_SNATIVECURRNAME As Long = &H1008 'native name of currency | |
| Public Const LOCALE_IDEFAULTEBCDICCODEPAGE As Long = &H1012 'default ebcdic code page | |
| Public Const LOCALE_SSORTNAME As Long = &H1013 'sort name | |
| '#endif /* WINVER >= &H0500 */ | |
| Public Declare Function GetSystemDefaultLangID Lib "kernel32" () As Long | |
| Public Declare Function GetUserDefaultLangID Lib "kernel32" () As Long | |
| Public Declare Function GetLocaleInfo Lib "kernel32" _ | |
| Alias "GetLocaleInfoA" _ | |
| (ByVal Locale As Long, _ | |
| ByVal LCType As Long, _ | |
| ByVal lpLCData As String, _ | |
| ByVal cchData As Long) As Long | |
| Public Const CWIZARD = "analysis" | |
| Const CROWOFFSET = 2 | |
| Const CDOCPROP_PAW_ROWOFFSET = 3 | |
| Private mDocPropRowOffset As Long | |
| Const CNUMBERDOC_ALL = "All" | |
| Const CTOTAL_DOCS_ANALYZED = "TotalDocsAnalysed" | |
| Const CNUMDAYS_IN_MONTH = 30 | |
| Const CMAX_LIMIT = 10000 | |
| Const CISSUE_DETDOCNAME = 1 | |
| Const CISSUE_DETDOCAPPLICATION = CISSUE_DETDOCNAME + 1 | |
| Const CISSUE_DETTYPE = CISSUE_DETDOCAPPLICATION + 1 | |
| Const CISSUE_DETSUBTYPE = CISSUE_DETTYPE + 1 | |
| Const CISSUE_DETLOCATION = CISSUE_DETSUBTYPE + 1 | |
| Const CISSUE_DETSUBLOCATION = CISSUE_DETLOCATION + 1 | |
| Const CISSUE_DETLINE = CISSUE_DETSUBLOCATION + 1 | |
| Const CISSUE_DETCOLUMN = CISSUE_DETLINE + 1 | |
| Const CISSUE_DETATTRIBUTES = CISSUE_DETCOLUMN + 1 | |
| Const CISSUE_DETNAMEANDPATH = CISSUE_DETATTRIBUTES + 1 | |
| Const CREF_DETDOCNAME = 1 | |
| Const CREF_DETDOCAPPLICATION = CREF_DETDOCNAME + 1 | |
| Const CREF_DETREFERENCE = CREF_DETDOCAPPLICATION + 1 | |
| Const CREF_DETDESCRIPTION = CREF_DETREFERENCE + 1 | |
| Const CREF_DETLOCATION = CREF_DETDESCRIPTION + 1 | |
| Const CREF_DETATTRIBUTES = CREF_DETLOCATION + 1 | |
| Const CREF_DETNAMEANDPATH = CREF_DETATTRIBUTES + 1 | |
| Const CINPUT_DIR = "indir" | |
| Const COUTPUT_DIR = "outdir" | |
| Const CRESULTS_FILE = "resultsfile" | |
| Const CLOG_FILE = "logfile" | |
| Const CRESULTS_TEMPLATE = "resultstemplate" | |
| Const CRESULTS_EXIST = "resultsexist" | |
| Const COVERWRITE_FILE = "overwritefile" | |
| Const CNEW_RESULTS_FILE = "newresultsfile" | |
| Const CINCLUDE_SUBDIRS = "includesubdirs" | |
| Const CDEBUG_LEVEL = "debuglevel" | |
| Const COUTPUT_TYPE = "outputtype" | |
| Const COUTPUT_TYPE_XLS = "xls" | |
| Const COUTPUT_TYPE_XML = "xml" | |
| Const COUTPUT_TYPE_BOTH = "both" | |
| Const COVERVIEW_TITLE_LABEL = "OV_Document_Analysis_Overview_lbl" | |
| Const CDEFAULT_PASSWORD = "defaultpassword" | |
| Const CVERSION = "version" | |
| Const CTITLE = "title" | |
| Const CDOPREPARE = "prepare" | |
| Const CISSUES_LIMIT = "issuesmonthlimit" | |
| Const CSINGLE_FILE = "singlefile" | |
| Const CFILE_LIST = "filelist" | |
| Const CSTAT_FILE = "statfilename" | |
| Const C_ABORT_ANALYSIS = "abortanalysis" | |
| Const C_DOCS_LESS_3_MONTH = "DocumentsYoungerThan3Month" | |
| Const C_DOCS_LESS_6_MONTH = "DocumentsYoungerThan6Month" | |
| Const C_DOCS_LESS_12_MONTH = "DocumentsYoungerThan12Month" | |
| Const C_DOCS_MORE_12_MONTH = "DocumentsOlderThan12Month" | |
| Private Const C_ANALYSIS As String = "Analysis" | |
| Private Const C_LAST_CHECKPOINT As String = "LastCheckpoint" | |
| Private Const C_NEXT_FILE As String = "NextFile" | |
| Private Const C_MAX_CHECK_INI As String = "FilesBeforeSave" | |
| Private Const C_MAX_WAIT_BEFORE_WRITE_INI As String = "SecondsBeforeSave" | |
| Private Const C_MAX_RANGE_PROCESS_TIME_INI As String = "ExcelMaxRangeProcessTime" | |
| Private Const C_ERROR_HANDLING_DOC As String = "_ERROR_HANDLING_DOC_" | |
| Private Const C_MAX_CHECK As Long = 100 | |
| Private Const C_MAX_WAIT_BEFORE_WRITE As Long = 300 ' sec | |
| Private Const C_MAX_RANGE_PROCESS_TIME As Integer = 30 'sec | |
| Private Const C_STAT_STARTING As Integer = 1 | |
| Private Const C_STAT_DONE As Integer = 2 | |
| Private Const C_STAT_FINISHED As Integer = 3 | |
| Private Type DocumentCount | |
| numDocsAnalyzed As Long | |
| numDocsAnalyzedWithIssues As Long | |
| numMinorIssues As Long | |
| numComplexIssues As Long | |
| numMacroIssues As Long | |
| numPreparableIssues As Long | |
| totalMacroCosts As Long | |
| totalDocIssuesCosts As Long | |
| totalPreparableIssuesCosts As Long | |
| End Type | |
| Private Type DocModificationDates | |
| lessThanThreemonths As Long | |
| threeToSixmonths As Long | |
| sixToTwelvemonths As Long | |
| greaterThanOneYear As Long | |
| End Type | |
| Private Type DocMacroClassifications | |
| None As Long | |
| Simple As Long | |
| Medium As Long | |
| complex As Long | |
| End Type | |
| Private Type DocIssueClassifications | |
| None As Long | |
| Minor As Long | |
| complex As Long | |
| End Type | |
| Const CCOST_COL_OFFSET = -1 | |
| Private mLogFilePath As String | |
| Private mDocIndex As String | |
| Private mDebugLevel As Long | |
| Private mIniFilePath As String | |
| Private mUserFormTypesDict As Scripting.Dictionary | |
| Private mIssuesDict As Scripting.Dictionary | |
| Private mMacroDict As Scripting.Dictionary | |
| Private mPreparedIssuesDict As Scripting.Dictionary | |
| Private mIssuesClassificationDict As Scripting.Dictionary | |
| Private mIssuesCostDict As Scripting.Dictionary | |
| Private mIssuesLimit As Date | |
| Public Const CWORD_DRIVER_FILE = "_OOoDocAnalysisWordDriver.doc" | |
| Public Const CEXCEL_DRIVER_FILE = "_OOoDocAnalysisExcelDriver.xls" | |
| Public Const CPP_DRIVER_FILE = "_OOoDocAnalysisPPTDriver.ppt" | |
| Public Const CWORD_DRIVER_FILE_TEMP = "~$OoDocAnalysisWordDriver.doc" | |
| Public Const CEXCEL_DRIVER_FILE_TEMP = "~$OoDocAnalysisExcelDriver.xls" | |
| Public Const CPP_DRIVER_FILE_TEMP = "~$OoDocAnalysisPPTDriver.ppt" | |
| 'Doc Properties Offsets - used in WriteDocProperties and GetPreparableFilesFromDocProps | |
| Const CDOCINFONAME = 1 | |
| Const CDOCINFOAPPLICATION = CDOCINFONAME + 1 | |
| Const CDOCINFOISSUE_CLASS = CDOCINFOAPPLICATION + 1 | |
| Const CDOCINFOCOMPLEXISSUES = CDOCINFOISSUE_CLASS + 1 | |
| Const CDOCINFOMINORISSUES = CDOCINFOCOMPLEXISSUES + 1 | |
| Const CDOCINFOPREPAREDISSUES = CDOCINFOMINORISSUES + 1 | |
| Const CDOCINFOMACRO_CLASS = CDOCINFOPREPAREDISSUES + 1 | |
| Const CDOCINFOMACRO_USERFORMS = CDOCINFOMACRO_CLASS + 1 | |
| Const CDOCINFOMACRO_LINESOFCODE = CDOCINFOMACRO_USERFORMS + 1 | |
| Const CDOCINFODOCISSUECOSTS = CDOCINFOMACRO_LINESOFCODE + 1 | |
| Const CDOCINFOPREPARABLEISSUECOSTS = CDOCINFODOCISSUECOSTS + 1 | |
| Const CDOCINFOMACROISSUECOSTS = CDOCINFOPREPARABLEISSUECOSTS + 1 | |
| Const CDOCINFONUMBERPAGES = CDOCINFOMACROISSUECOSTS + 1 | |
| Const CDOCINFOCREATED = CDOCINFONUMBERPAGES + 1 | |
| Const CDOCINFOLASTMODIFIED = CDOCINFOCREATED + 1 | |
| Const CDOCINFOLASTACCESSED = CDOCINFOLASTMODIFIED + 1 | |
| Const CDOCINFOLASTPRINTED = CDOCINFOLASTACCESSED + 1 | |
| Const CDOCINFOLASTSAVEDBY = CDOCINFOLASTPRINTED + 1 | |
| Const CDOCINFOREVISION = CDOCINFOLASTSAVEDBY + 1 | |
| Const CDOCINFOTEMPLATE = CDOCINFOREVISION + 1 | |
| Const CDOCINFONAMEANDPATH = CDOCINFOTEMPLATE + 1 | |
| 'Overview shapes | |
| Const COV_DOC_MOD_DATES_CHART = "Chart 21" | |
| Const COV_DOC_MACRO_CHART = "Chart 22" | |
| Const COV_DOC_ANALYSIS_CHART = "Chart 23" | |
| Const COV_DOC_MOD_DATES_COMMENT_TXB = "Text Box 25" | |
| Const COV_DOC_MOD_DATES_LEGEND_TXB = "Text Box 12" | |
| Const COV_DOC_MACRO_COMMENT_TXB = "Text Box 26" | |
| Const COV_DOC_MACRO_LEGEND_TXB = "Text Box 16" | |
| Const COV_DOC_ANALYSIS_COMMENT_TXB = "Text Box 27" | |
| Const COV_DOC_ANALYSIS_LEGEND_DAW_TXB = "Text Box 28" | |
| Const COV_DOC_ANALYSIS_LEGEND_PAW_TXB = "Text Box 18" | |
| Const COV_HIGH_LEVEL_ANALYSIS_RANGE = "OV_High_Level_Analysis_Range" | |
| Const COV_COST_RANGE = "OV_Cost_Range" | |
| 'Sheet labels | |
| Const COV_HIGH_LEVEL_ANALYSIS_LBL = "OV_High_level_analysis_lbl" | |
| Const COV_DP_PREPISSUES_COL_LBL = "DocProperties_PreparedIssues_Column" | |
| Const COV_COSTS_PREPISSUE_COUNT_COL_LBL = "Costs_PreparedIssueCount_Column" | |
| Const CDP_DAW_HIDDEN_COLS_LBL = "DP_DAW_HIDDEN_COLS_RANGE" | |
| Const CDP_DAW_HIDDEN_COLS2_LBL = "DP_DAW_HIDDEN_COLS_RANGE2" | |
| Const CDP_DAW_HIDDEN_ROW_LBL = "DP_DAW_HIDDEN_ROW_RANGE" | |
| Const COV_DAW_SETUP_SHEETS_RUN_LBL = "OV_DAW_SETUP_SHEETS_RUN" | |
| Const COV_PAW_SETUP_SHEETS_RUN_LBL = "OV_PAW_SETUP_SHEETS_RUN" | |
| Const COV_Internal_Attributes_Cols_LBL = "OV_Internal_Attributes_Cols" | |
| Const CR_STR = "<CR>" | |
| Const CR_TOPIC = "<TOPIC>" | |
| Const CR_PRODUCT = "<PRODUCT>" | |
| Const CLEGEND_FONT_SIZE = 8 | |
| Const CCOMMENTS_FONT_SIZE = 10 | |
| Dim mTstart As Single | |
| Dim mTend As Single | |
| Public gExcelMaxRangeProcessTime As Integer | |
| Sub AnalyseDirectory() | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "AnalyseDirectory" | |
| Dim iniFilePath As String | |
| Dim startDir As String | |
| Dim fileList As String | |
| Dim storeToDir As String | |
| Dim resultsFile As String | |
| Dim resultsTemplate As String | |
| Dim statFileName As String | |
| Dim bOverwriteResultsFile As Boolean | |
| Dim bNewResultsFile As Boolean | |
| Dim outputType As String | |
| Dim singleFile As String | |
| Dim nTimeNeeded As Long | |
| Dim nIncrementFileCounter As Long | |
| Dim nMaxWaitBeforeWrite As Long | |
| Dim fso As Scripting.FileSystemObject | |
| Set fso = New Scripting.FileSystemObject | |
| SetAppToMinimized | |
| If InDocPreparation Then | |
| mDocPropRowOffset = CDOCPROP_PAW_ROWOFFSET | |
| Else | |
| mDocPropRowOffset = CROWOFFSET | |
| End If | |
| 'Get Wizard input variables | |
| SetupWizardVariables fileList, storeToDir, resultsFile, _ | |
| mLogFilePath, resultsTemplate, bOverwriteResultsFile, bNewResultsFile, _ | |
| statFileName, mDebugLevel, outputType, singleFile | |
| startDir = ProfileGetItem("Analysis", CINPUT_DIR, "", mIniFilePath) | |
| nIncrementFileCounter = CLng(ProfileGetItem("Analysis", _ | |
| C_MAX_CHECK_INI, C_MAX_CHECK, mIniFilePath)) | |
| nMaxWaitBeforeWrite = CLng(ProfileGetItem("Analysis", _ | |
| C_MAX_WAIT_BEFORE_WRITE_INI, C_MAX_WAIT_BEFORE_WRITE, mIniFilePath)) | |
| gExcelMaxRangeProcessTime = CInt(ProfileGetItem("Analysis", _ | |
| C_MAX_RANGE_PROCESS_TIME_INI, C_MAX_RANGE_PROCESS_TIME, mIniFilePath)) | |
| LocalizeResources | |
| 'Setup File List | |
| 'For Prepare - get list from results spreadsheet with docs analysis found as preparable | |
| 'If no results spreadsheet then just try to prepare all the docs - run over full analysis list | |
| Dim myFiles As Collection | |
| Set myFiles = New Collection | |
| Dim sAnalysisOrPrep As String | |
| If InDocPreparation And CheckDoPrepare Then | |
| sAnalysisOrPrep = "Prepared" | |
| If fso.FileExists(storeToDir & "\" & resultsFile) Then | |
| If Not GetPrepareFilesToAnalyze(storeToDir & "\" & resultsFile, myFiles, fso) Then | |
| SetPrepareToNone | |
| WriteDebug currentFunctionName & ": No files to analyse!" | |
| GoTo FinalExit 'No files to prepare - exit | |
| End If | |
| Else | |
| If Not GetFilesToAnalyze(fileList, singleFile, myFiles) Then | |
| SetPrepareToNone | |
| WriteDebug currentFunctionName & ": No files to analyse! Filelist (" & fileList & ") empty?" | |
| GoTo FinalExit 'No files to prepare - exit | |
| End If | |
| End If | |
| Else | |
| sAnalysisOrPrep = "Analyzed" | |
| If Not GetFilesToAnalyze(fileList, singleFile, myFiles) Then | |
| WriteDebug currentFunctionName & ": No files to analyse! Filelist (" & fileList & ") empty?" | |
| GoTo FinalExit | |
| End If | |
| End If | |
| Dim index As Long | |
| Dim numFiles As Long | |
| Dim nextSave As Long | |
| Dim startIndex As Long | |
| Dim bResultsWaiting As Boolean | |
| Dim AnalysedDocs As Collection | |
| Dim startDate As Date | |
| Dim currentDate As Date | |
| Set AnalysedDocs = New Collection | |
| numFiles = myFiles.count | |
| bResultsWaiting = False | |
| If (singleFile <> "") Then | |
| ' No recovery handling for single file analysis and the value in the | |
| ' ini file should be used for bNewResultsFile | |
| startIndex = 1 | |
| Else | |
| bNewResultsFile = bNewResultsFile And GetIndexValues(startIndex, nextSave, myFiles) | |
| End If | |
| startDate = Now() | |
| ' Analyse all files | |
| For index = startIndex To numFiles | |
| Set mIssuesClassificationDict = New Scripting.Dictionary | |
| mIssuesClassificationDict.CompareMode = TextCompare | |
| Set mIssuesCostDict = New Scripting.Dictionary | |
| 'mIssuesCostDict.CompareMode = TextCompare | |
| Set mUserFormTypesDict = New Scripting.Dictionary | |
| Set mIssuesDict = New Scripting.Dictionary | |
| Set mMacroDict = New Scripting.Dictionary | |
| Set mPreparedIssuesDict = New Scripting.Dictionary | |
| 'Write to Application log | |
| Dim myAnalyser As MigrationAnalyser | |
| Set myAnalyser = New MigrationAnalyser | |
| If (CheckForAbort) Then GoTo FinalExit | |
| 'Log Analysis | |
| WriteToStatFile statFileName, C_STAT_STARTING, myFiles.item(index), fso | |
| WriteToLog "Analyzing", myFiles.item(index) | |
| WriteToIni C_NEXT_FILE, myFiles.item(index) | |
| mDocIndex = index | |
| 'Do Analysis | |
| myAnalyser.DoAnalyse myFiles.item(index), mUserFormTypesDict, startDir, storeToDir, fso | |
| AnalysedDocs.Add myAnalyser.Results | |
| bResultsWaiting = True | |
| WriteToLog sAnalysisOrPrep, index & "of" & numFiles & _ | |
| " " & getAppSpecificApplicationName & " Documents" | |
| WriteToLog "Analyzing", "Done" | |
| WriteToLog sAnalysisOrPrep & "Doc" & index, myFiles.item(index) | |
| Set myAnalyser = Nothing | |
| If (CheckForAbort) Then GoTo FinalExit | |
| 'No need to output results spreadsheet, just doing prepare | |
| If CheckDoPrepare Then GoTo CONTINUE_FOR | |
| nTimeNeeded = val(DateDiff("s", startDate, Now())) | |
| If ((nTimeNeeded > nMaxWaitBeforeWrite) Or _ | |
| (index >= nextSave)) Then | |
| If WriteResults(storeToDir, resultsFile, resultsTemplate, _ | |
| bOverwriteResultsFile, bNewResultsFile, _ | |
| outputType, AnalysedDocs, fso) Then | |
| nextSave = index + C_MAX_CHECK | |
| bResultsWaiting = False | |
| Set AnalysedDocs = New Collection | |
| WriteToIni C_LAST_CHECKPOINT, myFiles.item(index) | |
| startDate = Now() | |
| Else | |
| 'write error | |
| End If | |
| End If | |
| WriteToStatFile statFileName, C_STAT_DONE, myFiles.item(index), fso | |
| CONTINUE_FOR: | |
| Next index | |
| If (bResultsWaiting) Then | |
| If WriteResults(storeToDir, resultsFile, resultsTemplate, _ | |
| bOverwriteResultsFile, bNewResultsFile, _ | |
| outputType, AnalysedDocs, fso) Then | |
| WriteToIni C_LAST_CHECKPOINT, myFiles.item(index - 1) | |
| Else | |
| 'write error | |
| End If | |
| End If | |
| WriteToStatFile statFileName, C_STAT_FINISHED, "", fso | |
| FinalExit: | |
| Set fso = Nothing | |
| Set myFiles = Nothing | |
| Set mIssuesClassificationDict = Nothing | |
| Set mIssuesCostDict = Nothing | |
| Set mUserFormTypesDict = Nothing | |
| Set mIssuesDict = Nothing | |
| Set mMacroDict = Nothing | |
| Set mPreparedIssuesDict = Nothing | |
| Set AnalysedDocs = Nothing | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Function WriteResults(storeToDir As String, resultsFile As String, resultsTemplate As String, _ | |
| bOverwriteResultsFile As Boolean, bNewResultsFile As Boolean, _ | |
| outputType As String, AnalysedDocs As Collection, _ | |
| fso As FileSystemObject) As Boolean | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "WriteResults" | |
| If InDocPreparation Then | |
| If outputType = COUTPUT_TYPE_XML Or outputType = COUTPUT_TYPE_BOTH Then | |
| WriteXMLOutput storeToDir, resultsFile, _ | |
| bOverwriteResultsFile, bNewResultsFile, AnalysedDocs, fso | |
| End If | |
| End If | |
| If outputType = COUTPUT_TYPE_XLS Or outputType = COUTPUT_TYPE_BOTH Then | |
| WriteXLSOutput storeToDir, resultsFile, fso.GetAbsolutePathName(resultsTemplate), _ | |
| bOverwriteResultsFile, bNewResultsFile, AnalysedDocs, fso | |
| End If | |
| WriteResults = True | |
| bNewResultsFile = False | |
| FinalExit: | |
| Exit Function | |
| HandleErrors: | |
| WriteResults = False | |
| WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Function GetFilesToAnalyze_old(startDir As String, bIncludeSubdirs As Boolean, _ | |
| myFiles As Collection) As Boolean | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "GetFilesToAnalyze" | |
| Dim fso As New FileSystemObject | |
| Dim theResultsFile As String | |
| theResultsFile = ProfileGetItem("Analysis", CINPUT_DIR, "c:\", mIniFilePath) & "\" & ProfileGetItem("Analysis", CRESULTS_FILE, "", mIniFilePath) | |
| GetFilesToAnalyze = False | |
| Dim searchTypes As Collection | |
| Set searchTypes = New Collection | |
| SetupSearchTypes searchTypes | |
| If searchTypes.count = 0 Then | |
| GoTo FinalExit | |
| End If | |
| Dim myDocFiles As CollectedFiles | |
| Set myDocFiles = New CollectedFiles | |
| With myDocFiles | |
| .BannedList.Add fso.GetAbsolutePathName(getAppSpecificPath & "\" & CWORD_DRIVER_FILE) | |
| .BannedList.Add fso.GetAbsolutePathName(getAppSpecificPath & "\" & CEXCEL_DRIVER_FILE) | |
| .BannedList.Add fso.GetAbsolutePathName(getAppSpecificPath & "\" & CPP_DRIVER_FILE) | |
| .BannedList.Add fso.GetAbsolutePathName(getAppSpecificPath & "\" & CWORD_DRIVER_FILE_TEMP) | |
| .BannedList.Add fso.GetAbsolutePathName(getAppSpecificPath & "\" & CEXCEL_DRIVER_FILE_TEMP) | |
| .BannedList.Add fso.GetAbsolutePathName(getAppSpecificPath & "\" & CPP_DRIVER_FILE_TEMP) | |
| .BannedList.Add theResultsFile | |
| End With | |
| myDocFiles.Search rootDir:=startDir, FileSpecs:=searchTypes, _ | |
| IncludeSubdirs:=bIncludeSubdirs | |
| If getAppSpecificApplicationName = CAPPNAME_WORD Then | |
| Set myFiles = myDocFiles.WordFiles | |
| ElseIf getAppSpecificApplicationName = CAPPNAME_EXCEL Then | |
| Set myFiles = myDocFiles.ExcelFiles | |
| ElseIf getAppSpecificApplicationName = CAPPNAME_POWERPOINT Then | |
| Set myFiles = myDocFiles.PowerPointFiles | |
| Else | |
| WriteDebug currentFunctionName & " : invalid application " & getAppSpecificApplicationName | |
| GoTo FinalExit | |
| End If | |
| GetFilesToAnalyze = True | |
| FinalExit: | |
| Set searchTypes = Nothing | |
| Set myDocFiles = Nothing | |
| Exit Function | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Function GetFilesToAnalyze(fileList As String, startFile As String, _ | |
| myFiles As Collection) As Boolean | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "GetFilesToAnalyze" | |
| Dim fso As New FileSystemObject | |
| Dim fileContent As TextStream | |
| Dim fileName As String | |
| GetFilesToAnalyze = False | |
| If (startFile = "") Then | |
| If (fso.FileExists(fileList)) Then | |
| Set fileContent = fso.OpenTextFile(fileList, ForReading, False, TristateTrue) | |
| While (Not fileContent.AtEndOfStream) | |
| fileName = fileContent.ReadLine | |
| fileName = Trim(fileName) | |
| If (fileName <> "") Then | |
| myFiles.Add (fileName) | |
| End If | |
| Wend | |
| fileContent.Close | |
| End If | |
| Else | |
| myFiles.Add (startFile) | |
| End If | |
| If (myFiles.count <> 0) Then GetFilesToAnalyze = True | |
| FinalExit: | |
| Set fileContent = Nothing | |
| Set fso = Nothing | |
| Exit Function | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Function GetPrepareFilesToAnalyze(resultsFilePath As String, myFiles As Collection, _ | |
| fso As FileSystemObject) As Boolean | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "GetPrepareFilesToAnalyze" | |
| GetPrepareFilesToAnalyze = False | |
| If Not fso.FileExists(resultsFilePath) Then | |
| WriteDebug currentFunctionName & ": results file does not exist : " & resultsFilePath | |
| GoTo FinalExit | |
| End If | |
| 'Open results spreadsheet | |
| Dim xl As Excel.Application | |
| If getAppSpecificApplicationName = CAPPNAME_EXCEL Then | |
| Set xl = Application | |
| xl.Visible = True | |
| Else | |
| Set xl = GetExcelInstance | |
| xl.Visible = False | |
| End If | |
| Dim logWb As WorkBook | |
| Set logWb = xl.Workbooks.Open(resultsFilePath) | |
| Dim wsDocProp As Worksheet | |
| Set wsDocProp = logWb.Sheets(RID_STR_COMMON_RESULTS_SHEET_NAME_DOCPROP) | |
| Dim startRow As Long | |
| Dim endRow As Long | |
| startRow = mDocPropRowOffset + 1 | |
| endRow = GetWorkbookNameValueAsLong(logWb, CTOTAL_DOCS_ANALYZED) + mDocPropRowOffset | |
| GetPreparableFilesFromDocProps wsDocProp, startRow, endRow, fso, myFiles | |
| GetPrepareFilesToAnalyze = (myFiles.count > 0) | |
| FinalExit: | |
| Set wsDocProp = Nothing | |
| If Not logWb Is Nothing Then logWb.Close | |
| Set logWb = Nothing | |
| If getAppSpecificApplicationName <> CAPPNAME_EXCEL Then | |
| If Not xl Is Nothing Then | |
| If xl.Workbooks.count = 0 Then | |
| xl.Quit | |
| End If | |
| End If | |
| End If | |
| Set xl = Nothing | |
| Exit Function | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Function GetPreparableFilesFromDocProps(wsDocProp As Worksheet, startRow As Long, _ | |
| endRow As Long, fso As FileSystemObject, myFiles As Collection) As Boolean | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "GetPreparableFilesFromDocProps" | |
| GetPreparableFilesFromDocProps = False | |
| Dim index As Long | |
| Dim fileName As String | |
| Dim fileExt As String | |
| Dim docExt As String | |
| Dim templateExt As String | |
| docExt = getAppSpecificDocExt | |
| templateExt = getAppSpecificTemplateExt | |
| For index = startRow To endRow | |
| If GetWorksheetCellValueAsLong(wsDocProp, index, CDOCINFOPREPAREDISSUES) > 0 Then | |
| fileName = GetWorksheetCellValueAsString(wsDocProp, index, CDOCINFONAME) | |
| fileExt = "." & fso.GetExtensionName(fileName) | |
| 'Don't have to worry about search types - just looking at existing results | |
| 'so just check both legal extensions for this application | |
| If fileExt = docExt Or fileExt = templateExt Then | |
| myFiles.Add GetWorksheetCellValueAsString(wsDocProp, index, CDOCINFONAMEANDPATH) | |
| End If | |
| End If | |
| Next index | |
| GetPreparableFilesFromDocProps = myFiles.count > 0 | |
| FinalExit: | |
| Exit Function | |
| HandleErrors: | |
| GetPreparableFilesFromDocProps = False | |
| WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Sub OpenXLSResultFile(resultsFile As String, _ | |
| resultsTemplate As String, _ | |
| bNewResultsFile As Boolean, _ | |
| excelApp As Excel.Application, _ | |
| resultSheet As Excel.WorkBook) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "OpenXLSResultFile" | |
| If getAppSpecificApplicationName = CAPPNAME_EXCEL Then | |
| Set excelApp = Application | |
| excelApp.Visible = True | |
| Else | |
| Set excelApp = GetExcelInstance | |
| excelApp.Visible = False | |
| End If | |
| If bNewResultsFile Then | |
| Set resultSheet = excelApp.Workbooks.Add(Template:=resultsTemplate) | |
| Localize_WorkBook resultSheet | |
| Else | |
| Set resultSheet = excelApp.Workbooks.Open(resultsFile) | |
| End If | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| excelApp.DisplayAlerts = False | |
| WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub CloseXLSResultFile(excelApp As Excel.Application, _ | |
| resultSheet As Excel.WorkBook) | |
| On Error Resume Next | |
| If Not resultSheet Is Nothing Then resultSheet.Close | |
| Set resultSheet = Nothing | |
| If getAppSpecificApplicationName <> CAPPNAME_EXCEL Then | |
| If Not excelApp Is Nothing Then | |
| excelApp.Visible = True | |
| If excelApp.Workbooks.count = 0 Then | |
| excelApp.Quit | |
| End If | |
| End If | |
| End If | |
| Set excelApp = Nothing | |
| Exit Sub | |
| End Sub | |
| Sub WriteXLSOutput(storeToDir As String, resultsFile As String, resultsTemplate As String, _ | |
| bOverwriteResultsFile As Boolean, bNewResultsFile As Boolean, AnalysedDocs As Collection, _ | |
| fso As Scripting.FileSystemObject) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "WriteXLSOutput" | |
| Dim offsetDocPropRow As Long | |
| Dim offsetDocIssuesRow As Long | |
| Dim offsetDocIssueDetailsRow As Long | |
| Dim offsetDocRefDetailsRow As Long | |
| Const COVERVIEW_SHEET_IDX = 1 | |
| Const CDOCLIST_SHEET_IDX = 2 | |
| Const CISSUES_ANALYSED_SHEET = 3 | |
| Const CISSUE_DETAILS_SHEET = 4 | |
| Const CWORD_ISSUES_SHEET = 5 | |
| Const CEXCEL_ISSUES_SHEET = 6 | |
| Const CPOWERPOINT_ISSUES_SHEET = 7 | |
| Const CREFERENCE_ISSUES_SHEET = 8 | |
| 'Begin writing stats to excel | |
| Dim xl As Excel.Application | |
| If getAppSpecificApplicationName = CAPPNAME_EXCEL Then | |
| Set xl = Application | |
| xl.Visible = True | |
| Else | |
| Set xl = GetExcelInstance | |
| xl.Visible = False | |
| End If | |
| Dim logWb As WorkBook | |
| If bNewResultsFile Then | |
| Set logWb = xl.Workbooks.Add(Template:=resultsTemplate) | |
| Localize_WorkBook logWb | |
| Else | |
| Set logWb = xl.Workbooks.Open(storeToDir & "\" & resultsFile) | |
| End If | |
| SetupAnalysisResultsVariables logWb, offsetDocPropRow, _ | |
| offsetDocIssuesRow, offsetDocIssueDetailsRow, offsetDocRefDetailsRow | |
| ' Iterate through results and write info | |
| Dim aAnalysis As DocumentAnalysis | |
| Dim row As Long | |
| Dim docCounts As DocumentCount | |
| Dim templateCounts As DocumentCount | |
| Dim issuesRow As Long | |
| Dim issueDetailsRow As Long | |
| Dim refDetailsRow As Long | |
| Dim wsOverview As Worksheet | |
| Dim wsCosts As Worksheet | |
| Dim wsPgStats As Worksheet | |
| Dim wsIssues As Worksheet | |
| Dim wsIssueDetails As Worksheet | |
| Dim wsRefDetails As Worksheet | |
| Set wsOverview = logWb.Sheets(COVERVIEW_SHEET_IDX) | |
| Set wsPgStats = logWb.Sheets(CDOCLIST_SHEET_IDX) | |
| 'Some localized names might be longer than 31 chars, excel doesn't | |
| 'allow such names! | |
| On Error Resume Next | |
| wsOverview.name = RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW | |
| wsPgStats.name = RID_STR_COMMON_RESULTS_SHEET_NAME_DOCPROP | |
| On Error GoTo HandleErrors | |
| If InDocPreparation Then | |
| Set wsCosts = logWb.Sheets(CISSUES_ANALYSED_SHEET) | |
| Dim appName As String | |
| appName = getAppSpecificApplicationName | |
| Select Case appName | |
| Case "Word" | |
| Set wsIssues = logWb.Worksheets(CWORD_ISSUES_SHEET) | |
| Case "Excel" | |
| Set wsIssues = logWb.Worksheets(CEXCEL_ISSUES_SHEET) | |
| Case "PowerPoint" | |
| Set wsIssues = logWb.Worksheets(CPOWERPOINT_ISSUES_SHEET) | |
| Case Default | |
| Err.Raise Number:=-1, Description:="BadAppName" | |
| End Select | |
| Set wsIssueDetails = logWb.Sheets(CISSUE_DETAILS_SHEET) | |
| Set wsRefDetails = logWb.Sheets(CREFERENCE_ISSUES_SHEET) | |
| issuesRow = 1 + CROWOFFSET + offsetDocIssuesRow | |
| issueDetailsRow = 1 + CROWOFFSET + offsetDocIssueDetailsRow | |
| refDetailsRow = 1 + CROWOFFSET + offsetDocRefDetailsRow | |
| ' localize PAW worksheets | |
| Dim wsWordIssues As Worksheet | |
| Dim wsExcelIssues As Worksheet | |
| Dim wsPowerPointIssues As Worksheet | |
| Set wsWordIssues = logWb.Worksheets(CWORD_ISSUES_SHEET) | |
| Set wsExcelIssues = logWb.Worksheets(CEXCEL_ISSUES_SHEET) | |
| Set wsPowerPointIssues = logWb.Worksheets(CPOWERPOINT_ISSUES_SHEET) | |
| On Error Resume Next | |
| wsCosts.name = RID_STR_COMMON_RESULTS_SHEET_NAME_COSTS | |
| wsIssueDetails.name = RID_STR_COMMON_RESULTS_SHEET_NAME_DOCISSUE_DETAILS | |
| wsRefDetails.name = RID_STR_COMMON_RESULTS_SHEET_NAME_DOCREF_DETAILS | |
| wsWordIssues.name = RID_STR_COMMON_RESULTS_SHEET_NAME_DOCISSUES_WORD | |
| wsExcelIssues.name = RID_STR_COMMON_RESULTS_SHEET_NAME_DOCISSUES_EXCEL | |
| wsPowerPointIssues.name = RID_STR_COMMON_RESULTS_SHEET_NAME_DOCISSUES_POWERPOINT | |
| On Error GoTo HandleErrors | |
| End If | |
| Dim fileName As String | |
| Dim macroClasses As DocMacroClassifications | |
| Dim issueClasses As DocIssueClassifications | |
| For row = 1 To AnalysedDocs.count 'Need Row count - so not using Eor Each | |
| Set aAnalysis = AnalysedDocs.item(row) | |
| fileName = fso.GetFileName(aAnalysis.name) | |
| If InDocPreparation Then | |
| issuesRow = WriteDocIssues(wsIssues, issuesRow, aAnalysis, fileName) | |
| issueDetailsRow = _ | |
| ProcessIssuesAndWriteDocIssueDetails(logWb, wsIssueDetails, issueDetailsRow, aAnalysis, fileName) | |
| refDetailsRow = _ | |
| WriteDocRefDetails(wsRefDetails, refDetailsRow, aAnalysis, fileName) | |
| aAnalysis.MacroCosts = getMacroIssueCosts(logWb, aAnalysis) | |
| WriteDocProperties wsPgStats, row + offsetDocPropRow, aAnalysis, fileName | |
| Else | |
| ProcessIssuesForDAW logWb, aAnalysis, fileName | |
| WriteDocProperties wsPgStats, row + offsetDocPropRow, aAnalysis, fileName | |
| End If | |
| UpdateAllCounts aAnalysis, docCounts, templateCounts, macroClasses, issueClasses, fso | |
| Set aAnalysis = Nothing | |
| Next row | |
| ' We change the font used for text box shapes here for the japanese | |
| ' version, because office 2000 sometimes displays squares instead of | |
| ' chars | |
| Dim langStr As String | |
| Dim userLCID As Long | |
| Dim textSize As Long | |
| Dim fontName As String | |
| userLCID = GetUserDefaultLangID() | |
| langStr = GetUserLocaleInfo(userLCID, LOCALE_SISO639LANGNAME) | |
| If (langStr = "ja") Then | |
| WriteDebug currentFunctionName & " : Setting font to MS PGothic for 'ja' locale" | |
| fontName = "MS PGothic" | |
| textSize = 10 | |
| Else | |
| fontName = "Arial" | |
| textSize = CLEGEND_FONT_SIZE | |
| End If | |
| 'DAW - PAW switches | |
| If InDocPreparation Then | |
| SaveAnalysisResultsVariables logWb, issueDetailsRow - (1 + CROWOFFSET), _ | |
| refDetailsRow - (1 + CROWOFFSET) | |
| WriteOverview logWb, docCounts, templateCounts, macroClasses, issueClasses | |
| SetupPAWResultsSpreadsheet logWb, fontName, textSize | |
| WriteIssueCounts logWb | |
| Else | |
| WriteOverview logWb, docCounts, templateCounts, macroClasses, issueClasses | |
| 'StartTiming | |
| SetupDAWResultsSpreadsheet logWb, fontName, textSize | |
| 'EndTiming "SetupDAWResultsSpreadsheet" | |
| End If | |
| SetupPrintRanges logWb, row, issuesRow, issueDetailsRow, refDetailsRow | |
| If resultsFile <> "" Then | |
| 'Overwrite existing results file without prompting | |
| If bOverwriteResultsFile Or (Not bNewResultsFile) Then | |
| xl.DisplayAlerts = False | |
| End If | |
| logWb.SaveAs fileName:=storeToDir & "\" & resultsFile | |
| xl.DisplayAlerts = True | |
| End If | |
| FinalExit: | |
| If Not xl Is Nothing Then | |
| xl.Visible = True | |
| End If | |
| Set wsOverview = Nothing | |
| Set wsPgStats = Nothing | |
| If InDocPreparation Then | |
| Set wsCosts = Nothing | |
| Set wsIssues = Nothing | |
| Set wsIssueDetails = Nothing | |
| Set wsRefDetails = Nothing | |
| End If | |
| If Not logWb Is Nothing Then logWb.Close | |
| Set logWb = Nothing | |
| If getAppSpecificApplicationName <> CAPPNAME_EXCEL Then | |
| If Not xl Is Nothing Then | |
| If xl.Workbooks.count = 0 Then | |
| xl.Quit | |
| End If | |
| End If | |
| End If | |
| Set xl = Nothing | |
| Exit Sub | |
| HandleErrors: | |
| xl.DisplayAlerts = False | |
| WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Public Sub StartTiming() | |
| mTstart = 0 | |
| mTend = 0 | |
| mTstart = GetTickCount() | |
| End Sub | |
| Public Sub EndTiming(what As String) | |
| mTend = GetTickCount() | |
| WriteDebug "Timing: " & what & ": " & (FormatNumber((mTend - mTstart) / 1000, 0) & " seconds") | |
| mTstart = 0 | |
| mTend = 0 | |
| End Sub | |
| Sub WriteIssueCounts(logWb As WorkBook) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "WriteIssueCounts" | |
| Dim Str As String | |
| Dim str1 As String | |
| Dim val1 As Long | |
| Dim count As Long | |
| Dim vKeyArray As Variant | |
| Dim vItemArray As Variant | |
| Dim vPrepKeyArray As Variant | |
| Dim vPrepItemArray As Variant | |
| vKeyArray = mIssuesDict.Keys | |
| vItemArray = mIssuesDict.Items | |
| vPrepKeyArray = mPreparedIssuesDict.Keys | |
| vPrepItemArray = mPreparedIssuesDict.Items | |
| 'Write Issue Counts across all Documents | |
| For count = 0 To mIssuesDict.count - 1 | |
| str1 = vKeyArray(count) | |
| val1 = CInt(vItemArray(count)) | |
| logWb.Names(str1).RefersToRange.Cells(1, 1) = _ | |
| logWb.Names(str1).RefersToRange.Cells(1, 1).value + vItemArray(count) | |
| 'DEBUG: str = str & "Key: " & str1 & " Value: " & val1 & vbLf | |
| Next count | |
| 'Write Prepared Issues Counts across all Documents | |
| For count = 0 To mPreparedIssuesDict.count - 1 | |
| str1 = vPrepKeyArray(count) | |
| val1 = CInt(vPrepItemArray(count)) | |
| AddVariantToWorkbookNameValue logWb, str1, vPrepItemArray(count) | |
| 'DEBUG: str = str & "Key: " & str1 & " Value: " & val1 & vbLf | |
| Next count | |
| 'User Form control type count across all analyzed documents of this type | |
| str1 = getAppSpecificApplicationName & "_" & _ | |
| CSTR_ISSUE_VBA_MACROS & "_" & _ | |
| CSTR_SUBISSUE_PROPERTIES & "_" & _ | |
| CSTR_SUBISSUE_VBA_MACROS_USERFORMS_CONTROLTYPE_COUNT | |
| SetWorkbookNameValueToLong logWb, str1, mUserFormTypesDict.count | |
| 'Add list of User Form controls and counts to ...USERFORMS_CONTROLTYPE_COUNT field | |
| If mUserFormTypesDict.count > 0 Then | |
| vKeyArray = mUserFormTypesDict.Keys | |
| vItemArray = mUserFormTypesDict.Items | |
| Str = RID_STR_COMMON_ATTRIBUTE_CONTROLS & ": " | |
| For count = 0 To mUserFormTypesDict.count - 1 | |
| Str = Str & vbLf & vKeyArray(count) & " " & vItemArray(count) | |
| Next count | |
| WriteUserFromControlTypesComment logWb, str1, Str | |
| End If | |
| 'DEBUG: MsgBox str & vbLf & mIssuesDict.count | |
| WriteUniqueModuleCount logWb | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & _ | |
| " : logging costs : " & _ | |
| Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub WriteUniqueModuleCount(logWb As WorkBook) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "WriteUniqueModuleCount" | |
| Dim strLabel As String | |
| Dim uniqueLineCount As Long | |
| Dim uniqueModuleCount As Long | |
| Dim count As Long | |
| Dim vItemArray As Variant | |
| vItemArray = mMacroDict.Items | |
| 'Write Issues Costs | |
| uniqueLineCount = 0 | |
| For count = 0 To mMacroDict.count - 1 | |
| uniqueLineCount = uniqueLineCount + CInt(vItemArray(count)) | |
| Next count | |
| uniqueModuleCount = mMacroDict.count | |
| strLabel = getAppSpecificApplicationName & "_" & _ | |
| CSTR_ISSUE_VBA_MACROS & "_" & _ | |
| CSTR_SUBISSUE_PROPERTIES & "_" & _ | |
| CSTR_SUBISSUE_VBA_MACROS_UNIQUE_MODULE_COUNT | |
| SetWorkbookNameValueToLong logWb, strLabel, uniqueModuleCount | |
| strLabel = getAppSpecificApplicationName & "_" & _ | |
| CSTR_ISSUE_VBA_MACROS & "_" & _ | |
| CSTR_SUBISSUE_PROPERTIES & "_" & _ | |
| CSTR_SUBISSUE_VBA_MACROS_UNIQUE_LINE_COUNT | |
| SetWorkbookNameValueToLong logWb, strLabel, uniqueLineCount | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & _ | |
| " : logging Unique Module/ Line Counts : " & _ | |
| Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub WriteUserFromControlTypesComment(logWb As WorkBook, name As String, comment As String) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "WriteUserFromControlTypesComment" | |
| On Error Resume Next 'Ignore error if trying to add comment again - would happen on append to results | |
| logWb.Names(name).RefersToRange.Cells(1, 1).AddComment | |
| On Error GoTo HandleErrors | |
| logWb.Names(name).RefersToRange.Cells(1, 1).comment.Text Text:=comment | |
| 'Autosize not supported - Office 2000 | |
| 'logWb.Names(name).RefersToRange.Cells(1, 1).comment.AutoSize = True | |
| logWb.Names(name).RefersToRange.Cells(1, 1).comment.Visible = False | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & _ | |
| " : name : " & name & _ | |
| " : comment : " & comment & _ | |
| Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub UpdateAllCounts(aAnalysis As DocumentAnalysis, counts As DocumentCount, templateCounts As DocumentCount, _ | |
| macroClasses As DocMacroClassifications, issueClasses As DocIssueClassifications, _ | |
| fso As FileSystemObject) | |
| Const CMODDATE_LESS3MONTHS = 91 | |
| Const CMODDATE_LESS6MONTHS = 182 | |
| Const CMODDATE_LESS12MONTHS = 365 | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "UpdateAllCounts" | |
| 'DocIssue Classification occurs in setDocOverallIssueClassification under | |
| ' ProcessIssuesAndWriteDocIssueDetails when all DocIssues are being traversed. | |
| 'MacroClass for the Doc is setup at the end of the Analyze_Macros in DoAnalysis | |
| 'Mod Dates are determined in SetDocProperties in DoAnalysis | |
| 'DocMacroClassifications | |
| Select Case aAnalysis.MacroOverallClass | |
| Case enMacroComplex | |
| macroClasses.complex = macroClasses.complex + 1 | |
| Case enMacroMedium | |
| macroClasses.Medium = macroClasses.Medium + 1 | |
| Case enMacroSimple | |
| macroClasses.Simple = macroClasses.Simple + 1 | |
| Case Else | |
| macroClasses.None = macroClasses.None + 1 | |
| End Select | |
| 'DocIssueClassifications | |
| aAnalysis.BelowIssuesLimit = True | |
| Select Case aAnalysis.DocOverallIssueClass | |
| Case enComplex | |
| issueClasses.complex = issueClasses.complex + 1 | |
| Case enMinor | |
| issueClasses.Minor = issueClasses.Minor + 1 | |
| Case Else | |
| issueClasses.None = issueClasses.None + 1 | |
| End Select | |
| 'DocumentCounts | |
| Dim extStr As String | |
| extStr = "." & LCase(fso.GetExtensionName(aAnalysis.name)) | |
| If extStr = getAppSpecificDocExt Then | |
| UpdateDocCounts counts, aAnalysis | |
| ElseIf extStr = getAppSpecificTemplateExt Then | |
| UpdateDocCounts templateCounts, aAnalysis | |
| Else | |
| WriteDebug currentFunctionName & " : path " & aAnalysis.name & _ | |
| ": unhandled file extesnion " & extStr & " : " & Err.Number & " " & Err.Description & " " & Err.Source | |
| End If | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : path " & aAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub UpdateDocCounts(counts As DocumentCount, aAnalysis As DocumentAnalysis) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "UpdateDocCounts" | |
| counts.numDocsAnalyzed = counts.numDocsAnalyzed + 1 | |
| If aAnalysis.IssuesCount > 0 Then 'During Analysis incremented | |
| counts.numDocsAnalyzedWithIssues = counts.numDocsAnalyzedWithIssues + 1 | |
| If aAnalysis.BelowIssuesLimit Then | |
| counts.numMinorIssues = _ | |
| counts.numMinorIssues + aAnalysis.MinorIssuesCount | |
| 'MinorIssuesCount incemented as all DocIssues are being traversed are being written out - ProcessIssuesAndWriteDocIssueDetails | |
| counts.numComplexIssues = counts.numComplexIssues + aAnalysis.ComplexIssuesCount 'Calculated | |
| counts.totalDocIssuesCosts = counts.totalDocIssuesCosts + _ | |
| aAnalysis.DocIssuesCosts | |
| counts.totalPreparableIssuesCosts = counts.totalPreparableIssuesCosts + _ | |
| aAnalysis.PreparableIssuesCosts | |
| End If | |
| counts.numMacroIssues = counts.numMacroIssues + aAnalysis.MacroIssuesCount 'During Analysis incremented | |
| counts.totalMacroCosts = counts.totalMacroCosts + aAnalysis.MacroCosts | |
| End If | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : path " & aAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub WriteDocProperties(wsPgStats As Worksheet, row As Long, aAnalysis As DocumentAnalysis, _ | |
| fileName As String) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "WriteDocProperties" | |
| Dim rowIndex As Long | |
| rowIndex = row + mDocPropRowOffset | |
| If aAnalysis.Application = RID_STR_COMMON_CANNOT_OPEN Then | |
| SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFONAME, fileName | |
| SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFOAPPLICATION, aAnalysis.Application | |
| SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFONAMEANDPATH, aAnalysis.name | |
| GoTo FinalExit | |
| End If | |
| If InDocPreparation Then | |
| SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFONAME, fileName | |
| SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFOAPPLICATION, aAnalysis.Application | |
| SetWorksheetCellValueToLong wsPgStats, rowIndex, CDOCINFODOCISSUECOSTS, aAnalysis.DocIssuesCosts | |
| SetWorksheetCellValueToLong wsPgStats, rowIndex, CDOCINFOPREPARABLEISSUECOSTS, aAnalysis.PreparableIssuesCosts | |
| SetWorksheetCellValueToLong wsPgStats, rowIndex, CDOCINFOMACROISSUECOSTS, aAnalysis.MacroCosts | |
| SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFOISSUE_CLASS, _ | |
| getDocOverallIssueClassificationAsString(aAnalysis.DocOverallIssueClass) | |
| SetWorksheetCellValueToLong wsPgStats, rowIndex, CDOCINFOCOMPLEXISSUES, aAnalysis.ComplexIssuesCount | |
| SetWorksheetCellValueToLong wsPgStats, rowIndex, CDOCINFOMINORISSUES, aAnalysis.MinorIssuesCount | |
| SetWorksheetCellValueToLong wsPgStats, rowIndex, CDOCINFOPREPAREDISSUES, aAnalysis.PreparableIssuesCount | |
| SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFOMACRO_CLASS, _ | |
| getDocOverallMacroClassAsString(aAnalysis.MacroOverallClass) | |
| SetWorksheetCellValueToLong wsPgStats, rowIndex, CDOCINFOMACRO_USERFORMS, aAnalysis.MacroNumUserForms | |
| SetWorksheetCellValueToLong wsPgStats, rowIndex, CDOCINFOMACRO_LINESOFCODE, aAnalysis.MacroTotalNumLines | |
| SetWorksheetCellValueToLong wsPgStats, rowIndex, CDOCINFONUMBERPAGES, aAnalysis.PageCount | |
| SetWorksheetCellValueToVariant wsPgStats, rowIndex, CDOCINFOCREATED, CheckDate(aAnalysis.Created) | |
| SetWorksheetCellValueToVariant wsPgStats, rowIndex, CDOCINFOLASTMODIFIED, CheckDate(aAnalysis.Modified) | |
| SetWorksheetCellValueToVariant wsPgStats, rowIndex, CDOCINFOLASTACCESSED, CheckDate(aAnalysis.Accessed) | |
| SetWorksheetCellValueToVariant wsPgStats, rowIndex, CDOCINFOLASTPRINTED, CheckDate(aAnalysis.Printed) | |
| SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFOLASTSAVEDBY, aAnalysis.SavedBy | |
| SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFOREVISION, aAnalysis.Revision | |
| SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFOTEMPLATE, aAnalysis.Template | |
| SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFONAMEANDPATH, aAnalysis.name | |
| Else | |
| SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFONAME, fileName | |
| SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFOAPPLICATION, aAnalysis.Application | |
| SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFOISSUE_CLASS, _ | |
| getDocOverallIssueClassificationAsString(aAnalysis.DocOverallIssueClass) | |
| SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFOMACRO_CLASS, _ | |
| getDocOverallMacroClassAsString(aAnalysis.MacroOverallClass) | |
| SetWorksheetCellValueToVariant wsPgStats, rowIndex, CDOCINFOLASTMODIFIED, CheckDate(aAnalysis.Modified) | |
| SetWorksheetCellValueToString wsPgStats, rowIndex, CDOCINFONAMEANDPATH, aAnalysis.name | |
| End If | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : path " & aAnalysis.name & " : " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Function CheckDate(myDate As Date) As Variant | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "CheckDate" | |
| Dim lowerNTDateLimit As Date | |
| If Not IsDate(myDate) Then | |
| CheckDate = RID_STR_COMMON_NA | |
| Exit Function | |
| End If | |
| lowerNTDateLimit = DateSerial(1980, 1, 1) | |
| CheckDate = IIf(myDate < lowerNTDateLimit, RID_STR_COMMON_NA, myDate) | |
| FinalExit: | |
| Exit Function | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : date " & myDate & " : " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Function WriteDocIssues(wsIssues As Worksheet, row As Long, _ | |
| aAnalysis As DocumentAnalysis, fileName As String) As Long | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "WriteDocIssues" | |
| Const CNAME = 1 | |
| Const CAPPLICATION = CNAME + 1 | |
| Const CISSUE_COLUMNOFFSET = CAPPLICATION | |
| If aAnalysis.IssuesCount = 0 Then | |
| WriteDocIssues = row | |
| Exit Function | |
| End If | |
| SetWorksheetCellValueToString wsIssues, row, CNAME, fileName | |
| SetWorksheetCellValueToString wsIssues, row, CAPPLICATION, aAnalysis.Application | |
| Dim index As Integer | |
| For index = 1 To aAnalysis.TotalIssueTypes | |
| If aAnalysis.IssuesCountArray(index) > 0 Then | |
| SetWorksheetCellValueToString wsIssues, row, CISSUE_COLUMNOFFSET + index, aAnalysis.IssuesCountArray(index) | |
| End If | |
| Next index | |
| SetWorksheetCellValueToString wsIssues, row, CISSUE_COLUMNOFFSET + aAnalysis.TotalIssueTypes + 1, aAnalysis.name | |
| WriteDocIssues = row + 1 | |
| FinalExit: | |
| Exit Function | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : path " & aAnalysis.name & " : " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Sub ProcessIssuesForDAW(logWb As WorkBook, aAnalysis As DocumentAnalysis, fileName As String) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "ProcessIssuesForDAW" | |
| Dim myIssue As IssueInfo | |
| Dim issueClass As EnumDocOverallIssueClass | |
| Dim index As Integer | |
| For index = 1 To aAnalysis.Issues.count | |
| Set myIssue = aAnalysis.Issues(index) | |
| If Not isMacroIssue(myIssue) Then | |
| issueClass = getDocIssueClassification(logWb, myIssue) | |
| CountDocIssuesForDoc issueClass, aAnalysis | |
| SetOverallDocIssueClassification issueClass, aAnalysis | |
| End If | |
| Set myIssue = Nothing | |
| Next index | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : path " & aAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Function ProcessIssuesAndWriteDocIssueDetails(logWb As WorkBook, wsIssueDetails As Worksheet, DetailsRow As Long, _ | |
| aAnalysis As DocumentAnalysis, fileName As String) As Long | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "ProcessIssueAndWriteDocIssueDetails" | |
| Dim myIssue As IssueInfo | |
| Dim rowIndex As Long | |
| Dim issueClass As EnumDocOverallIssueClass | |
| Dim issueCost As Long | |
| rowIndex = DetailsRow | |
| Dim index As Integer | |
| For index = 1 To aAnalysis.Issues.count | |
| Set myIssue = aAnalysis.Issues(index) | |
| ' Process Document Issues and Costs for the Document | |
| ' Will be output to List of Documents sheet by WriteDocProperties( ) | |
| If Not isMacroIssue(myIssue) Then | |
| issueClass = getDocIssueClassification(logWb, myIssue) | |
| CountDocIssuesForDoc issueClass, aAnalysis | |
| SetOverallDocIssueClassification issueClass, aAnalysis | |
| issueCost = getDocIssueCost(logWb, aAnalysis, myIssue) | |
| aAnalysis.DocIssuesCosts = aAnalysis.DocIssuesCosts + issueCost | |
| If myIssue.Preparable Then | |
| aAnalysis.PreparableIssuesCosts = aAnalysis.PreparableIssuesCosts + issueCost | |
| End If | |
| End If | |
| 'Collate Issue and Factor counts across all Documents | |
| 'Will be output to the Issues Analyzed sheet by WriteIssueCounts( ) | |
| CollateIssueAndFactorCountsAcrossAllDocs aAnalysis, myIssue, fileName | |
| OutputCommonIssueDetails wsIssueDetails, rowIndex, aAnalysis, myIssue, fileName | |
| OutputCommonIssueAttributes wsIssueDetails, rowIndex, myIssue | |
| rowIndex = rowIndex + 1 | |
| Set myIssue = Nothing | |
| Next index | |
| ProcessIssuesAndWriteDocIssueDetails = rowIndex | |
| FinalExit: | |
| Exit Function | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : path " & aAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Function getDocIssueCost(logWb As WorkBook, aAnalysis As DocumentAnalysis, myIssue As IssueInfo) As Long | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "getDocIssueCost" | |
| Dim issueKey As String | |
| Dim ret As Long | |
| ret = 0 | |
| issueKey = getAppSpecificApplicationName & "_" & myIssue.IssueTypeXML & "_" & myIssue.SubTypeXML | |
| ret = getIssueValueFromXLSorDict(logWb, aAnalysis, mIssuesCostDict, issueKey, 1, CCOST_COL_OFFSET) | |
| FinalExit: | |
| getDocIssueCost = ret | |
| Exit Function | |
| HandleErrors: | |
| ret = 0 | |
| WriteDebug currentFunctionName & " : path " & aAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Function getMacroIssueCosts(logWb As WorkBook, aAnalysis As DocumentAnalysis) As Long | |
| 'Error handling not required | |
| getMacroIssueCosts = getVBAMacroIssueCost(logWb, aAnalysis) '+ getMacroExtRefIssueCost(logWb, aAnalysis) | |
| 'NOTE: Currently not counting External Refs as Macro Cost | |
| 'could be added if porting off Windows | |
| End Function | |
| Function getVBAMacroIssueCost(logWb As WorkBook, aAnalysis As DocumentAnalysis) As Long | |
| Const CMACRO_ROW_OFFSET_UNIQUE_LINES_COST = 4 | |
| Const CMACRO_ROW_OFFSET_USER_FORMS_COUNT_COST = 5 | |
| Const CMACRO_ROW_OFFSET_USER_FORMS_CONTROL_COUNT_COST = 6 | |
| Const CMACRO_ROW_OFFSET_USER_FORMS_CONTROL_TYPE_COUNT_COST = 7 | |
| Const CMACRO_NUM_OF_LINES_FACTOR_KEY = "_UniqueLineCount" | |
| Const CMACRO_USER_FORMS_COUNT_FACTOR_KEY = "_UserFormsCount" | |
| Const CMACRO_USER_FORMS_CONTROL_COUNT_FACTOR_KEY = "_UserFormsControlCount" | |
| Const CMACRO_USER_FORMS_CONTROL_TYPE_COUNT_FACTOR_KEY = "_UserFormsControlTypeCount" | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "getVBAMacroIssueCost" | |
| Dim baseIssueKey As String | |
| Dim ret As Long | |
| ret = 0 | |
| If Not aAnalysis.HasMacros Then GoTo FinalExit | |
| 'Fetch VBA Macro Cost Factors - if required | |
| baseIssueKey = getAppSpecificApplicationName & "_" & CSTR_ISSUE_VBA_MACROS & "_" & CSTR_SUBISSUE_PROPERTIES | |
| 'Num Lines - Costing taken from "Lines in Unique Modules" | |
| If aAnalysis.MacroTotalNumLines > 0 Then | |
| ret = ret + aAnalysis.MacroTotalNumLines * _ | |
| getValueFromXLSorDict(logWb, aAnalysis, mIssuesCostDict, _ | |
| baseIssueKey & CMACRO_NUM_OF_LINES_FACTOR_KEY, baseIssueKey, _ | |
| CMACRO_ROW_OFFSET_UNIQUE_LINES_COST, CCOST_COL_OFFSET) | |
| End If | |
| 'User Forms Count | |
| If aAnalysis.MacroNumUserForms > 0 Then | |
| ret = ret + aAnalysis.MacroNumUserForms * _ | |
| getValueFromXLSorDict(logWb, aAnalysis, mIssuesCostDict, _ | |
| baseIssueKey & CMACRO_USER_FORMS_COUNT_FACTOR_KEY, baseIssueKey, _ | |
| CMACRO_ROW_OFFSET_USER_FORMS_COUNT_COST, CCOST_COL_OFFSET) | |
| End If | |
| 'User Forms Control Count | |
| If aAnalysis.MacroNumUserFormControls > 0 Then | |
| ret = ret + aAnalysis.MacroNumUserFormControls * _ | |
| getValueFromXLSorDict(logWb, aAnalysis, mIssuesCostDict, _ | |
| baseIssueKey & CMACRO_USER_FORMS_CONTROL_COUNT_FACTOR_KEY, baseIssueKey, _ | |
| CMACRO_ROW_OFFSET_USER_FORMS_CONTROL_COUNT_COST, CCOST_COL_OFFSET) | |
| End If | |
| 'User Forms Control Type Count | |
| If aAnalysis.MacroNumUserFormControlTypes > 0 Then | |
| ret = ret + aAnalysis.MacroNumUserFormControlTypes * getValueFromXLSorDict(logWb, aAnalysis, mIssuesCostDict, _ | |
| baseIssueKey & CMACRO_USER_FORMS_CONTROL_TYPE_COUNT_FACTOR_KEY, baseIssueKey, CMACRO_ROW_OFFSET_USER_FORMS_CONTROL_TYPE_COUNT_COST, CCOST_COL_OFFSET) | |
| End If | |
| FinalExit: | |
| getVBAMacroIssueCost = ret | |
| Exit Function | |
| HandleErrors: | |
| ret = 0 | |
| WriteDebug currentFunctionName & " : path " & aAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Function getMacroExtRefIssueCost(logWb As WorkBook, aAnalysis As DocumentAnalysis) As Long | |
| Const CMACRO_ROW_OFFSET_NUM_EXTERNAL_REFS_COST = 2 | |
| Const CMACRO_NUM_EXTERNAL_REFS_FACTOR_KEY = "_ExternalRefs" | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "getMacroExtRefIssueCost" | |
| Dim baseIssueKey As String | |
| Dim ret As Long | |
| ret = 0 | |
| If aAnalysis.MacroNumExternalRefs <= 0 Then GoTo FinalExit | |
| 'Fetch External Ref Cost Factors | |
| baseIssueKey = getAppSpecificApplicationName & "_" & CSTR_ISSUE_PORTABILITY & "_" & _ | |
| CSTR_SUBISSUE_EXTERNAL_REFERENCES_IN_MACRO | |
| ret = ret + aAnalysis.MacroNumExternalRefs * _ | |
| getValueFromXLSorDict(logWb, aAnalysis, mIssuesCostDict, _ | |
| baseIssueKey & CMACRO_NUM_EXTERNAL_REFS_FACTOR_KEY, baseIssueKey, _ | |
| CMACRO_ROW_OFFSET_NUM_EXTERNAL_REFS_COST, CCOST_COL_OFFSET) | |
| FinalExit: | |
| getMacroExtRefIssueCost = ret | |
| Exit Function | |
| HandleErrors: | |
| ret = 0 | |
| WriteDebug currentFunctionName & " : path " & aAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Function getIssueValueFromXLSorDict(logWb As WorkBook, aAnalysis As DocumentAnalysis, dict As Scripting.Dictionary, _ | |
| key As String, row As Long, column As Long) As Long | |
| 'Error handling not required | |
| getIssueValueFromXLSorDict = getValueFromXLSorDict(logWb, aAnalysis, dict, key, key, row, column) | |
| End Function | |
| Function getValueFromXLSorDict(logWb As WorkBook, aAnalysis As DocumentAnalysis, dict As Scripting.Dictionary, _ | |
| dictKey As String, xlsKey As String, row As Long, column As Long) As Long | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "getValueFromXLSorDict" | |
| Dim ret As Long | |
| ret = 0 | |
| If dict.Exists(dictKey) Then | |
| ret = dict.item(dictKey) | |
| Else | |
| On Error Resume Next | |
| ret = logWb.Names(xlsKey).RefersToRange.Cells(row, column).value | |
| 'Log as error missing key | |
| If Err.Number <> 0 Then | |
| WriteDebug currentFunctionName & _ | |
| " : Issue Cost Key - " & xlsKey & ": label missing from results.xlt Costs sheet, check sheet and add/ check spelling label" & Err.Number & " " & Err.Description & " " & Err.Source | |
| WriteDebug currentFunctionName & " : dictKey " & dictKey & " : xlsKey " & xlsKey & " : " & Err.Number & " " & Err.Description & " " & Err.Source | |
| ret = 0 | |
| End If | |
| On Error GoTo HandleErrors | |
| dict.Add dictKey, ret | |
| End If | |
| FinalExit: | |
| getValueFromXLSorDict = ret | |
| Exit Function | |
| HandleErrors: | |
| ret = 0 | |
| WriteDebug currentFunctionName & " : path " & aAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Function isMacroIssue(myIssue As IssueInfo) | |
| 'Error handling not required | |
| isMacroIssue = False | |
| If myIssue.IssueTypeXML = CSTR_ISSUE_VBA_MACROS Or _ | |
| (myIssue.IssueTypeXML = CSTR_ISSUE_PORTABILITY And _ | |
| myIssue.SubTypeXML = CSTR_SUBISSUE_EXTERNAL_REFERENCES_IN_MACRO) Then | |
| isMacroIssue = True | |
| End If | |
| End Function | |
| Sub CountDocIssuesForDoc(issueClass As EnumDocOverallIssueClass, aAnalysis As DocumentAnalysis) | |
| 'Error handling not required | |
| If issueClass = enMinor Then | |
| aAnalysis.MinorIssuesCount = aAnalysis.MinorIssuesCount + 1 | |
| End If | |
| ' Macro issues are counted during analysis | |
| ' Complex issues is calculated from: mIssues.count - mMinorIssuesCount - mMacroIssuesCount | |
| End Sub | |
| Sub SetOverallDocIssueClassification(issueClass As EnumDocOverallIssueClass, aAnalysis As DocumentAnalysis) | |
| 'Error handling not required | |
| If aAnalysis.DocOverallIssueClass = enComplex Then Exit Sub | |
| If issueClass = enComplex Then | |
| aAnalysis.DocOverallIssueClass = enComplex | |
| Else | |
| aAnalysis.DocOverallIssueClass = enMinor | |
| End If | |
| End Sub | |
| Function getDocIssueClassification(logWb As WorkBook, myIssue As IssueInfo) As EnumDocOverallIssueClass | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "getDocIssueClassification" | |
| Dim issueKey As String | |
| Dim bRet As Boolean | |
| bRet = False | |
| getDocIssueClassification = enMinor | |
| issueKey = getAppSpecificApplicationName & "_" & myIssue.IssueTypeXML & "_" & myIssue.SubTypeXML | |
| If mIssuesClassificationDict.Exists(issueKey) Then | |
| bRet = mIssuesClassificationDict.item(issueKey) | |
| Else | |
| On Error Resume Next | |
| bRet = logWb.Names(issueKey).RefersToRange.Cells(1, 0).value | |
| 'Log as error missing key | |
| If Err.Number <> 0 Then | |
| WriteDebug currentFunctionName & _ | |
| " : Issue Cost Key - " & issueKey & ": label missing from results.xlt Costs sheet, check sheet and add/ check spelling label" & Err.Number & " " & Err.Description & " " & Err.Source | |
| bRet = False | |
| End If | |
| On Error GoTo HandleErrors | |
| mIssuesClassificationDict.Add issueKey, bRet | |
| End If | |
| FinalExit: | |
| If bRet Then | |
| getDocIssueClassification = enComplex | |
| End If | |
| Exit Function | |
| HandleErrors: | |
| bRet = False | |
| WriteDebug currentFunctionName & " : issueKey " & issueKey & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Function getDocOverallIssueClassificationAsString(docIssueClass As EnumDocOverallIssueClass) As String | |
| Dim Str As String | |
| 'Error handling not required | |
| Select Case docIssueClass | |
| Case enComplex | |
| Str = RID_STR_COMMON_ISSUE_CLASS_COMPLEX | |
| Case enMinor | |
| Str = RID_STR_COMMON_ISSUE_CLASS_MINOR | |
| Case Else | |
| Str = RID_STR_COMMON_ISSUE_CLASS_NONE | |
| End Select | |
| getDocOverallIssueClassificationAsString = Str | |
| End Function | |
| Public Function getDocOverallMacroClassAsString(docMacroClass As EnumDocOverallMacroClass) As String | |
| Dim Str As String | |
| 'Error handling not required | |
| Select Case docMacroClass | |
| Case enMacroComplex | |
| Str = RID_STR_COMMON_MACRO_CLASS_COMPLEX | |
| Case enMacroMedium | |
| Str = RID_STR_COMMON_MACRO_CLASS_MEDIUM | |
| Case enMacroSimple | |
| Str = RID_STR_COMMON_MACRO_CLASS_SIMPLE | |
| Case Else | |
| Str = RID_STR_COMMON_MACRO_CLASS_NONE | |
| End Select | |
| getDocOverallMacroClassAsString = Str | |
| End Function | |
| Function WriteDocRefDetails(wsRefDetails As Worksheet, DetailsRow As Long, _ | |
| aAnalysis As DocumentAnalysis, fileName As String) As Long | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "WriteDocRefDetails" | |
| Dim myIssue As IssueInfo | |
| Dim rowIndex As Long | |
| rowIndex = DetailsRow | |
| Dim index As Integer | |
| 'Output References for Docs with Macros | |
| If aAnalysis.HasMacros And (aAnalysis.References.count > 0) Then | |
| For index = 1 To aAnalysis.References.count | |
| Set myIssue = aAnalysis.References(index) | |
| OutputReferenceAttributes wsRefDetails, rowIndex, aAnalysis, myIssue, fileName | |
| rowIndex = rowIndex + 1 | |
| Set myIssue = Nothing | |
| Next index | |
| End If | |
| WriteDocRefDetails = rowIndex | |
| FinalExit: | |
| Exit Function | |
| HandleErrors: | |
| WriteDebug currentFunctionName & _ | |
| " : path " & aAnalysis.name & ": " & _ | |
| " : row " & DetailsRow & ": " & _ | |
| Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Sub OutputReferenceAttributes(wsIssueDetails As Worksheet, rowIndex As Long, _ | |
| aAnalysis As DocumentAnalysis, myIssue As IssueInfo, fileName As String) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "OutputReferenceAttributes" | |
| Dim strAttributes As String | |
| With myIssue | |
| SetWorksheetCellValueToString wsIssueDetails, rowIndex, CREF_DETDOCNAME, fileName | |
| SetWorksheetCellValueToString wsIssueDetails, rowIndex, CREF_DETDOCAPPLICATION, aAnalysis.Application | |
| strAttributes = .Values(RID_STR_COMMON_ATTRIBUTE_MAJOR) & "." & .Values(RID_STR_COMMON_ATTRIBUTE_MINOR) | |
| strAttributes = IIf(strAttributes = "0.0" Or strAttributes = ".", .Values(RID_STR_COMMON_ATTRIBUTE_NAME), _ | |
| .Values(RID_STR_COMMON_ATTRIBUTE_NAME) & " " & .Values(RID_STR_COMMON_ATTRIBUTE_MAJOR) & _ | |
| "." & .Values(RID_STR_COMMON_ATTRIBUTE_MINOR)) | |
| SetWorksheetCellValueToString wsIssueDetails, rowIndex, CREF_DETREFERENCE, strAttributes | |
| If .Values(RID_STR_COMMON_ATTRIBUTE_TYPE) = RID_STR_COMMON_ATTRIBUTE_PROJECT Then | |
| SetWorksheetCellValueToString wsIssueDetails, rowIndex, CREF_DETDESCRIPTION, RID_STR_COMMON_ATTRIBUTE_PROJECT | |
| Else | |
| SetWorksheetCellValueToString wsIssueDetails, rowIndex, CREF_DETDESCRIPTION, _ | |
| IIf(.Values(RID_STR_COMMON_ATTRIBUTE_DESCRIPTION) <> "", .Values(RID_STR_COMMON_ATTRIBUTE_DESCRIPTION), RID_STR_COMMON_NA) | |
| End If | |
| If .Values(RID_STR_COMMON_ATTRIBUTE_ISBROKEN) <> RID_STR_COMMON_ATTRIBUTE_BROKEN Then | |
| SetWorksheetCellValueToString wsIssueDetails, rowIndex, CREF_DETLOCATION, _ | |
| .Values(RID_STR_COMMON_ATTRIBUTE_FILE) | |
| Else | |
| SetWorksheetCellValueToString wsIssueDetails, rowIndex, CREF_DETLOCATION, _ | |
| RID_STR_COMMON_NA | |
| End If | |
| 'Reference Details | |
| strAttributes = RID_STR_COMMON_ATTRIBUTE_TYPE & ": " & .Values(RID_STR_COMMON_ATTRIBUTE_TYPE) & vbLf | |
| strAttributes = strAttributes & RID_STR_COMMON_ATTRIBUTE_PROPERTIES & ": " & _ | |
| .Values(RID_STR_COMMON_ATTRIBUTE_BUILTIN) & " " & .Values(RID_STR_COMMON_ATTRIBUTE_ISBROKEN) | |
| strAttributes = IIf(.Values(RID_STR_COMMON_ATTRIBUTE_GUID) <> "", _ | |
| strAttributes & vbLf & RID_STR_COMMON_ATTRIBUTE_GUID & ": " & .Values(RID_STR_COMMON_ATTRIBUTE_GUID), _ | |
| strAttributes) | |
| SetWorksheetCellValueToString wsIssueDetails, rowIndex, CREF_DETATTRIBUTES, strAttributes | |
| SetWorksheetCellValueToString wsIssueDetails, rowIndex, CREF_DETNAMEANDPATH, aAnalysis.name | |
| End With | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & _ | |
| " : path " & aAnalysis.name & ": " & _ | |
| " : rowIndex " & rowIndex & ": " & _ | |
| " : myIssue " & myIssue.IssueTypeXML & "_" & myIssue.SubTypeXML & ": " & _ | |
| Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub OutputCommonIssueAttributes(wsIssueDetails As Worksheet, rowIndex As Long, _ | |
| myIssue As IssueInfo) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "OutputCommonIssueAttributes" | |
| Dim index As Integer | |
| Dim strAttributes As String | |
| strAttributes = "" | |
| For index = 1 To myIssue.Attributes.count | |
| strAttributes = strAttributes & myIssue.Attributes(index) & " - " & _ | |
| myIssue.Values(index) | |
| strAttributes = strAttributes & IIf(index <> myIssue.Attributes.count, vbLf, "") | |
| Next index | |
| SetWorksheetCellValueToString wsIssueDetails, rowIndex, CISSUE_DETATTRIBUTES, strAttributes | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & _ | |
| " : rowIndex " & rowIndex & ": " & _ | |
| " : myIssue " & myIssue.IssueTypeXML & "_" & myIssue.SubTypeXML & ": " & _ | |
| Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| 'Store issue cost and factor costs across all documents | |
| Sub CollateIssueAndFactorCountsAcrossAllDocs(aAnalysis As DocumentAnalysis, myIssue As IssueInfo, fileName As String) | |
| Const CSTR_USER_FORM = "User Form" | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "CollateIssueAndFactorCountsAcrossAllDocs" | |
| 'Don't want to cost ISSUE_INFORMATION issues | |
| If myIssue.IssueTypeXML = CSTR_ISSUE_INFORMATION Then Exit Sub | |
| Dim issueKey As String | |
| issueKey = getAppSpecificApplicationName & "_" & myIssue.IssueTypeXML & "_" & myIssue.SubTypeXML | |
| 'Store costing metrics for Issue | |
| AddIssueAndOneToDict issueKey | |
| 'Store prepeared issue for costing metrics | |
| If myIssue.Preparable Then | |
| AddPreparedIssueAndOneToDict issueKey & "_Prepared" | |
| End If | |
| 'Additional costing Factors output for VB macros | |
| If (myIssue.IssueTypeXML = CSTR_ISSUE_VBA_MACROS) And _ | |
| (myIssue.SubTypeXML <> CSTR_SUBISSUE_MACRO_PASSWORD_PROTECTION) Then | |
| 'Unique Macro Module and Line count | |
| AddMacroModuleHashToMacroDict myIssue | |
| 'Line count | |
| AddIssueAndValToDict issueKey & "_" & CSTR_SUBISSUE_VBA_MACROS_NUMLINES, myIssue, _ | |
| RID_STR_COMMON_ATTRIBUTE_NUMBER_OF_LINES | |
| 'User From info | |
| If myIssue.SubLocation = CSTR_USER_FORM Then | |
| AddIssueAndOneToDict issueKey & "_" & CSTR_SUBISSUE_VBA_MACROS_USERFORMS_COUNT | |
| AddIssueAndValToDict issueKey & "_" & CSTR_SUBISSUE_VBA_MACROS_USERFORMS_CONTROL_COUNT, myIssue, _ | |
| RID_STR_COMMON_ATTRIBUTE_CONTROLS | |
| End If | |
| 'Additional costing Factors output for External References | |
| ElseIf (myIssue.IssueTypeXML = CSTR_ISSUE_PORTABILITY And _ | |
| myIssue.SubTypeXML = CSTR_SUBISSUE_EXTERNAL_REFERENCES_IN_MACRO) Then | |
| AddIssueAndValToDict issueKey & "_" & CSTR_SUBISSUE_EXTERNAL_REFERENCES_IN_MACRO_COUNT, myIssue, _ | |
| RID_STR_COMMON_ATTRIBUTE_NON_PORTABLE_EXTERNAL_REFERENCES_COUNT | |
| End If | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & _ | |
| " : path " & aAnalysis.name & ": " & _ | |
| " : myIssue " & myIssue.IssueTypeXML & "_" & myIssue.SubTypeXML & ": " & _ | |
| Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub OutputCommonIssueDetails(wsIssueDetails As Worksheet, rowIndex As Long, _ | |
| aAnalysis As DocumentAnalysis, myIssue As IssueInfo, fileName As String) | |
| Const CSTR_USER_FORM = "User Form" | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "OutputCommonIssueDetails" | |
| SetWorksheetCellValueToString wsIssueDetails, rowIndex, CISSUE_DETDOCNAME, fileName | |
| SetWorksheetCellValueToString wsIssueDetails, rowIndex, CISSUE_DETDOCAPPLICATION, aAnalysis.Application | |
| SetWorksheetCellValueToString wsIssueDetails, rowIndex, CISSUE_DETTYPE, myIssue.IssueType | |
| SetWorksheetCellValueToString wsIssueDetails, rowIndex, CISSUE_DETSUBTYPE, myIssue.SubType | |
| SetWorksheetCellValueToString wsIssueDetails, rowIndex, CISSUE_DETLOCATION, myIssue.Location | |
| SetWorksheetCellValueToString wsIssueDetails, rowIndex, CISSUE_DETSUBLOCATION, _ | |
| IIf(myIssue.SubLocation = "", RID_STR_COMMON_NA, myIssue.SubLocation) | |
| SetWorksheetCellValueToVariant wsIssueDetails, rowIndex, CISSUE_DETLINE, _ | |
| IIf(myIssue.Line = -1, RID_STR_COMMON_NA, myIssue.Line) | |
| SetWorksheetCellValueToString wsIssueDetails, rowIndex, CISSUE_DETCOLUMN, _ | |
| IIf(myIssue.column = "", RID_STR_COMMON_NA, myIssue.column) | |
| SetWorksheetCellValueToString wsIssueDetails, rowIndex, CISSUE_DETNAMEANDPATH, aAnalysis.name | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & _ | |
| " : path " & aAnalysis.name & ": " & _ | |
| " : rowIndex " & rowIndex & ": " & _ | |
| " : myIssue " & myIssue.IssueTypeXML & "_" & myIssue.SubTypeXML & ": " & _ | |
| Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub AddIssueAndBoolValToDict(issueKey As String, issue As IssueInfo, valKey As String) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "AddIssueAndBoolValToDict" | |
| If mIssuesDict.Exists(issueKey) Then | |
| mIssuesDict.item(issueKey) = mIssuesDict.item(issueKey) + _ | |
| IIf(issue.Values(valKey) > 0, 1, 0) | |
| Else | |
| mIssuesDict.Add issueKey, IIf(issue.Values(valKey) > 0, 1, 0) | |
| End If | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & _ | |
| " : issueKey " & issueKey & ": " & _ | |
| " : valKey " & valKey & ": " & _ | |
| Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub AddIssueAndValToDict(issueKey As String, issue As IssueInfo, valKey As String) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "AddIssueAndValToDict" | |
| If mIssuesDict.Exists(issueKey) Then | |
| mIssuesDict.item(issueKey) = mIssuesDict.item(issueKey) + issue.Values(valKey) | |
| Else | |
| mIssuesDict.Add issueKey, issue.Values(valKey) | |
| End If | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & _ | |
| " : issueKey " & issueKey & ": " & _ | |
| " : valKey " & valKey & ": " & _ | |
| Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub AddMacroModuleHashToMacroDict(issue As IssueInfo) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| Dim issueKey As String | |
| Dim issueVal As String | |
| currentFunctionName = "AddMacroModuleHashToMacroDict" | |
| issueKey = issue.Values(RID_STR_COMMON_ATTRIBUTE_SIGNATURE) | |
| If issueKey = RID_STR_COMMON_NA Then Exit Sub | |
| If Not mMacroDict.Exists(issueKey) Then | |
| mMacroDict.Add issueKey, issue.Values(RID_STR_COMMON_ATTRIBUTE_NUMBER_OF_LINES) | |
| End If | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & _ | |
| " : issueKey " & issueKey & ": " & _ | |
| Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub AddIssueAndOneToDict(key As String) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "AddIssueAndOneToDict" | |
| If mIssuesDict.Exists(key) Then | |
| mIssuesDict.item(key) = mIssuesDict.item(key) + 1 | |
| Else | |
| mIssuesDict.Add key, 1 | |
| End If | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : key " & key & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub AddPreparedIssueAndOneToDict(key As String) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "AddPreparedIssueAndOneToDict" | |
| If mPreparedIssuesDict.Exists(key) Then | |
| mPreparedIssuesDict.item(key) = mPreparedIssuesDict.item(key) + 1 | |
| Else | |
| mPreparedIssuesDict.Add key, 1 | |
| End If | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : key " & key & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Function GetExcelInstance() As Excel.Application | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "GetExcelInstance" | |
| Dim xl As Excel.Application | |
| On Error Resume Next | |
| 'Try and get an existing instance | |
| Set xl = GetObject(, "Excel.Application") | |
| If Err.Number = 429 Then | |
| Set xl = CreateObject("Excel.Application") | |
| ElseIf Err.Number <> 0 Then | |
| Set xl = Nothing | |
| MsgBox "Error: " & Err.Description | |
| Exit Function | |
| End If | |
| Set GetExcelInstance = xl | |
| Set xl = Nothing | |
| FinalExit: | |
| Exit Function | |
| HandleErrors: | |
| WriteDebug currentFunctionName & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Sub WriteOverview(logWb As WorkBook, DocCount As DocumentCount, templateCount As DocumentCount, _ | |
| macroClasses As DocMacroClassifications, issueClasses As DocIssueClassifications) | |
| Const COV_ISSUECLASS_COMPLEX = "MAW_ISSUECLASS_COMPLEX" | |
| Const COV_ISSUECLASS_MINOR = "MAW_ISSUECLASS_MINOR" | |
| Const COV_ISSUECLASS_NONE = "MAW_ISSUECLASS_NONE" | |
| Const COV_MACROCLASS_COMPLEX = "MAW_MACROCLASS_COMPLEX" | |
| Const COV_MACROCLASS_MEDIUM = "MAW_MACROCLASS_MEDIUM" | |
| Const COV_MACROCLASS_SIMPLE = "MAW_MACROCLASS_SIMPLE" | |
| Const COV_MACROCLASS_NONE = "MAW_MACROCLASS_NONE" | |
| Const COV_ISSUECOUNT_COMPLEX = "MAW_ISSUECOUNT_COMPLEX" | |
| Const COV_ISSUECOUNT_MINOR = "MAW_ISSUECOUNT_MINOR" | |
| Const COV_MODDATES_LESS3MONTHS = "MAW_MODDATES_LESS3MONTHS" | |
| Const COV_MODDATES_3TO6MONTHS = "MAW_MODDATES_3TO6MONTHS" | |
| Const COV_MODDATES_6TO12MONTHS = "MAW_MODDATES_6TO12MONTHS" | |
| Const COV_MODDATES_MORE12MONTHS = "MAW_MODDATES_MORE12MONTHS" | |
| Const COV_DOC_MIGRATION_COSTS = "Document_Migration_Costs" | |
| Const COV_DOC_PREPARABLE_COSTS = "Document_Migration_Preparable_Costs" | |
| Const COV_MACRO_MIGRATION_COSTS = "Macro_Migration_Costs" | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "WriteOverview" | |
| Dim appName As String | |
| appName = getAppSpecificApplicationName | |
| 'OV - Title | |
| SetWorkbookNameValueToString logWb, COVERVIEW_TITLE_LABEL, GetTitle | |
| SetWorkbookNameValueToVariant logWb, "AnalysisDate", Now | |
| SetWorkbookNameValueToString logWb, "AnalysisVersion", _ | |
| RID_STR_COMMON_OV_VERSION_STR & ": " & GetTitle & " " & GetVersion | |
| 'OV - Number of Documents Analyzed | |
| AddLongToWorkbookNameValue logWb, CNUMBERDOC_ALL & getAppSpecificDocExt, DocCount.numDocsAnalyzed | |
| AddLongToWorkbookNameValue logWb, CNUMBERDOC_ALL & getAppSpecificTemplateExt, templateCount.numDocsAnalyzed | |
| 'OV - Documents with Document Migration Issues (excludes macro issues) | |
| AddLongToWorkbookNameValue logWb, appName & "_" & COV_ISSUECLASS_COMPLEX, issueClasses.complex | |
| AddLongToWorkbookNameValue logWb, appName & "_" & COV_ISSUECLASS_MINOR, issueClasses.Minor | |
| AddLongToWorkbookNameValue logWb, appName & "_" & COV_ISSUECLASS_NONE, issueClasses.None | |
| 'OV - Documents with Macro Migration Issues | |
| AddLongToWorkbookNameValue logWb, appName & "_" & COV_MACROCLASS_COMPLEX, macroClasses.complex | |
| AddLongToWorkbookNameValue logWb, appName & "_" & COV_MACROCLASS_MEDIUM, macroClasses.Medium | |
| AddLongToWorkbookNameValue logWb, appName & "_" & COV_MACROCLASS_SIMPLE, macroClasses.Simple | |
| AddLongToWorkbookNameValue logWb, appName & "_" & COV_MACROCLASS_NONE, macroClasses.None | |
| 'OV - Document Modification Dates | |
| Dim modDates As DocModificationDates | |
| Call GetDocModificationDates(modDates) | |
| SetWorkbookNameValueToLong logWb, COV_MODDATES_LESS3MONTHS, modDates.lessThanThreemonths | |
| SetWorkbookNameValueToLong logWb, COV_MODDATES_3TO6MONTHS, modDates.threeToSixmonths | |
| SetWorkbookNameValueToLong logWb, COV_MODDATES_6TO12MONTHS, modDates.sixToTwelvemonths | |
| SetWorkbookNameValueToLong logWb, COV_MODDATES_MORE12MONTHS, modDates.greaterThanOneYear | |
| If InDocPreparation Then | |
| 'OV - Document Migration Issues(excludes macro issues) | |
| AddLongToWorkbookNameValue logWb, appName & "_" & COV_ISSUECOUNT_COMPLEX, _ | |
| DocCount.numComplexIssues + templateCount.numComplexIssues | |
| AddLongToWorkbookNameValue logWb, appName & "_" & COV_ISSUECOUNT_MINOR, _ | |
| DocCount.numMinorIssues + templateCount.numMinorIssues | |
| 'OV - Document Migration Costs | |
| AddLongToWorkbookNameValue logWb, appName & "_" & COV_DOC_MIGRATION_COSTS, _ | |
| DocCount.totalDocIssuesCosts + templateCount.totalDocIssuesCosts | |
| 'OV - Document Migration Preparable Costs | |
| AddLongToWorkbookNameValue logWb, COV_DOC_PREPARABLE_COSTS, _ | |
| DocCount.totalPreparableIssuesCosts + templateCount.totalPreparableIssuesCosts | |
| 'OV - Macro Migration Costs | |
| AddLongToWorkbookNameValue logWb, appName & "_" & COV_MACRO_MIGRATION_COSTS, _ | |
| DocCount.totalMacroCosts + templateCount.totalMacroCosts | |
| End If | |
| 'OV - Internal Attributes | |
| AddLongToWorkbookNameValue logWb, appName & "_" & "TotalDocsAnalysedWithIssues", _ | |
| DocCount.numDocsAnalyzedWithIssues + templateCount.numDocsAnalyzedWithIssues | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : Problem writing overview: " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub SetupDAWResultsSpreadsheet(logWb As WorkBook, fontName As String, fontSize As Long) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "SetupDAWResultsSpreadsheet" | |
| Dim bSetupRun As Boolean | |
| bSetupRun = CBool(GetWorkbookNameValueAsLong(logWb, COV_DAW_SETUP_SHEETS_RUN_LBL)) | |
| If bSetupRun Then Exit Sub | |
| 'Setup Text Boxes | |
| SetupSheetTextBox logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_MOD_DATES_COMMENT_TXB, _ | |
| RID_STR_COMMON_OV_DOC_MOD_DATES_COMMENT_TITLE, RID_STR_COMMON_OV_DOC_MOD_DATES_COMMENT_BODY, _ | |
| CCOMMENTS_FONT_SIZE, fontName | |
| SetupSheetTextBox logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_MOD_DATES_LEGEND_TXB, _ | |
| RID_STR_COMMON_OV_LEGEND_TITLE, RID_STR_COMMON_OV_DOC_MOD_DATES_LEGEND_BODY, fontSize, fontName | |
| SetupSheetTextBox logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_MACRO_COMMENT_TXB, _ | |
| RID_STR_COMMON_OV_DOC_MACRO_COMMENT_TITLE, RID_STR_COMMON_OV_DOC_MACRO_COMMENT_BODY, _ | |
| CCOMMENTS_FONT_SIZE, fontName | |
| SetupSheetTextBox logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_MACRO_LEGEND_TXB, _ | |
| RID_STR_COMMON_OV_LEGEND_TITLE, RID_STR_COMMON_OV_DOC_MACRO_LEGEND_BODY, fontSize, fontName | |
| Dim monthLimit As Long | |
| monthLimit = GetIssuesLimitInDays / CNUMDAYS_IN_MONTH | |
| SetWorkbookNameValueToString logWb, COV_HIGH_LEVEL_ANALYSIS_LBL, _ | |
| IIf(monthLimit <> CMAX_LIMIT, _ | |
| ReplaceTopicTokens(RID_STR_COMMON_OV_HIGH_LEVEL_ANALYSIS_DAW, CR_TOPIC, CStr(monthLimit)), _ | |
| RID_STR_COMMON_OV_HIGH_LEVEL_ANALYSIS_PAW_NO_LIMIT) | |
| SetupSheetTextBox logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_ANALYSIS_COMMENT_TXB, _ | |
| RID_STR_COMMON_OV_DOC_ANALYSIS_COMMENT_TITLE, RID_STR_COMMON_OV_DOC_ANALYSIS_COMMENT_BODY, _ | |
| CCOMMENTS_FONT_SIZE, fontName | |
| SetupSheetTextBox logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_ANALYSIS_LEGEND_DAW_TXB, _ | |
| RID_STR_COMMON_OV_LEGEND_TITLE, RID_STR_COMMON_OV_DOC_ANALYSIS_DAW_LEGEND_BODY, fontSize, fontName | |
| 'Setup Chart Titles | |
| SetupSheetChartTitles logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_MOD_DATES_CHART, _ | |
| RID_STR_COMMON_OV_DOC_MOD_DATES_CHART_TITLE | |
| SetupSheetChartTitles logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_MACRO_CHART, _ | |
| RID_STR_COMMON_OV_DOC_MACRO_CHART_TITLE | |
| SetupSheetChartTitles logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_ANALYSIS_CHART, _ | |
| RID_STR_COMMON_OV_DOC_ANALYSIS_CHART_TITLE | |
| 'Set selection to top cell of Overview | |
| logWb.Sheets(RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW).Range("A1").Select | |
| bSetupRun = True | |
| SetWorkbookNameValueToBoolean logWb, COV_DAW_SETUP_SHEETS_RUN_LBL, bSetupRun | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : Problem setting up spreadsheet for DAW: " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub SetupPAWResultsSpreadsheet(logWb As WorkBook, fontName As String, fontSize As Long) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "SetupPAWResultsSpreadsheet" | |
| Dim bSetupRun As Boolean | |
| bSetupRun = CBool(GetWorkbookNameValueAsLong(logWb, COV_PAW_SETUP_SHEETS_RUN_LBL)) | |
| If bSetupRun Then Exit Sub | |
| 'Costs | |
| logWb.Names(COV_COSTS_PREPISSUE_COUNT_COL_LBL).RefersToRange.EntireColumn.Hidden = False | |
| 'Setup Text Boxes | |
| SetupSheetTextBox logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_MOD_DATES_LEGEND_TXB, _ | |
| RID_STR_COMMON_OV_LEGEND_TITLE, RID_STR_COMMON_OV_DOC_MOD_DATES_LEGEND_BODY, fontSize, fontName | |
| SetupSheetTextBox logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_MACRO_LEGEND_TXB, _ | |
| RID_STR_COMMON_OV_LEGEND_TITLE, RID_STR_COMMON_OV_DOC_MACRO_LEGEND_BODY, fontSize, fontName | |
| SetWorkbookNameValueToString logWb, COV_HIGH_LEVEL_ANALYSIS_LBL, _ | |
| RID_STR_COMMON_OV_HIGH_LEVEL_ANALYSIS_PAW_NO_LIMIT | |
| SetupSheetTextBox logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_ANALYSIS_LEGEND_PAW_TXB, _ | |
| RID_STR_COMMON_OV_LEGEND_TITLE, RID_STR_COMMON_OV_DOC_ANALYSIS_PAW_LEGEND_BODY, fontSize, fontName | |
| 'Setup Chart Titles | |
| SetupSheetChartTitles logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_MOD_DATES_CHART, _ | |
| RID_STR_COMMON_OV_DOC_MOD_DATES_CHART_TITLE | |
| SetupSheetChartTitles logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_MACRO_CHART, _ | |
| RID_STR_COMMON_OV_DOC_MACRO_CHART_TITLE | |
| SetupSheetChartTitles logWb, RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW, COV_DOC_ANALYSIS_CHART, _ | |
| RID_STR_COMMON_OV_DOC_ANALYSIS_CHART_TITLE | |
| 'Set selection to top cell of Overview | |
| logWb.Sheets(RID_STR_COMMON_RESULTS_SHEET_NAME_OVERVIEW).Range("A1").Select | |
| bSetupRun = True | |
| SetWorkbookNameValueToBoolean logWb, COV_PAW_SETUP_SHEETS_RUN_LBL, bSetupRun | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : Problem setting up spreadsheet for PAW: " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub SetupPrintRanges(logWb As WorkBook, docPropRow As Long, appIssuesRow As Long, issueDetailsRow As Long, _ | |
| refDetailsRow As Long) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "SetupPrintRanges" | |
| 'Set Print Ranges | |
| If InDocPreparation Then | |
| logWb.Worksheets(RID_STR_COMMON_RESULTS_SHEET_NAME_DOCPROP).PageSetup.PrintArea = "$A1:$U" & (docPropRow + mDocPropRowOffset) | |
| logWb.Worksheets(RID_STR_COMMON_RESULTS_SHEET_NAME_DOCISSUE_DETAILS).PageSetup.PrintArea = "$A1:$J" & issueDetailsRow | |
| logWb.Worksheets(RID_STR_COMMON_RESULTS_SHEET_NAME_DOCREF_DETAILS).PageSetup.PrintArea = "$A1:$G" & refDetailsRow | |
| If getAppSpecificApplicationName = CAPPNAME_WORD Then | |
| logWb.Worksheets(RID_STR_COMMON_RESULTS_SHEET_NAME_DOCISSUES_WORD).PageSetup.PrintArea = _ | |
| "$A1:$N" & appIssuesRow | |
| ElseIf getAppSpecificApplicationName = CAPPNAME_EXCEL Then | |
| logWb.Worksheets(RID_STR_COMMON_RESULTS_SHEET_NAME_DOCISSUES_EXCEL).PageSetup.PrintArea = _ | |
| "$A1:$M" & appIssuesRow | |
| Else | |
| logWb.Worksheets(RID_STR_COMMON_RESULTS_SHEET_NAME_DOCISSUES_POWERPOINT).PageSetup.PrintArea = _ | |
| "$A1:$K" & appIssuesRow | |
| End If | |
| Else | |
| logWb.Worksheets(RID_STR_COMMON_RESULTS_SHEET_NAME_DOCPROP).PageSetup.PrintArea = "$A1:$U" & (docPropRow + mDocPropRowOffset) | |
| End If | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : Problem setting print ranges: " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub SetupSheetChartTitles(logWb As WorkBook, namedWorksheet As String, namedChart As String, _ | |
| chartTitle As String) | |
| Const CCHART_TITLE_FONT_SIZE = 11 | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "SetupSheetChartTitles" | |
| With logWb.Sheets(namedWorksheet).ChartObjects(namedChart).Chart | |
| .HasTitle = True | |
| .chartTitle.Characters.Text = chartTitle | |
| .chartTitle.Font.Size = CCHART_TITLE_FONT_SIZE | |
| End With | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & _ | |
| " namedWorkSheet: " & namedWorksheet & _ | |
| " namedChart: " & namedChart & _ | |
| " chartTitle: " & chartTitle & _ | |
| Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub SetupSheetTextBox(logWb As WorkBook, namedWorksheet As String, _ | |
| textBoxName As String, textBoxTitle As String, textBoxBody As String, _ | |
| textSize As Long, fontName As String) | |
| Const CMAX_INSERTABLE_STRING_LEN = 255 | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "SetupSheetTextBox" | |
| Dim strTextBody As String | |
| Dim allText As String | |
| strTextBody = ReplaceTopic2Tokens(textBoxBody, CR_STR, Chr(10), CR_PRODUCT, RID_STR_COMMON_OV_PRODUCT_STR) | |
| 'Setup Text Boxes | |
| logWb.Sheets(namedWorksheet).Activate | |
| logWb.Sheets(namedWorksheet).Shapes(textBoxName).Select | |
| '*** Workaround Excel bug: 213841 XL: Passed Strings Longer Than 255 Characters Are Truncated | |
| Dim I As Long | |
| logWb.Application.Selection.Text = "" | |
| logWb.Application.Selection.Characters.Text = textBoxTitle & Chr(10) | |
| With logWb.Application.Selection | |
| For I = 0 To Int(Len(strTextBody) / CMAX_INSERTABLE_STRING_LEN) | |
| .Characters(.Characters.count + 1).Text = Mid(strTextBody, _ | |
| (I * CMAX_INSERTABLE_STRING_LEN) + 1, CMAX_INSERTABLE_STRING_LEN) | |
| Next | |
| End With | |
| 'Highlight title only | |
| With logWb.Application.Selection.Characters(start:=1, Length:=Len(textBoxTitle)).Font | |
| .name = fontName | |
| .FontStyle = "Bold" | |
| .Size = textSize | |
| End With | |
| With logWb.Application.Selection.Characters(start:=Len(textBoxTitle) + 1, _ | |
| Length:=Len(strTextBody) + 1).Font | |
| .name = fontName | |
| .FontStyle = "Regular" | |
| .Size = textSize | |
| End With | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & _ | |
| " namedWorkSheet: " & namedWorksheet & _ | |
| " textBoxName: " & textBoxName & _ | |
| " textBoxTitle: " & textBoxTitle & _ | |
| " textBoxBody: " & textBoxBody & _ | |
| " textSize: " & textSize & _ | |
| Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Function GetWorkbookNameValueAsLong(logWb As WorkBook, name As String) As Long | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "GetWorkbookNameValueAsLong" | |
| GetWorkbookNameValueAsLong = logWb.Names(name).RefersToRange.Cells(1, 1).value | |
| FinalExit: | |
| Exit Function | |
| HandleErrors: | |
| GetWorkbookNameValueAsLong = 0 | |
| WriteDebug currentFunctionName & " : name " & name & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Function GetWorksheetCellValueAsLong(logWs As Worksheet, row As Long, col As Long) As Long | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "GetWorksheetCellValueAsLong" | |
| GetWorksheetCellValueAsLong = logWs.Cells(row, col).value | |
| FinalExit: | |
| Exit Function | |
| HandleErrors: | |
| WriteDebug currentFunctionName & _ | |
| " : row " & row & _ | |
| " : col " & col & _ | |
| Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Function GetWorksheetCellValueAsString(logWs As Worksheet, row As Long, col As Long) As String | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "GetWorksheetCellValueToString" | |
| GetWorksheetCellValueAsString = logWs.Cells(row, col).value | |
| FinalExit: | |
| Exit Function | |
| HandleErrors: | |
| GetWorksheetCellValueAsString = "" | |
| WriteDebug currentFunctionName & _ | |
| " : row " & row & _ | |
| " : col " & col & _ | |
| Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Sub SetWorksheetCellValueToLong(logWs As Worksheet, row As Long, col As Long, val As Long) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "SetWorksheetCellValueToLong" | |
| logWs.Cells(row, col) = val | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & _ | |
| " : row " & row & _ | |
| " : col " & col & _ | |
| " : val " & val & ": " & _ | |
| Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub SetWorksheetCellValueToInteger(logWs As Worksheet, row As Long, col As Long, intVal As Integer) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "SetWorksheetCellValueToInteger" | |
| logWs.Cells(row, col) = intVal | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & _ | |
| " : row " & row & _ | |
| " : col " & col & _ | |
| " : intVal " & intVal & ": " & _ | |
| Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub SetWorksheetCellValueToVariant(logWs As Worksheet, row As Long, col As Long, varVal As Variant) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "SetWorksheetCellValueToInteger" | |
| logWs.Cells(row, col) = varVal | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & _ | |
| " : row " & row & _ | |
| " : col " & col & _ | |
| " : varVal " & varVal & ": " & _ | |
| Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub SetWorksheetCellValueToString(logWs As Worksheet, row As Long, col As Long, strVal As String) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "SetWorksheetCellValueToString" | |
| logWs.Cells(row, col) = strVal | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & _ | |
| " : row " & row & _ | |
| " : col " & col & _ | |
| " : strVal " & strVal & ": " & _ | |
| Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub SetWorkbookNameValueToBoolean(logWb As WorkBook, name As String, bVal As Boolean) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "SetWorkbookNameValueToBoolean" | |
| logWb.Names(name).RefersToRange.Cells(1, 1) = bVal | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : name " & name & " : boolean value " & bVal & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub SetWorkbookNameValueToString(logWb As WorkBook, name As String, val As String) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "SetWorkbookNameValueToString" | |
| logWb.Names(name).RefersToRange.Cells(1, 1) = val | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : name " & name & " : value " & val & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub SetWorkbookNameValueToLong(logWb As WorkBook, name As String, val As Long) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "SetWorkbookNameValueToLong" | |
| logWb.Names(name).RefersToRange.Cells(1, 1) = val | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : name " & name & " : value " & val & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub SetWorkbookNameValueToVariant(logWb As WorkBook, name As String, val As Variant) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "SetWorkbookNameValueToVariant" | |
| logWb.Names(name).RefersToRange.Cells(1, 1) = val | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : name " & name & " : value " & val & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub AddLongToWorkbookNameValue(logWb As WorkBook, name As String, val As Long) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "AddLongToWorkbookNameValue" | |
| logWb.Names(name).RefersToRange.Cells(1, 1) = logWb.Names(name).RefersToRange.Cells(1, 1).value + val | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : name " & name & " : value " & val & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub AddVariantToWorkbookNameValue(logWb As WorkBook, name As String, varVal As Variant) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "AddVariantToWorkbookNameValue" | |
| logWb.Names(name).RefersToRange.Cells(1, 1) = logWb.Names(name).RefersToRange.Cells(1, 1).value + varVal | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : name " & name & " : value " & varVal & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub SaveAnalysisResultsVariables(logWb As WorkBook, offsetDocIssueDetailsRow As Long, _ | |
| offsetDocRefDetailsRow As Long) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "SaveAnalysisResultsVariables" | |
| 'OV - Internal Attributes | |
| SetWorkbookNameValueToLong logWb, "TotalIssuesAnalysed", offsetDocIssueDetailsRow | |
| SetWorkbookNameValueToLong logWb, "TotalRefsAnalysed", offsetDocRefDetailsRow | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : offsetDocIssueDetailsRow " & offsetDocIssueDetailsRow & _ | |
| " : offsetDocRefDetailsRow " & offsetDocRefDetailsRow & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub SetupAnalysisResultsVariables(logWb As WorkBook, _ | |
| offsetDocPropRow As Long, offsetDocIssuesRow As Long, _ | |
| offsetDocIssueDetailsRow As Long, offsetDocRefDetailsRow As Long) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "SetupAnalysisResultsVariables" | |
| offsetDocPropRow = GetWorkbookNameValueAsLong(logWb, CTOTAL_DOCS_ANALYZED) | |
| offsetDocIssueDetailsRow = GetWorkbookNameValueAsLong(logWb, "TotalIssuesAnalysed") | |
| offsetDocRefDetailsRow = GetWorkbookNameValueAsLong(logWb, "TotalRefsAnalysed") | |
| offsetDocIssuesRow = GetWorkbookNameValueAsLong(logWb, getAppSpecificApplicationName & "_" & "TotalDocsAnalysedWithIssues") | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & _ | |
| " : offsetDocPropRow " & offsetDocPropRow & _ | |
| " : offsetDocIssueDetailsRow " & offsetDocIssueDetailsRow & _ | |
| " : offsetDocRefDetailsRow " & offsetDocRefDetailsRow & _ | |
| " : offsetDocIssuesRow " & offsetDocIssuesRow & _ | |
| Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub WriteToIni(key As String, value As String) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "WriteToIni" | |
| If mIniFilePath = "" Then Exit Sub | |
| Call WritePrivateProfileString("Analysis", key, value, mIniFilePath) | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : key " & key & " : value " & value & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub WriteToLog(key As String, value As String) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "WriteToLog" | |
| If mLogFilePath = "" Then Exit Sub | |
| Dim sSection As String | |
| sSection = getAppSpecificApplicationName | |
| Call WritePrivateProfileString(sSection, key, value, mLogFilePath) | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : key " & key & " : value " & value & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub WriteDebug(value As String) | |
| On Error Resume Next 'Ignore errors in our error writing routines - could get circular dependency otherwise | |
| Static ErrCount As Long | |
| If mLogFilePath = "" Then Exit Sub | |
| Dim sSection As String | |
| sSection = getAppSpecificApplicationName & "Debug" | |
| If mDebugLevel > 0 Then | |
| Call WritePrivateProfileString(sSection, "Doc" & mDocIndex & "_debug" & ErrCount, value, mLogFilePath) | |
| ErrCount = ErrCount + 1 | |
| Else | |
| Debug.Print | |
| End If | |
| End Sub | |
| Sub WriteDebugLevelTwo(value As String) | |
| On Error Resume Next 'Ignore errors in our error writing routines - could get circular dependency otherwise | |
| Static ErrCountTwo As Long | |
| If mLogFilePath = "" Then Exit Sub | |
| Dim sSection As String | |
| sSection = getAppSpecificApplicationName & "Debug" | |
| If mDebugLevel > 1 Then | |
| Call WritePrivateProfileString(sSection, "Doc" & mDocIndex & "_debug" & ErrCountTwo, "Level2: " & value, mLogFilePath) | |
| ErrCountTwo = ErrCountTwo + 1 | |
| Else | |
| Debug.Print | |
| End If | |
| End Sub | |
| Public Function ProfileLoadDict(dict As Scripting.Dictionary, _ | |
| lpSectionName As String, _ | |
| inifile As String) As Long | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "ProfileLoadDict" | |
| Dim success As Long | |
| Dim c As Long | |
| Dim nSize As Long | |
| Dim KeyData As String | |
| Dim lpKeyName As String | |
| Dim ret As String | |
| ret = Space$(2048) | |
| nSize = Len(ret) | |
| success = GetPrivateProfileString( _ | |
| lpSectionName, vbNullString, "", ret, nSize, inifile) | |
| If success Then | |
| ret = Left$(ret, success) | |
| Do Until ret = "" | |
| lpKeyName = StripNulls(ret) | |
| KeyData = ProfileGetItem( _ | |
| lpSectionName, lpKeyName, "", inifile) | |
| dict.Add lpKeyName, KeyData | |
| Loop | |
| End If | |
| ProfileLoadDict = dict.count | |
| FinalExit: | |
| Exit Function | |
| HandleErrors: | |
| WriteDebug currentFunctionName & _ | |
| " : dict.Count " & dict.count & _ | |
| " : lpSectionName " & lpSectionName & _ | |
| " : inifile " & inifile & _ | |
| Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Private Function StripNulls(startStrg As String) As String | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "StripNulls" | |
| Dim pos As Long | |
| Dim item As String | |
| pos = InStr(1, startStrg, Chr$(0)) | |
| If pos Then | |
| item = Mid$(startStrg, 1, pos - 1) | |
| startStrg = Mid$(startStrg, pos + 1, Len(startStrg)) | |
| StripNulls = item | |
| End If | |
| FinalExit: | |
| Exit Function | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : startStrg " & startStrg & " : " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Public Function ProfileGetItem(lpSectionName As String, _ | |
| lpKeyName As String, _ | |
| defaultValue As String, _ | |
| inifile As String) As String | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "ProfileGetItem" | |
| Dim success As Long | |
| Dim nSize As Long | |
| Dim ret As String | |
| ret = Space$(2048) | |
| nSize = Len(ret) | |
| success = GetPrivateProfileString(lpSectionName, _ | |
| lpKeyName, _ | |
| defaultValue, _ | |
| ret, _ | |
| nSize, _ | |
| inifile) | |
| If success Then | |
| ProfileGetItem = Left$(ret, success) | |
| Else | |
| ProfileGetItem = defaultValue | |
| End If | |
| FinalExit: | |
| Exit Function | |
| HandleErrors: | |
| WriteDebug currentFunctionName & _ | |
| " : lpSectionName " & lpSectionName & _ | |
| " : lpKeyName " & lpKeyName & _ | |
| " : defaultValue " & defaultValue & _ | |
| " : inifile " & inifile & _ | |
| Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Public Function GetDefaultPassword() As String | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "GetDefaultPassword" | |
| Static myPassword As String | |
| If myPassword = "" Then | |
| myPassword = ProfileGetItem("Analysis", CDEFAULT_PASSWORD, "", mIniFilePath) | |
| End If | |
| GetDefaultPassword = myPassword | |
| FinalExit: | |
| Exit Function | |
| HandleErrors: | |
| WriteDebug currentFunctionName & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Public Function GetVersion() As String | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "GetVersion" | |
| Static myVersion As String | |
| If myVersion = "" Then | |
| myVersion = ProfileGetItem("Analysis", CVERSION, "", mIniFilePath) | |
| End If | |
| GetVersion = myVersion | |
| FinalExit: | |
| Exit Function | |
| HandleErrors: | |
| WriteDebug currentFunctionName & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Public Function GetTitle() As String | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "GetTitle" | |
| Static myTitle As String | |
| If myTitle = "" Then | |
| myTitle = ProfileGetItem("Analysis", CTITLE, RID_STR_COMMON_ANALYSIS_STR, mIniFilePath) | |
| End If | |
| GetTitle = myTitle | |
| FinalExit: | |
| Exit Function | |
| HandleErrors: | |
| WriteDebug currentFunctionName & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Sub SetPrepareToNone() | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "SetPrepareToNone" | |
| Call WritePrivateProfileString("Analysis", CDOPREPARE, CStr(0), mIniFilePath) | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Function CheckForAbort() As Boolean | |
| Dim currentFunctionName As String | |
| Dim bAbort As Boolean | |
| currentFunctionName = "CheckForAbort" | |
| bAbort = False | |
| On Error GoTo HandleErrors | |
| bAbort = CBool(ProfileGetItem("Analysis", C_ABORT_ANALYSIS, "false", mIniFilePath)) | |
| 'reset the flag | |
| If (bAbort) Then Call WriteToIni(C_ABORT_ANALYSIS, "false") | |
| FinalExit: | |
| CheckForAbort = bAbort | |
| Exit Function | |
| HandleErrors: | |
| WriteDebug currentFunctionName & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Function CheckDoPrepare() As Boolean | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "CheckDoPrepare" | |
| Static bDoPrepare As Boolean | |
| Static myDoPrepare As String | |
| If myDoPrepare = "" Then | |
| bDoPrepare = CBool(ProfileGetItem("Analysis", _ | |
| CDOPREPARE, "False", mIniFilePath)) | |
| myDoPrepare = "OK" | |
| End If | |
| CheckDoPrepare = bDoPrepare | |
| FinalExit: | |
| Exit Function | |
| HandleErrors: | |
| WriteDebug currentFunctionName & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Function GetIssuesLimitInDays() As Long | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "GetIssuesLimitInDays" | |
| Static issuesLimit As Long | |
| Static myDoPrepare As String | |
| If issuesLimit = 0 Then | |
| issuesLimit = CLng(ProfileGetItem("Analysis", _ | |
| CISSUES_LIMIT, CMAX_LIMIT, mIniFilePath)) * CNUMDAYS_IN_MONTH | |
| End If | |
| GetIssuesLimitInDays = issuesLimit | |
| FinalExit: | |
| Exit Function | |
| HandleErrors: | |
| WriteDebug currentFunctionName & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Public Sub AddIssueDetailsNote(myIssue As IssueInfo, noteNum As Long, noteStr As String, _ | |
| Optional preStr As String) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "AddIssueDetailsNote" | |
| If IsMissing(preStr) Then | |
| preStr = RID_STR_COMMON_NOTE_PRE | |
| End If | |
| myIssue.Attributes.Add preStr & "[" & noteNum & "]" | |
| myIssue.Values.Add noteStr | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : noteNum " & noteNum & " : noteStr " & noteStr & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Public Sub SetupWizardVariables( _ | |
| fileList As String, storeToDir As String, resultsFile As String, _ | |
| logFile As String, resultsTemplate As String, bOverwriteFile As Boolean, _ | |
| bNewResultsFile As Boolean, statFileName As String, debugLevel As Long, _ | |
| outputType As String, singleFile As String) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "SetupWizardVariables" | |
| If mIniFilePath = "" Then | |
| mIniFilePath = GetAppDataFolder & "\Sun\AnalysisWizard\" & CWIZARD & ".ini" | |
| End If | |
| statFileName = ProfileGetItem("Analysis", CSTAT_FILE, "", mIniFilePath) | |
| fileList = ProfileGetItem("Analysis", CFILE_LIST, "", mIniFilePath) | |
| storeToDir = ProfileGetItem("Analysis", COUTPUT_DIR, "", mIniFilePath) | |
| resultsFile = ProfileGetItem("Analysis", CRESULTS_FILE, "", mIniFilePath) | |
| logFile = ProfileGetItem("Analysis", CLOG_FILE, "", mIniFilePath) | |
| resultsTemplate = ProfileGetItem("Analysis", CRESULTS_TEMPLATE, "", mIniFilePath) | |
| bOverwriteFile = IIf(ProfileGetItem("Analysis", CRESULTS_EXIST, COVERWRITE_FILE, mIniFilePath) = COVERWRITE_FILE, _ | |
| True, False) | |
| bNewResultsFile = CBool(ProfileGetItem("Analysis", CNEW_RESULTS_FILE, "True", mIniFilePath)) | |
| debugLevel = CLng(ProfileGetItem("Analysis", CDEBUG_LEVEL, "1", mIniFilePath)) | |
| outputType = ProfileGetItem("Analysis", COUTPUT_TYPE, COUTPUT_TYPE_XLS, mIniFilePath) | |
| singleFile = ProfileGetItem("Analysis", CSINGLE_FILE, "", mIniFilePath) | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & _ | |
| ": mIniFilePath " & mIniFilePath & ": " & _ | |
| Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Public Sub SetupSearchTypes(searchTypes As Collection) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "SetupSearchTypes" | |
| Dim bDocument As Boolean | |
| Dim bTemplate As Boolean | |
| bDocument = CBool(ProfileGetItem("Analysis", LCase("type" & getAppSpecificApplicationName & "doc"), "False", mIniFilePath)) | |
| bTemplate = CBool(ProfileGetItem("Analysis", LCase("type" & getAppSpecificApplicationName & "dot"), "False", mIniFilePath)) | |
| If bDocument = True Then searchTypes.Add "*" & getAppSpecificDocExt | |
| If bTemplate = True Then searchTypes.Add "*" & getAppSpecificTemplateExt | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & ": searchTypes.Count " & searchTypes.count & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub WriteXMLHeader(out As TextStream) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "WriteXMLHeader" | |
| out.WriteLine "<?xml version=""1.0"" encoding=""ISO-8859-1""?>" | |
| out.WriteLine "<!DOCTYPE results SYSTEM 'analysis.dtd'>" | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub WriteXMLResultsStartTag(out As TextStream) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "WriteXMLResultsStartTag" | |
| out.WriteLine "<results generated-by=""" & IIf(InDocPreparation, "documentanalysis_preparation", "documentanalysis") & """" | |
| out.WriteLine " version=""" & GetVersion & """ timestamp=""" & Now & """" | |
| out.WriteLine " type=""" & getAppSpecificApplicationName & """ >" | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub WriteXMLResultsEndTag(out As TextStream) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "WriteXMLResultsEndTag" | |
| out.WriteLine "</results>" | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub WriteXMLDocProperties(out As TextStream, aAnalysis As DocumentAnalysis) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "WriteXMLDocProperties" | |
| out.WriteLine "<document location=""" & EncodeXML(aAnalysis.name) & """" | |
| out.WriteLine " application=""" & aAnalysis.Application & """" | |
| out.WriteLine " issues-count=""" & (aAnalysis.IssuesCount) & """" | |
| out.WriteLine " pages=""" & aAnalysis.PageCount & """" | |
| out.WriteLine " created=""" & CheckDate(aAnalysis.Created) & """" | |
| out.WriteLine " modified=""" & CheckDate(aAnalysis.Modified) & """" | |
| out.WriteLine " accessed=""" & CheckDate(aAnalysis.Accessed) & """" | |
| out.WriteLine " printed=""" & CheckDate(aAnalysis.Printed) & """" | |
| out.WriteLine " last-save-by=""" & aAnalysis.SavedBy & """" | |
| out.WriteLine " revision=""" & aAnalysis.Revision & """" | |
| out.WriteLine " based-on-template=""" & EncodeXML(aAnalysis.Template) & """" | |
| out.WriteLine ">" | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : path " & aAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub WriteXMLDocPropertiesEndTag(out As TextStream) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "WriteXMLDocPropertiesEndTag" | |
| out.WriteLine "</document>" | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub WriteXMLDocRefDetails(out As TextStream, aAnalysis As DocumentAnalysis) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "WriteXMLDocRefDetails" | |
| Dim myIssue As IssueInfo | |
| 'Output References for Docs with Macros | |
| If aAnalysis.HasMacros And (aAnalysis.References.count > 0) Then | |
| out.WriteLine "<references>" | |
| For Each myIssue In aAnalysis.References | |
| OutputXMLReferenceAttributes out, aAnalysis, myIssue | |
| Next myIssue | |
| out.WriteLine "</references>" | |
| End If | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : path " & aAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub OutputXMLReferenceAttributes(out As TextStream, aAnalysis As DocumentAnalysis, myIssue As IssueInfo) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "OutputXMLReferenceAttributes" | |
| Dim strAttributes As String | |
| With myIssue | |
| out.WriteLine "<reference" | |
| strAttributes = .Values("Major") & "." & .Values("Minor") | |
| strAttributes = IIf(strAttributes = "0.0" Or strAttributes = ".", .Values("Name"), _ | |
| .Values("Name") & " " & .Values("Major") & "." & .Values("Minor")) | |
| out.WriteLine " name=""" & EncodeXML(strAttributes) & """" | |
| If .Values("Type") = "Project" Then | |
| strAttributes = "Project reference" | |
| Else | |
| strAttributes = IIf(.Values("Description") <> "", .Values("Description"), RID_STR_COMMON_NA) | |
| End If | |
| out.WriteLine " description=""" & EncodeXML(strAttributes) & """" | |
| If .Values("IsBroken") <> RID_STR_COMMON_ATTRIBUTE_BROKEN Then | |
| out.WriteLine " location=""" & .Values("File") & """" | |
| End If | |
| out.WriteLine " type=""" & .Values("Type") & """" | |
| strAttributes = IIf(.Values("GUID") <> "", .Values("GUID"), RID_STR_COMMON_NA) | |
| out.WriteLine " GUID=""" & strAttributes & """" | |
| out.WriteLine " is-broken=""" & .Values("IsBroken") & """" | |
| out.WriteLine " builtin=""" & .Values("BuiltIn") & """" | |
| out.WriteLine " />" | |
| End With | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : path " & aAnalysis.name & " : myIssue " & myIssue.IssueTypeXML & "_" & myIssue.SubTypeXML & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub WriteXMLDocIssueDetails(out As TextStream, aAnalysis As DocumentAnalysis) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "WriteXMLDocIssueDetails" | |
| Dim myIssue As IssueInfo | |
| If aAnalysis.Issues.count = 0 Then Exit Sub | |
| out.WriteLine "<issues>" | |
| For Each myIssue In aAnalysis.Issues | |
| OutputXMLCommonIssueDetails out, aAnalysis, myIssue | |
| OutputXMLCommonIssueAttributes out, myIssue | |
| out.WriteLine "</issue>" | |
| Next myIssue | |
| out.WriteLine "</issues>" | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : path " & aAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub OutputXMLCommonIssueDetails(out As TextStream, aAnalysis As DocumentAnalysis, myIssue As IssueInfo) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "OutputXMLCommonIssueDetails" | |
| out.WriteLine "<issue category=""" & myIssue.IssueTypeXML & """" | |
| out.WriteLine " type=""" & myIssue.SubTypeXML & """" | |
| 'NOTE: Dropping severity - now stored in results.xlt, do not want to open it to fetch this data | |
| 'out.WriteLine " severity=""" & IIf(CheckForMinorIssue(aAnalysis, myIssue), "Minor", "Major") & """" | |
| out.WriteLine " prepared=""" & IIf((myIssue.Preparable), "True", "False") & """ >" | |
| out.WriteLine "<location type=""" & myIssue.locationXML & """ >" | |
| If myIssue.SubLocation <> "" Then | |
| out.WriteLine "<property name=""sublocation"" value=""" & myIssue.SubLocation & """ />" | |
| End If | |
| If myIssue.Line <> -1 Then | |
| out.WriteLine "<property name=""line"" value=""" & myIssue.Line & """ />" | |
| End If | |
| If myIssue.column <> "" Then | |
| out.WriteLine "<property name=""column"" value=""" & myIssue.column & """ />" | |
| End If | |
| out.WriteLine "</location>" | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : path " & aAnalysis.name & " : myIssue " & myIssue.IssueTypeXML & "_" & myIssue.SubTypeXML & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub OutputXMLCommonIssueAttributes(out As TextStream, myIssue As IssueInfo) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "OutputXMLCommonIssueAttributes" | |
| Dim index As Integer | |
| Dim valStr As String | |
| Dim attStr As String | |
| If myIssue.Attributes.count = 0 Then Exit Sub | |
| out.WriteLine "<details>" | |
| For index = 1 To myIssue.Attributes.count | |
| attStr = myIssue.Attributes(index) | |
| If InStr(attStr, RID_STR_COMMON_NOTE_PRE & "[") = 1 Then | |
| attStr = Right$(attStr, Len(attStr) - Len(RID_STR_COMMON_NOTE_PRE & "[")) | |
| attStr = Left$(attStr, Len(attStr) - 1) | |
| out.WriteLine "<note index=""" & attStr & """ value=""" & EncodeXML(myIssue.Values(index)) & """ />" | |
| Else | |
| out.WriteLine "<property name=""" & EncodeXML(myIssue.Attributes(index)) & """ value=""" & EncodeXML(myIssue.Values(index)) & """ />" | |
| End If | |
| Next index | |
| out.WriteLine "</details>" | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : myIssue " & myIssue.IssueTypeXML & "_" & myIssue.SubTypeXML & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Sub WriteXMLOutput(storeToDir As String, resultsFile As String, _ | |
| bOverwriteResultsFile As Boolean, bNewResultsFile As Boolean, AnalysedDocs As Collection, _ | |
| fso As Scripting.FileSystemObject) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "WriteXMLOutput" | |
| Dim xmlOutput As TextStream | |
| Dim xmlOrigOutput As TextStream | |
| Dim origOutput As String | |
| Dim analysis As DocumentAnalysis | |
| Dim outFilePath As String | |
| outFilePath = storeToDir & "\" & fso.GetBaseName(resultsFile) & "_" & _ | |
| getAppSpecificApplicationName & ".xml" | |
| Set xmlOutput = fso.CreateTextFile(outFilePath, True) | |
| WriteXMLHeader xmlOutput | |
| 'Set xmlOrigOutput = fso.OpenTextFile(outFilePath, ForReading) | |
| 'Set xmlOutput = fso.OpenTextFile(outFilePath, ForWriting) | |
| WriteXMLResultsStartTag xmlOutput | |
| For Each analysis In AnalysedDocs | |
| WriteXMLDocProperties xmlOutput, analysis | |
| WriteXMLDocRefDetails xmlOutput, analysis | |
| WriteXMLDocIssueDetails xmlOutput, analysis | |
| WriteXMLDocPropertiesEndTag xmlOutput | |
| Next analysis | |
| WriteXMLResultsEndTag xmlOutput | |
| FinalExit: | |
| xmlOutput.Close | |
| Set xmlOutput = Nothing | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : path " & outFilePath & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub | |
| Private Function EncodeUrl(ByVal sUrl As String) As String | |
| Const MAX_PATH As Long = 260 | |
| Const ERROR_SUCCESS As Long = 0 | |
| Const URL_DONT_SIMPLIFY As Long = &H8000000 | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "EncodeUrl" | |
| Dim sUrlEsc As String | |
| Dim dwSize As Long | |
| Dim dwFlags As Long | |
| If Len(sUrl) > 0 Then | |
| sUrlEsc = Space$(MAX_PATH) | |
| dwSize = Len(sUrlEsc) | |
| dwFlags = URL_DONT_SIMPLIFY | |
| If UrlEscape(sUrl, _ | |
| sUrlEsc, _ | |
| dwSize, _ | |
| dwFlags) = ERROR_SUCCESS Then | |
| EncodeUrl = Left$(sUrlEsc, dwSize) | |
| End If 'If UrlEscape | |
| End If 'If Len(sUrl) > 0 | |
| FinalExit: | |
| Exit Function | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : sUrl " & sUrl & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Private Function EncodeXML(Str As String) As String | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "EncodeXML" | |
| Str = Replace(Str, "^", "^") | |
| Str = Replace(Str, "&", "&") | |
| Str = Replace(Str, "`", "'") | |
| Str = Replace(Str, "{", "{") | |
| Str = Replace(Str, "}", "}") | |
| Str = Replace(Str, "|", "|") | |
| Str = Replace(Str, "]", "]") | |
| Str = Replace(Str, "[", "[") | |
| Str = Replace(Str, """", """) | |
| Str = Replace(Str, "<", "<") | |
| Str = Replace(Str, ">", ">") | |
| 'str = Replace(str, "\", "\") | |
| 'str = Replace(str, "#", "#") | |
| 'str = Replace(str, "?", "?") | |
| 'str = Replace(str, "/", "/") | |
| EncodeXML = Str | |
| FinalExit: | |
| Exit Function | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : string " & Str & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Function ReplaceTopicTokens(sString As String, _ | |
| sToken As String, _ | |
| sReplacement As String) As String | |
| On Error Resume Next | |
| Dim p As Integer | |
| Dim sTmp As String | |
| sTmp = sString | |
| Do | |
| p = InStr(sTmp, sToken) | |
| If p Then | |
| sTmp = Left(sTmp, p - 1) + sReplacement + Mid(sTmp, p + Len(sToken)) | |
| End If | |
| Loop While p > 0 | |
| ReplaceTopicTokens = sTmp | |
| End Function | |
| Function ReplaceTopic2Tokens(sString As String, _ | |
| sToken1 As String, _ | |
| sReplacement1 As String, _ | |
| sToken2 As String, _ | |
| sReplacement2 As String) As String | |
| On Error Resume Next | |
| ReplaceTopic2Tokens = _ | |
| ReplaceTopicTokens(ReplaceTopicTokens(sString, sToken1, sReplacement1), _ | |
| sToken2, sReplacement2) | |
| End Function | |
| 'Language setting functions | |
| Function GetResourceDataFileName(thisDir As String) As String | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "GetResourceDataFileName" | |
| Dim fso As FileSystemObject | |
| Set fso = New FileSystemObject | |
| 'A debug method - if a file called debug.dat exists load it. | |
| If fso.FileExists(fso.GetAbsolutePathName(thisDir & "\debug.dat")) Then | |
| GetResourceDataFileName = fso.GetAbsolutePathName(thisDir & "\debug.dat") | |
| GoTo FinalExit | |
| End If | |
| Dim isoLangStr As String | |
| Dim isoCountryStr As String | |
| Dim langDir As String | |
| langDir = thisDir & "\" & "lang" | |
| Dim userLCID As Long | |
| userLCID = GetUserDefaultLangID() | |
| Dim sysLCID As Long | |
| sysLCID = GetSystemDefaultLangID() | |
| isoLangStr = GetUserLocaleInfo(userLCID, LOCALE_SISO639LANGNAME) | |
| isoCountryStr = GetUserLocaleInfo(userLCID, LOCALE_SISO3166CTRYNAME) | |
| 'check for locale data in following order: | |
| ' user language | |
| ' isoLangStr & "_" & isoCountryStr & ".dat" | |
| ' isoLangStr & ".dat" | |
| ' system language | |
| ' isoLangStr & "_" & isoCountryStr & ".dat" | |
| ' isoLangStr & ".dat" | |
| ' "en_US" & ".dat" | |
| If fso.FileExists(fso.GetAbsolutePathName(langDir & "\" & isoLangStr & "-" & isoCountryStr & ".dat")) Then | |
| GetResourceDataFileName = fso.GetAbsolutePathName(langDir & "\" & isoLangStr & "-" & isoCountryStr & ".dat") | |
| ElseIf fso.FileExists(fso.GetAbsolutePathName(langDir & "\" & isoLangStr & ".dat")) Then | |
| GetResourceDataFileName = fso.GetAbsolutePathName(langDir & "\" & isoLangStr & ".dat") | |
| Else | |
| isoLangStr = GetUserLocaleInfo(sysLCID, LOCALE_SISO639LANGNAME) | |
| isoCountryStr = GetUserLocaleInfo(sysLCID, LOCALE_SISO3166CTRYNAME) | |
| If fso.FileExists(fso.GetAbsolutePathName(langDir & "\" & isoLangStr & "-" & isoCountryStr & ".dat")) Then | |
| GetResourceDataFileName = fso.GetAbsolutePathName(langDir & "\" & isoLangStr & "-" & isoCountryStr & ".dat") | |
| ElseIf fso.FileExists(fso.GetAbsolutePathName(langDir & "\" & isoLangStr & ".dat")) Then | |
| GetResourceDataFileName = fso.GetAbsolutePathName(langDir & "\" & isoLangStr & ".dat") | |
| Else | |
| GetResourceDataFileName = fso.GetAbsolutePathName(langDir & "\" & "en-US.dat") | |
| End If | |
| End If | |
| FinalExit: | |
| Set fso = Nothing | |
| Exit Function | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| Public Function GetUserLocaleInfo(ByVal dwLocaleID As Long, ByVal dwLCType As Long) As String | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "GetUserLocaleInfo" | |
| Dim sReturn As String | |
| Dim r As Long | |
| 'call the function passing the Locale type | |
| 'variable to retrieve the required size of | |
| 'the string buffer needed | |
| r = GetLocaleInfo(dwLocaleID, dwLCType, sReturn, Len(sReturn)) | |
| 'if successful.. | |
| If r Then | |
| 'pad the buffer with spaces | |
| sReturn = Space$(r) | |
| 'and call again passing the buffer | |
| r = GetLocaleInfo(dwLocaleID, dwLCType, sReturn, Len(sReturn)) | |
| 'if successful (r > 0) | |
| If r Then | |
| 'r holds the size of the string | |
| 'including the terminating null | |
| GetUserLocaleInfo = Left$(sReturn, r - 1) | |
| End If | |
| End If | |
| FinalExit: | |
| Exit Function | |
| HandleErrors: | |
| WriteDebug currentFunctionName & ": " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Function | |
| ' This function returns the Application Data Folder Path | |
| Function GetAppDataFolder() As String | |
| Dim idlstr As Long | |
| Dim sPath As String | |
| Dim IDL As ITEMIDLIST | |
| Const NOERROR = 0 | |
| Const MAX_LENGTH = 260 | |
| Const CSIDL_APPDATA = &H1A | |
| On Error GoTo Err_GetFolder | |
| ' Fill the idl structure with the specified folder item. | |
| idlstr = SHGetSpecialFolderLocation(0, CSIDL_APPDATA, IDL) | |
| If idlstr = NOERROR Then | |
| ' Get the path from the idl list, and return | |
| ' the folder with a slash at the end. | |
| sPath = Space$(MAX_LENGTH) | |
| idlstr = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath) | |
| If idlstr Then | |
| GetAppDataFolder = Left$(sPath, InStr(sPath, Chr$(0)) - 1) | |
| End If | |
| End If | |
| Exit_GetFolder: | |
| Exit Function | |
| Err_GetFolder: | |
| MsgBox "An Error was Encountered" & Chr(13) & Err.Description, _ | |
| vbCritical Or vbOKOnly | |
| Resume Exit_GetFolder | |
| End Function | |
| Sub WriteToStatFile(statFileName As String, statValue As Integer, _ | |
| currDocument As String, fso As Scripting.FileSystemObject) | |
| On Error Resume Next | |
| Dim fileCont As TextStream | |
| Set fileCont = fso.OpenTextFile(statFileName, ForWriting, True, TristateTrue) | |
| If (statValue = C_STAT_STARTING) Then | |
| fileCont.WriteLine ("analysing=" & currDocument) | |
| ElseIf (statValue = C_STAT_DONE) Then | |
| fileCont.WriteLine ("analysed=" & currDocument) | |
| ElseIf (statValue = C_STAT_FINISHED) Then | |
| fileCont.WriteLine ("finished") | |
| End If | |
| fileCont.Close | |
| End Sub | |
| ' The function FindIndex looks for a document in the given document list | |
| ' starting at the position lastIndex in that list. If the document could | |
| ' not be found, the function starts searching from the beginning | |
| Function FindIndex(myDocument As String, _ | |
| myDocList As Collection, _ | |
| lastIndex As Long) As Long | |
| Dim lastEntry As Long | |
| Dim curIndex As Long | |
| Dim curEntry As String | |
| Dim entryFound As Boolean | |
| entryFound = False | |
| lastEntry = myDocList.count | |
| If (lastIndex > lastEntry) Then lastIndex = lastEntry | |
| If (lastIndex > 1) Then | |
| curIndex = lastIndex | |
| Else | |
| curIndex = 1 | |
| End If | |
| While Not entryFound And curIndex <= lastEntry | |
| curEntry = myDocList.item(curIndex) | |
| If (curEntry = myDocument) Then | |
| entryFound = True | |
| Else | |
| curIndex = curIndex + 1 | |
| End If | |
| Wend | |
| If (Not entryFound) Then | |
| curIndex = 1 | |
| While Not entryFound And curIndex < lastIndex | |
| curEntry = myDocList.item(curIndex) | |
| If (curEntry = myDocument) Then | |
| entryFound = True | |
| Else | |
| curIndex = curIndex + 1 | |
| End If | |
| Wend | |
| End If | |
| If entryFound Then | |
| FindIndex = curIndex | |
| Else | |
| FindIndex = 0 | |
| End If | |
| End Function | |
| ' The sub GetIndexValues calulates the start index of the analysis and the index | |
| ' of the file after which the next intermediate reult will be written | |
| Function GetIndexValues(startIndex As Long, nextCheck As Long, _ | |
| myFiles As Collection) As Boolean | |
| Dim lastCheckpoint As String | |
| Dim nextFile As String | |
| Dim newResultsFile As Boolean | |
| lastCheckpoint = ProfileGetItem(C_ANALYSIS, C_LAST_CHECKPOINT, "", mIniFilePath) | |
| nextFile = ProfileGetItem(C_ANALYSIS, C_NEXT_FILE, "", mIniFilePath) | |
| newResultsFile = True | |
| If (nextFile = "") Then | |
| ' No Analysis done yet | |
| startIndex = 1 | |
| nextCheck = C_MAX_CHECK | |
| Else | |
| If (lastCheckpoint = "") Then | |
| startIndex = 1 | |
| Else | |
| startIndex = FindIndex(lastCheckpoint, myFiles, 1) + 1 | |
| If (startIndex > 0) Then newResultsFile = False | |
| End If | |
| nextCheck = FindIndex(nextFile, myFiles, startIndex - 1) | |
| If (nextCheck = 0) Then ' Next file not in file list, restarting | |
| startIndex = 1 | |
| nextCheck = C_MAX_CHECK | |
| newResultsFile = True | |
| ElseIf (nextCheck < startIndex) Then 'we are done? | |
| nextCheck = startIndex + C_MAX_CHECK | |
| ElseIf (nextCheck = startIndex) Then 'skip this one | |
| WriteToLog C_ERROR_HANDLING_DOC & nextCheck, nextFile | |
| startIndex = startIndex + 1 | |
| nextCheck = startIndex + C_MAX_CHECK | |
| Else 'last time an error occured with that file, write before analysing | |
| nextCheck = nextCheck - 1 | |
| End If | |
| End If | |
| GetIndexValues = newResultsFile | |
| End Function | |
| Private Sub GetDocModificationDates(docCounts As DocModificationDates) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "GetDocModificationDates" | |
| docCounts.lessThanThreemonths = CLng(ProfileGetItem("Analysis", C_DOCS_LESS_3_MONTH, "0", mIniFilePath)) | |
| docCounts.threeToSixmonths = CLng(ProfileGetItem("Analysis", C_DOCS_LESS_6_MONTH, "0", mIniFilePath)) | |
| docCounts.sixToTwelvemonths = CLng(ProfileGetItem("Analysis", C_DOCS_LESS_12_MONTH, "0", mIniFilePath)) | |
| docCounts.greaterThanOneYear = CLng(ProfileGetItem("Analysis", C_DOCS_MORE_12_MONTH, "0", mIniFilePath)) | |
| FinalExit: | |
| Exit Sub | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source | |
| Resume FinalExit | |
| End Sub |