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