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 = "" Const CR_TOPIC = "" Const CR_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 "" out.WriteLine "" 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 "" 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 "" 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 "" 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 "" 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 "" For Each myIssue In aAnalysis.References OutputXMLReferenceAttributes out, aAnalysis, myIssue Next myIssue out.WriteLine "" 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 " "", .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 "" For Each myIssue In aAnalysis.Issues OutputXMLCommonIssueDetails out, aAnalysis, myIssue OutputXMLCommonIssueAttributes out, myIssue out.WriteLine "" Next myIssue out.WriteLine "" 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 "" out.WriteLine "" If myIssue.SubLocation <> "" Then out.WriteLine "" End If If myIssue.Line <> -1 Then out.WriteLine "" End If If myIssue.column <> "" Then out.WriteLine "" End If out.WriteLine "" 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 "
" 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 "" Else out.WriteLine "" End If Next index out.WriteLine "
" 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