diff options
Diffstat (limited to 'migrationanalysis/src/driver_docs/sources/CommonMigrationAnalyser.bas')
| -rw-r--r-- | migrationanalysis/src/driver_docs/sources/CommonMigrationAnalyser.bas | 1119 |
1 files changed, 1119 insertions, 0 deletions
diff --git a/migrationanalysis/src/driver_docs/sources/CommonMigrationAnalyser.bas b/migrationanalysis/src/driver_docs/sources/CommonMigrationAnalyser.bas new file mode 100644 index 000000000000..5fae03a4d399 --- /dev/null +++ b/migrationanalysis/src/driver_docs/sources/CommonMigrationAnalyser.bas @@ -0,0 +1,1119 @@ +Attribute VB_Name = "CommonMigrationAnalyser"
+'/*************************************************************************
+' *
+' 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
+
+
+'***********************************************
+'**** APPLICATION COMMON ANALYSIS FUNCTIONS ****
+'***********************************************
+
+'** Common - XML Issue and SubIssue strings
+'For preparation - need access to some Word/ Excel or PP consts
+Public Const CSTR_ISSUE_OBJECTS_GRAPHICS_AND_FRAMES = "ObjectsGraphicsAndFrames"
+Public Const CSTR_SUBISSUE_OBJECT_IN_HEADER_FOOTER = "ObjectInHeaderFooter"
+
+Public Const CSTR_ISSUE_INFORMATION = "Information"
+Public Const CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES = "ContentAndDocumentProperties"
+Public Const CSTR_ISSUE_FORMAT = "Format"
+Public Const CSTR_ISSUE_PORTABILITY = "Portability"
+Public Const CSTR_ISSUE_VBA_MACROS = "VBAMacros"
+
+Public Const CSTR_SUBISSUE_DOCUMENT_PARTS_PROTECTION = "DocumentPartsProtection"
+Public Const CSTR_SUBISSUE_EXTERNAL_REFERENCES_IN_MACRO = "ExternalReferencesInMacro"
+Public Const CSTR_SUBISSUE_EXTERNAL_REFERENCES_IN_MACRO_COUNT = "ExternalReferencesInMacroCount"
+Public Const CSTR_SUBISSUE_GRADIENT = "Gradient"
+Public Const CSTR_SUBISSUE_INVALID_PASSWORD_ENTERED = "InvalidPasswordEntered"
+Public Const CSTR_SUBISSUE_LINE = "Line"
+Public Const CSTR_SUBISSUE_MACRO_PASSWORD_PROTECTION = "PasswordProtected"
+Public Const CSTR_SUBISSUE_OLD_WORKBOOK_VERSION = "OldWorkbookVersion"
+Public Const CSTR_SUBISSUE_OLE_EMBEDDED = "EmbeddedOLEObject"
+Public Const CSTR_SUBISSUE_OLE_LINKED = "LinkedOLEObject"
+Public Const CSTR_SUBISSUE_OLE_CONTROL = "OLEControl"
+Public Const CSTR_SUBISSUE_OLE_FIELD_LINK = "OLEFieldLink"
+Public Const CSTR_SUBISSUE_OLE_UNKNOWN = "UnknownType"
+Public Const CSTR_SUBISSUE_PASSWORDS_PROTECTION = "PasswordProtection"
+Public Const CSTR_SUBISSUE_PROPERTIES = "Properties"
+Public Const CSTR_SUBISSUE_REFERENCES = "References"
+Public Const CSTR_SUBISSUE_TRANSPARENCY = "Transparency"
+Public Const CSTR_SUBISSUE_VBA_MACROS_NUMLINES = "NumberOfLines"
+Public Const CSTR_SUBISSUE_VBA_MACROS_USERFORMS_COUNT = "UserFormsCount"
+Public Const CSTR_SUBISSUE_VBA_MACROS_USERFORMS_CONTROL_COUNT = "UserFormsControlCount"
+Public Const CSTR_SUBISSUE_VBA_MACROS_USERFORMS_CONTROLTYPE_COUNT = "UserFormsControlTypeCount"
+Public Const CSTR_SUBISSUE_VBA_MACROS_UNIQUE_MODULE_COUNT = "UniqueModuleCount"
+Public Const CSTR_SUBISSUE_VBA_MACROS_UNIQUE_LINE_COUNT = "UniqueLineCount"
+'** END Common - XML Issue and SubIssue strings
+
+'Macro classification bounds
+Public Const CMACRO_LINECOUNT_MEDIUM_LBOUND = 50
+
+'Don't localize folder name
+Public Const CSTR_COMMON_PREPARATION_FOLDER = "prepared"
+
+
+Public Enum EnumDocOverallMacroClass
+ enMacroNone = 0
+ enMacroSimple = 1
+ enMacroMedium = 2
+ enMacroComplex = 3
+End Enum
+Public Enum EnumDocOverallIssueClass
+ enNone = 0
+ enMinor = 1
+ enComplex = 2
+End Enum
+
+Sub EmptyCollection(docAnalysis As DocumentAnalysis, coll As Collection)
+ On Error GoTo HandleErrors
+ Dim currentFunctionName As String
+ currentFunctionName = "EmptyCollection"
+ Dim Num As Long
+ For Num = 1 To coll.count ' Remove name from the collection.
+ coll.Remove 1 ' Default collection numeric indexes
+ Next ' begin at 1.
+ Exit Sub
+
+HandleErrors:
+ WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
+End Sub
+
+Public Function Analyze_Macros(docAnalysis As DocumentAnalysis, _
+ userFormTypesDict As Scripting.Dictionary, _
+ currDoc As Object)
+ On Error GoTo HandleErrors
+ Dim currentFunctionName As String
+ currentFunctionName = "Analyze_Macros"
+ Dim macroDetails As String
+ Dim cmpDetails As String
+ Dim myProject As VBProject
+ Dim myComponent As VBComponent
+ Dim numLines As Long
+ Dim myIssue As IssueInfo
+ Dim wrd As Object
+ Dim bUserFormWithEmptyCodeModule As Boolean
+
+ On Error Resume Next
+ Set myProject = getAppSpecificVBProject(currDoc)
+ If Err.Number <> 0 Then
+ ' Failed to get access to VBProject
+ WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & _
+ RID_STR_COMMON_ATTRIBUTE_UNABLE_TO_ACCESS_VBPROJECT & ":" & _
+ RID_STR_COMMON_ATTRIBUTE_FURTHER_MACRO_ANALYSIS_NOT_POSSIBLE
+
+ GoTo FinalExit
+ End If
+
+ On Error GoTo HandleErrors
+ If myProject.Protection = vbext_pp_locked Then
+ Set myIssue = New IssueInfo
+ With myIssue
+ .IssueID = CID_VBA_MACROS
+ .IssueType = RID_STR_COMMON_ISSUE_VBA_MACROS
+ .SubType = RID_STR_COMMON_SUBISSUE_MACRO_PASSWORD_PROTECTION
+ .Location = .CLocationDocument
+
+ .IssueTypeXML = CSTR_ISSUE_VBA_MACROS
+ .SubTypeXML = CSTR_SUBISSUE_MACRO_PASSWORD_PROTECTION
+ .locationXML = .CXMLLocationDocument
+
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_VBPROJECT_PASSWORD
+ .Values.Add RID_STR_COMMON_ATTRIBUTE_FURTHER_MACRO_ANALYSIS_NOT_POSSIBLE
+ End With
+ docAnalysis.IssuesCountArray(CID_VBA_MACROS) = _
+ docAnalysis.IssuesCountArray(CID_VBA_MACROS) + 1
+ docAnalysis.Issues.Add myIssue
+ docAnalysis.MacroIssuesCount = docAnalysis.MacroIssuesCount + 1
+
+ docAnalysis.HasMacros = True
+ GoTo FinalExit
+ End If
+
+ Dim myContolDict As Scripting.Dictionary
+ For Each myComponent In myProject.VBComponents
+
+ bUserFormWithEmptyCodeModule = False
+ If CheckEmptyProject(docAnalysis, myProject, myComponent) Then
+ If myComponent.Type <> vbext_ct_MSForm Then
+ GoTo FOREACH_CONTINUE
+ Else
+ bUserFormWithEmptyCodeModule = True
+ End If
+ End If
+
+ Analyze_MacrosForPortabilityIssues docAnalysis, myProject, myComponent
+
+ Set myIssue = New IssueInfo
+ With myIssue
+ .IssueID = CID_VBA_MACROS
+ .IssueType = RID_STR_COMMON_ISSUE_VBA_MACROS
+ .SubType = RID_STR_COMMON_SUBISSUE_PROPERTIES
+ .Location = .CLocationDocument
+
+ .IssueTypeXML = CSTR_ISSUE_VBA_MACROS
+ .SubTypeXML = CSTR_SUBISSUE_PROPERTIES
+ .locationXML = .CXMLLocationDocument
+
+ .SubLocation = VBComponentType(myComponent)
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_PROJECT
+ .Values.Add myProject.name
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_COMPONENT
+ .Values.Add myComponent.name
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_PROCEDURES
+ .Values.Add VBNumFuncs(docAnalysis, myComponent.CodeModule), RID_STR_COMMON_ATTRIBUTE_PROCEDURES
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NUMBER_OF_LINES
+ numLines = VBNumLines(docAnalysis, myComponent.CodeModule)
+ .Values.Add numLines, RID_STR_COMMON_ATTRIBUTE_NUMBER_OF_LINES
+
+ If bUserFormWithEmptyCodeModule Then
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_SIGNATURE
+ .Values.Add RID_STR_COMMON_NA, RID_STR_COMMON_ATTRIBUTE_SIGNATURE
+ Else
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_SIGNATURE
+ .Values.Add MD5HashString( _
+ myComponent.CodeModule.Lines(1, myComponent.CodeModule.CountOfLines)), _
+ RID_STR_COMMON_ATTRIBUTE_SIGNATURE
+ End If
+
+ docAnalysis.MacroTotalNumLines = numLines + docAnalysis.MacroTotalNumLines
+ End With
+
+ ' User Forms - control details
+ If (myComponent.Type = vbext_ct_MSForm) And Not bUserFormWithEmptyCodeModule Then
+ myIssue.Attributes.Add RID_STR_COMMON_ATTRIBUTE_CONTROLS
+ myIssue.Values.Add myComponent.Designer.Controls.count, RID_STR_COMMON_ATTRIBUTE_CONTROLS
+ docAnalysis.MacroNumUserForms = 1 + docAnalysis.MacroNumUserForms
+ docAnalysis.MacroNumUserFormControls = myComponent.Designer.Controls.count + docAnalysis.MacroNumUserFormControls
+
+ Dim myControl As Control
+ Dim controlTypes As String
+ Dim myType As String
+
+ Set myContolDict = New Scripting.Dictionary
+
+ For Each myControl In myComponent.Designer.Controls
+ myType = TypeName(myControl)
+ If myContolDict.Exists(myType) Then
+ myContolDict.item(myType) = myContolDict.item(myType) + 1
+ Else
+ myContolDict.Add myType, 1
+ End If
+ If userFormTypesDict.Exists(myType) Then
+ userFormTypesDict.item(myType) = userFormTypesDict.item(myType) + 1
+ Else
+ userFormTypesDict.Add myType, 1
+ End If
+ Next
+
+ If myComponent.Designer.Controls.count > 0 Then
+ Dim count As Long
+ Dim vKeyArray As Variant
+ Dim vItemArray As Variant
+
+ vKeyArray = myContolDict.Keys
+ vItemArray = myContolDict.Items
+
+ controlTypes = ""
+ For count = 0 To myContolDict.count - 1
+ controlTypes = controlTypes & vKeyArray(count) & " " & CInt(vItemArray(count)) & " "
+ Next count
+ myIssue.Attributes.Add RID_STR_COMMON_ATTRIBUTE_USERFORM_TYPE
+ myIssue.Values.Add controlTypes, RID_STR_COMMON_ATTRIBUTE_USERFORM_TYPE
+
+ myIssue.Attributes.Add RID_STR_COMMON_ATTRIBUTE_USERFORM_TYPES_COUNT
+ myIssue.Values.Add myContolDict.count, RID_STR_COMMON_ATTRIBUTE_USERFORM_TYPES_COUNT
+
+ docAnalysis.MacroNumUserFormControlTypes = myContolDict.count + docAnalysis.MacroNumUserFormControlTypes
+ End If
+ Set myContolDict = Nothing
+ End If
+
+ 'Check for occurence of " Me " in Form and Class Modules
+ If myComponent.Type = vbext_ct_MSForm Or _
+ myComponent.Type = vbext_ct_ClassModule Then
+
+ Dim strFind As String
+ strFind = ""
+ count = 0
+ strFind = VBFindLines(docAnalysis, myComponent.CodeModule, "Me", count, bWholeWord:=True)
+' If (strFind <> "") Then MsgBox strFind
+
+ If count > 0 Then
+ myIssue.Attributes.Add RID_STR_COMMON_ATTRIBUTE_CLASS_ME_COUNT
+ myIssue.Values.Add count, RID_STR_COMMON_ATTRIBUTE_CLASS_ME_COUNT
+ End If
+ End If
+
+ docAnalysis.IssuesCountArray(CID_VBA_MACROS) = _
+ docAnalysis.IssuesCountArray(CID_VBA_MACROS) + 1
+ docAnalysis.Issues.Add myIssue
+ docAnalysis.MacroIssuesCount = docAnalysis.MacroIssuesCount + 1
+
+ Set myIssue = Nothing
+
+FOREACH_CONTINUE:
+ 'No equiv to C continue in VB
+ Next myComponent 'End - For Each myComponent
+
+ If docAnalysis.IssuesCountArray(CID_VBA_MACROS) > 0 Then
+ Analyze_VBEReferences docAnalysis, currDoc
+ docAnalysis.HasMacros = True
+ End If
+
+FinalExit:
+ docAnalysis.MacroOverallClass = ClassifyDocOverallMacroClass(docAnalysis)
+
+ Set myProject = Nothing
+ Set myIssue = Nothing
+ Set myContolDict = Nothing
+ Exit Function
+
+HandleErrors:
+ WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
+ Resume FinalExit
+End Function
+
+Function CheckOnlyEmptyProject(docAnalysis As DocumentAnalysis, currDoc As Object) As Boolean
+ On Error GoTo HandleErrors
+ Dim currentFunctionName As String
+ currentFunctionName = "CheckOnlyEmptyProject"
+ Dim myProject As VBProject
+ Set myProject = getAppSpecificVBProject(currDoc)
+ Dim myVBComponent As VBComponent
+
+ For Each myVBComponent In myProject.VBComponents
+ If Not CheckEmptyProject(docAnalysis, myProject, myVBComponent) Then
+ CheckOnlyEmptyProject = False
+ GoTo FinalExit
+ End If
+ Next myVBComponent
+
+ CheckOnlyEmptyProject = True
+
+FinalExit:
+ Set myProject = Nothing
+ Exit Function
+
+HandleErrors:
+ WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
+ Resume FinalExit
+End Function
+
+Sub Analyze_VBEReferences(docAnalysis As DocumentAnalysis, currDoc As Object)
+ On Error GoTo HandleErrors
+ Dim currentFunctionName As String
+ currentFunctionName = "Analyze_VBEReferences"
+ 'References
+ Dim Ref As Reference
+ Dim fso As Scripting.FileSystemObject
+ Dim myVBProject As VBProject
+ Dim myVBComponent As VBComponent
+
+ Set fso = New Scripting.FileSystemObject
+
+ If CheckOnlyEmptyProject(docAnalysis, currDoc) Then
+ Exit Sub
+ End If
+ Set myVBProject = getAppSpecificVBProject(currDoc)
+
+ For Each Ref In myVBProject.References
+ Analyze_VBEReferenceSingle docAnalysis, Ref, fso
+ Next Ref
+
+FinalExit:
+ Set myVBProject = Nothing
+ Set fso = Nothing
+ Exit Sub
+
+HandleErrors:
+ WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
+ Resume FinalExit
+End Sub
+
+Sub Analyze_VBEReferenceSingle(docAnalysis As DocumentAnalysis, Ref As Reference, fso As Scripting.FileSystemObject)
+ On Error GoTo HandleErrors
+ Dim currentFunctionName As String
+ currentFunctionName = "Analyze_VBEReferenceSingle"
+ 'References
+ Dim myIssue As IssueInfo
+ Dim bBadRef As Boolean
+
+ Set myIssue = New IssueInfo
+ With myIssue
+ .IssueID = CID_INFORMATION_REFS
+ .IssueType = RID_STR_COMMON_ISSUE_INFORMATION
+ .SubType = RID_STR_COMMON_SUBISSUE_REFERENCES
+ .Location = .CLocationDocument
+
+ .IssueTypeXML = CSTR_ISSUE_INFORMATION
+ .SubTypeXML = CSTR_SUBISSUE_REFERENCES
+ .locationXML = .CXMLLocationDocument
+
+ If Ref.GUID = "" Then
+ bBadRef = True
+ Else
+ bBadRef = False
+ End If
+ If Not bBadRef Then
+ .SubLocation = LCase(fso.GetFileName(Ref.FullPath))
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME
+ .Values.Add Ref.name, RID_STR_COMMON_ATTRIBUTE_NAME
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_DESCRIPTION
+ .Values.Add Ref.Description, RID_STR_COMMON_ATTRIBUTE_DESCRIPTION
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_FILE
+ .Values.Add LCase(fso.GetFileName(Ref.FullPath)), RID_STR_COMMON_ATTRIBUTE_FILE
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_PATH
+ .Values.Add LCase(Ref.FullPath), RID_STR_COMMON_ATTRIBUTE_PATH
+ Else
+ .SubLocation = RID_STR_COMMON_NA
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME
+ .Values.Add RID_STR_COMMON_ATTRIBUTE_MISSING, RID_STR_COMMON_ATTRIBUTE_NAME
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_DESCRIPTION
+ .Values.Add RID_STR_COMMON_ATTRIBUTE_CHECK_DOCUMENT_REFERENCES, RID_STR_COMMON_ATTRIBUTE_DESCRIPTION
+ End If
+
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_MAJOR
+ .Values.Add IIf(Not bBadRef, Ref.Major, ""), RID_STR_COMMON_ATTRIBUTE_MAJOR
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_MINOR
+ .Values.Add IIf(Not bBadRef, Ref.Minor, ""), RID_STR_COMMON_ATTRIBUTE_MINOR
+
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_TYPE
+ .Values.Add IIf(Ref.Type = vbext_rk_Project, RID_STR_COMMON_ATTRIBUTE_PROJECT, RID_STR_COMMON_ATTRIBUTE_TYPELIB), RID_STR_COMMON_ATTRIBUTE_TYPE
+
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_BUILTIN
+ .Values.Add IIf(Ref.BuiltIn, RID_STR_COMMON_ATTRIBUTE_BUILTIN, RID_STR_COMMON_ATTRIBUTE_CUSTOM), RID_STR_COMMON_ATTRIBUTE_BUILTIN
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_ISBROKEN
+ .Values.Add IIf(bBadRef, RID_STR_COMMON_ATTRIBUTE_BROKEN, RID_STR_COMMON_ATTRIBUTE_INTACT), RID_STR_COMMON_ATTRIBUTE_ISBROKEN
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_GUID
+ .Values.Add IIf(Ref.Type = vbext_rk_TypeLib, Ref.GUID, ""), RID_STR_COMMON_ATTRIBUTE_GUID
+ End With
+
+ docAnalysis.References.Add myIssue
+
+FinalExit:
+ Set myIssue = Nothing
+ Exit Sub
+
+HandleErrors:
+ WriteDebugLevelTwo currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
+ Resume FinalExit
+End Sub
+
+Sub Analyze_MacrosForPortabilityIssues(docAnalysis As DocumentAnalysis, myProject As VBProject, myComponent As VBComponent)
+ On Error GoTo HandleErrors
+ Dim currentFunctionName As String
+ currentFunctionName = "Analyze_MacrosForPortabilityIssues"
+ Dim myIssue As IssueInfo
+ Dim count As Long
+
+ ' Code Modules
+ Dim strFind As String
+ strFind = VBFindLines(docAnalysis, myComponent.CodeModule, "CreateObject", count, bWholeWord:=True) & _
+ VBFindLines(docAnalysis, myComponent.CodeModule, "GetObject", count, bWholeWord:=True) & _
+ VBFindLines(docAnalysis, myComponent.CodeModule, "ADODB.", count, True, True) & _
+ VBFindLines(docAnalysis, myComponent.CodeModule, "Word.", count, True, True) & _
+ VBFindLines(docAnalysis, myComponent.CodeModule, "Excel.", count, True, True) & _
+ VBFindLines(docAnalysis, myComponent.CodeModule, "PowerPoint.", count, True, True) & _
+ VBFindLines(docAnalysis, myComponent.CodeModule, "Access.", count, True, True) & _
+ VBFindLines(docAnalysis, myComponent.CodeModule, "Declare Function ", count, False) & _
+ VBFindLines(docAnalysis, myComponent.CodeModule, "Declare Sub ", count, False)
+
+
+ If (strFind <> "") And (myComponent.Type <> vbext_ct_Document) Then
+ Set myIssue = New IssueInfo
+ With myIssue
+ .IssueID = CID_PORTABILITY
+ .IssueType = RID_STR_COMMON_ISSUE_PORTABILITY
+ .SubType = RID_STR_COMMON_SUBISSUE_EXTERNAL_REFERENCES_IN_MACROS
+ .Location = .CLocationDocument
+
+ .IssueTypeXML = CSTR_ISSUE_PORTABILITY
+ .SubTypeXML = CSTR_SUBISSUE_EXTERNAL_REFERENCES_IN_MACRO
+ .locationXML = .CXMLLocationDocument
+
+ .SubLocation = VBComponentType(myComponent)
+
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_PROJECT
+ .Values.Add myProject.name
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_COMPONENT
+ .Values.Add myComponent.name
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NON_PORTABLE_EXTERNAL_REFERENCES
+ .Values.Add RID_STR_COMMON_ATTRIBUTE_INCLUDING & vbLf & Left(strFind, Len(strFind) - 1)
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NON_PORTABLE_EXTERNAL_REFERENCES_COUNT
+ .Values.Add count, RID_STR_COMMON_ATTRIBUTE_NON_PORTABLE_EXTERNAL_REFERENCES_COUNT
+ End With
+ docAnalysis.IssuesCountArray(CID_PORTABILITY) = _
+ docAnalysis.IssuesCountArray(CID_PORTABILITY) + 1
+ docAnalysis.Issues.Add myIssue
+ docAnalysis.MacroNumExternalRefs = count + docAnalysis.MacroNumExternalRefs
+ docAnalysis.MacroIssuesCount = docAnalysis.MacroIssuesCount + 1
+ End If
+
+FinalExit:
+ Set myIssue = Nothing
+ Exit Sub
+
+
+HandleErrors:
+ WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
+Resume FinalExit
+End Sub
+
+'Find Lines in code module containing strFind and return list of them
+Function VBFindLines(docAnalysis As DocumentAnalysis, vbcm As CodeModule, strFind As String, _
+ count As Long, _
+ Optional bInProcedure As Boolean = True, _
+ Optional bUsingNew As Boolean = False, _
+ Optional bWholeWord As Boolean = False, _
+ Optional bMatchCase As Boolean = False) As String
+ On Error GoTo HandleErrors
+ Dim currentFunctionName As String
+ currentFunctionName = "VBFindLines"
+ Dim lngStartLine As Long
+ Dim lngStartCol As Long
+ Dim lngEndLine As Long
+ Dim lngEndCol As Long
+ Dim strLine As String
+ lngStartLine = 1
+ lngStartCol = 1
+ lngEndLine = vbcm.CountOfLines
+ Dim tmpString As String
+ If (vbcm.CountOfLines = 0) Then
+ Exit Function
+ End If
+ tmpString = vbcm.Lines(vbcm.CountOfLines, 1)
+ lngEndCol = Len(vbcm.Lines(vbcm.CountOfLines, 1))
+ Dim lngType As Long
+ Dim strProc As String
+ Dim retStr As String
+
+ ' Search
+ Do While vbcm.Find(strFind, lngStartLine, _
+ lngStartCol, lngEndLine, lngEndCol, bWholeWord, bMatchCase)
+
+ 'Ignore any lines using this func
+ If InStr(1, vbcm.Lines(lngStartLine, 1), "VBFindLines") <> 0 Then
+ GoTo CONTINUE_LOOP
+ End If
+
+ If bInProcedure Then
+ If bUsingNew Then
+ If InStr(1, vbcm.Lines(lngStartLine, 1), "New") <> 0 Then
+ strProc = vbcm.ProcOfLine(lngStartLine, lngType)
+ Else
+ strProc = ""
+ End If
+ Else
+ strProc = vbcm.ProcOfLine(lngStartLine, lngType)
+ End If
+ If strProc = "" Then GoTo CONTINUE_LOOP
+
+ VBFindLines = VBFindLines & "[" & strProc & " ( ) - " & lngStartLine & " ]" & _
+ vbLf & vbcm.Lines(lngStartLine, 1) & vbLf
+ Else
+ strProc = vbcm.Lines(lngStartLine, 1)
+ If strProc = "" Then GoTo CONTINUE_LOOP
+
+ 'Can be External refs, Const, Type or variable declarations
+ If InStr(1, vbcm.Lines(lngStartLine, 1), "Declare Function") <> 0 Then
+ VBFindLines = VBFindLines & "[" & RID_STR_COMMON_DEC_TO_EXTERNAL_LIBRARY & " - " & lngStartLine & " ]" & _
+ vbLf & strProc & vbLf
+ Else
+ VBFindLines = VBFindLines & "[" & RID_STR_COMMON_VB_COMPONENT_MODULE & " " & strFind & _
+ " - " & lngStartLine & " ]" & vbLf
+ End If
+ End If
+ count = count + 1
+
+CONTINUE_LOOP:
+ 'Reset Params to search for next hit
+ lngStartLine = lngEndLine + 1
+ lngStartCol = 1
+ lngEndLine = vbcm.CountOfLines
+ lngEndCol = Len(vbcm.Lines(vbcm.CountOfLines, 1))
+
+ If lngStartLine >= lngEndLine Then Exit Function
+
+ Loop 'End - Do While vbcm.Find
+ VBFindLines = VBFindLines
+ Exit Function
+
+HandleErrors:
+ WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
+End Function
+Function VBNumLines(docAnalysis As DocumentAnalysis, vbcm As CodeModule) As Long
+ On Error GoTo HandleErrors
+ Dim currentFunctionName As String
+ currentFunctionName = "VBNumLines"
+ Dim cLines As Long
+ Dim lngType As Long
+ Dim strProc As String
+
+ 'Issue: Just give line count in module to be in sync with Macro Analysis and Migration Wizard
+ VBNumLines = vbcm.CountOfLines
+
+ 'For cLines = 1 To vbcm.CountOfLines
+ ' strProc = vbcm.ProcOfLine(cLines, lngType)
+ ' If strProc <> "" Then
+ ' VBNumLines = VBNumLines - _
+ ' (vbcm.ProcBodyLine(strProc, lngType) - vbcm.ProcStartLine(strProc, lngType))
+ ' cLines = cLines + vbcm.ProcCountLines(strProc, lngType) - 1
+ ' End If
+ 'Next
+ Exit Function
+
+HandleErrors:
+ WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
+End Function
+Function VBNumFuncs(docAnalysis As DocumentAnalysis, vbcm As CodeModule) As Long
+ On Error GoTo HandleErrors
+ Dim currentFunctionName As String
+ currentFunctionName = "VBNumFuncs"
+ Dim cLines As Long
+ Dim lngType As Long
+ Dim strProc As String
+
+ For cLines = 1 To vbcm.CountOfLines
+ strProc = vbcm.ProcOfLine(cLines, lngType)
+ If strProc <> "" Then
+ VBNumFuncs = VBNumFuncs + 1
+ cLines = cLines + vbcm.ProcCountLines(strProc, lngType) - 1
+ End If
+ Next
+ Exit Function
+HandleErrors:
+ WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
+End Function
+
+Function VBComponentType(vbc As VBComponent) As String
+ Select Case vbc.Type
+ Case vbext_ct_StdModule
+ VBComponentType = RID_STR_COMMON_VB_COMPONENT_STANDARD
+ Case vbext_ct_ClassModule
+ VBComponentType = RID_STR_COMMON_VB_COMPONENT_CLASS
+ Case vbext_ct_MSForm
+ VBComponentType = RID_STR_COMMON_VB_COMPONENT_USER_FORM
+ Case vbext_ct_Document
+ VBComponentType = RID_STR_COMMON_VB_COMPONENT_DOCUMENT
+ Case 11 'vbext_ct_ActiveX Designer
+ VBComponentType = RID_STR_COMMON_VB_COMPONENT_ACTIVEX_DESIGNER
+ Case Else
+ VBComponentType = RID_STR_COMMON_UNKNOWN
+ End Select
+End Function
+
+Function CheckEmptyProject(docAnalysis As DocumentAnalysis, myProject As VBProject, myComponent As VBComponent) As Boolean
+ On Error GoTo HandleErrors
+ Dim currentFunctionName As String
+ currentFunctionName = "CheckEmptyProject"
+ Dim bEmptyProject As Boolean
+
+ 'Bug: Can have empty project with different name from default, would be picked up
+ ' as not empty.
+ 'bEmptyProject = _
+ ' (StrComp(myProject.name, CTOPLEVEL_PROJECT) = 0) And _
+ ' (VBNumFuncs(docAnalysis, myComponent.CodeModule) = 0) And _
+ ' (VBNumLines(docAnalysis, myComponent.CodeModule) < 3)
+
+ ' Code Modules
+ Dim strFind As String
+ Dim count As Long
+ 'Check for:
+ 'Public Const myFoo ....
+ 'Public Declare Function ....
+ 'Public myVar As ...
+ strFind = VBFindLines(docAnalysis, myComponent.CodeModule, "Public", _
+ count, bInProcedure:=False, bWholeWord:=True, bMatchCase:=True)
+
+ bEmptyProject = _
+ (VBNumFuncs(docAnalysis, myComponent.CodeModule) = 0) And _
+ (VBNumLines(docAnalysis, myComponent.CodeModule) < 3) And _
+ (strFind = "")
+
+ CheckEmptyProject = IIf(bEmptyProject, True, False)
+ Exit Function
+
+
+HandleErrors:
+ WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
+End Function
+
+Function getCustomDocPropTypeAsString(propType As MsoDocProperties)
+ Dim Str As String
+
+ Select Case propType
+ Case msoPropertyTypeBoolean
+ Str = RID_STR_COMMON_YES_OR_NO
+ Case msoPropertyTypeDate
+ Str = RID_STR_COMMON_DATE
+ Case msoPropertyTypeFloat
+ Str = RID_STR_COMMON_NUMBER
+ Case msoPropertyTypeNumber
+ Str = RID_STR_COMMON_NUMBER
+ Case msoPropertyTypeString
+ Str = RID_STR_COMMON_TEXT
+ Case Else
+ Str = "Unknown"
+ End Select
+
+ getCustomDocPropTypeAsString = Str
+End Function
+
+Sub HandleProtectedDocInvalidPassword(docAnalysis As DocumentAnalysis, strError As String, fso As FileSystemObject)
+ On Error GoTo HandleErrors
+ Dim currentFunctionName As String
+ currentFunctionName = "HandleProtectedDocInvalidPassword"
+ Dim f As File
+ Set f = fso.GetFile(docAnalysis.name)
+
+ docAnalysis.Application = RID_STR_COMMON_PASSWORD_SKIPDOC
+
+ On Error Resume Next
+ docAnalysis.PageCount = 0
+ docAnalysis.Created = f.DateCreated
+ docAnalysis.Modified = f.DateLastModified
+ docAnalysis.Accessed = f.DateLastAccessed
+ docAnalysis.Printed = DateValue("01/01/1900")
+ docAnalysis.SavedBy = RID_STR_COMMON_NA
+ docAnalysis.Revision = 0
+ docAnalysis.Template = RID_STR_COMMON_NA
+ On Error GoTo HandleErrors
+
+ Dim myIssue As IssueInfo
+ Set myIssue = New IssueInfo
+
+ With myIssue
+ .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES
+ .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES
+ .SubType = RID_STR_COMMON_SUBISSUE_INVALID_PASSWORD_ENTERED
+ .Location = .CLocationDocument
+
+ .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES
+ .SubTypeXML = CSTR_SUBISSUE_INVALID_PASSWORD_ENTERED
+ .locationXML = .CXMLLocationDocument
+
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_PASSWORD
+ .Values.Add strError
+
+ docAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _
+ docAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1
+ End With
+
+ docAnalysis.Issues.Add myIssue
+
+FinalExit:
+ Set myIssue = Nothing
+ Set f = Nothing
+ Exit Sub
+
+HandleErrors:
+ WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
+ Resume FinalExit
+End Sub
+
+Sub Analyze_OLEEmbeddedSingleShape(docAnalysis As DocumentAnalysis, aShape As Shape, mySubLocation As Variant)
+
+ On Error GoTo HandleErrors
+ Dim currentFunctionName As String
+ currentFunctionName = "Analyze_OLEEmbeddedSingleShape"
+ Dim myIssue As IssueInfo
+ Dim bOleObject As Boolean
+ Dim TypeAsString As String
+ Dim XMLTypeAsString As String
+ Dim objName As String
+
+ bOleObject = (aShape.Type = msoEmbeddedOLEObject) Or _
+ (aShape.Type = msoLinkedOLEObject) Or _
+ (aShape.Type = msoOLEControlObject)
+
+ If Not bOleObject Then Exit Sub
+
+ aShape.Select
+ Select Case aShape.Type
+ Case msoEmbeddedOLEObject
+ TypeAsString = RID_STR_COMMON_OLE_EMBEDDED
+ XMLTypeAsString = CSTR_SUBISSUE_OLE_EMBEDDED
+ Case msoLinkedOLEObject
+ TypeAsString = RID_STR_COMMON_OLE_LINKED
+ XMLTypeAsString = CSTR_SUBISSUE_OLE_LINKED
+ Case msoOLEControlObject
+ TypeAsString = RID_STR_COMMON_OLE_CONTROL
+ XMLTypeAsString = CSTR_SUBISSUE_OLE_CONTROL
+ Case Else
+ TypeAsString = RID_STR_COMMON_OLE_UNKNOWN
+ XMLTypeAsString = CSTR_SUBISSUE_OLE_UNKNOWN
+ End Select
+
+ Dim appStr As String
+ appStr = getAppSpecificApplicationName
+
+ Set myIssue = New IssueInfo
+ With myIssue
+ .IssueID = CID_PORTABILITY
+ .IssueType = RID_STR_COMMON_ISSUE_PORTABILITY
+ .SubType = TypeAsString
+ .Location = .CLocationPage
+ .SubLocation = mySubLocation
+
+ .IssueTypeXML = CSTR_ISSUE_PORTABILITY
+ .SubTypeXML = XMLTypeAsString
+ .locationXML = .CXMLLocationPage
+
+ .Line = aShape.top
+ .column = aShape.Left
+
+ If aShape.name <> "" Then
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME
+ .Values.Add aShape.name
+ End If
+
+ If aShape.Type = msoEmbeddedOLEObject Or _
+ aShape.Type = msoOLEControlObject Then
+ Dim objType As String
+ On Error Resume Next
+
+ objType = getAppSpecificOLEClassType(aShape)
+
+ If objType = "" Then GoTo FinalExit
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_OBJECT_TYPE
+ .Values.Add objType
+
+ If aShape.Type = msoOLEControlObject Then
+ docAnalysis.MacroNumOLEControls = 1 + docAnalysis.MacroNumOLEControls
+ End If
+
+ If appStr = CAPPNAME_POWERPOINT Then
+ '#114127: Too many open windows
+ 'Checking for OLEFormat.Object is Nothing or IsEmpty still causes problem
+ If objType <> "Equation.3" Then
+ objName = aShape.OLEFormat.Object.name
+ If Err.Number = 0 Then
+ If aShape.name <> objName Then
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_OBJECT_NAME
+ .Values.Add objName
+ End If
+ End If
+ End If
+ Else
+ If Not (aShape.OLEFormat.Object) Is Nothing Then
+ objName = aShape.OLEFormat.Object.name
+ If Err.Number = 0 Then
+ If aShape.name <> objName Then
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_OBJECT_NAME
+ .Values.Add objName
+ End If
+ End If
+ End If
+ End If
+
+ On Error GoTo HandleErrors
+ End If
+
+ If aShape.Type = msoLinkedOLEObject Then
+ If appStr <> CAPPNAME_WORD Then
+ On Error Resume Next
+ Dim path As String
+ path = aShape.OLEFormat.Object.SourceFullName
+ If Err.Number = 0 Then
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_SOURCE
+ .Values.Add path
+ End If
+ On Error GoTo HandleErrors
+ Else
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_SOURCE
+ .Values.Add aShape.LinkFormat.SourceFullName
+ End If
+ End If
+
+ docAnalysis.IssuesCountArray(CID_PORTABILITY) = _
+ docAnalysis.IssuesCountArray(CID_PORTABILITY) + 1
+ End With
+ docAnalysis.Issues.Add myIssue
+
+FinalExit:
+ Set myIssue = Nothing
+ Exit Sub
+
+HandleErrors:
+ WriteDebugLevelTwo currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
+ Resume FinalExit
+End Sub
+
+Sub Analyze_Lines(docAnalysis As DocumentAnalysis, myShape As Shape, mySubLocation As Variant)
+ On Error GoTo HandleErrors
+ Dim currentFunctionName As String
+ currentFunctionName = "Analyze_Lines"
+
+ If myShape.Line.Style = msoLineSingle Or _
+ myShape.Line.Style = msoLineStyleMixed Then Exit Sub
+
+ Dim myIssue As IssueInfo
+ Set myIssue = New IssueInfo
+
+ With myIssue
+ .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES
+ .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES
+ .SubType = RID_RESXLS_COST_LineStyle
+ .Location = .CLocationPage
+ .SubLocation = mySubLocation
+
+ .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES
+ .SubTypeXML = CSTR_SUBISSUE_LINE
+ .locationXML = .CXMLLocationPage
+
+ .Line = myShape.top
+ .column = myShape.Left
+
+ If myShape.name <> "" Then
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME
+ .Values.Add myShape.name
+ End If
+
+ AddIssueDetailsNote myIssue, 0, RID_STR_COMMON_SUBISSUE_LINE_NOTE
+
+ docAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _
+ docAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1
+ End With
+
+ docAnalysis.Issues.Add myIssue
+
+FinalExit:
+ Set myIssue = Nothing
+ Exit Sub
+
+HandleErrors:
+ WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
+ Resume FinalExit
+End Sub
+
+Sub Analyze_Transparency(docAnalysis As DocumentAnalysis, myShape As Shape, mySubLocation As Variant)
+ On Error GoTo HandleErrors
+ Dim currentFunctionName As String
+ currentFunctionName = "Analyze_Transparency"
+
+ If Not myShape.Type = msoPicture Then Exit Sub
+
+ Dim bHasTransparentBkg
+ bHasTransparentBkg = False
+
+ On Error Resume Next
+ If myShape.PictureFormat.TransparentBackground = msoTrue Then
+ If Error.Number = 0 Then
+ bHasTransparentBkg = True
+ End If
+ End If
+
+ On Error GoTo HandleErrors
+ If Not bHasTransparentBkg Then Exit Sub
+
+ Dim myIssue As IssueInfo
+ Set myIssue = New IssueInfo
+
+ With myIssue
+ .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES
+ .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES
+ .SubType = RID_RESXLS_COST_Transparent
+ .Location = .CLocationSlide
+ .SubLocation = mySubLocation
+
+ .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES
+ .SubTypeXML = CSTR_SUBISSUE_TRANSPARENCY
+ .locationXML = .CXMLLocationPage
+
+ .Line = myShape.top
+ .column = myShape.Left
+
+ If myShape.name <> "" Then
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME
+ .Values.Add myShape.name
+ End If
+
+ AddIssueDetailsNote myIssue, 0, RID_STR_COMMON_SUBISSUE_TRANSPARENCY_NOTE
+
+ docAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _
+ docAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1
+ End With
+
+ docAnalysis.Issues.Add myIssue
+
+FinalExit:
+ Set myIssue = Nothing
+ Exit Sub
+
+HandleErrors:
+ WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
+ Resume FinalExit
+End Sub
+
+Sub Analyze_Gradients(docAnalysis As DocumentAnalysis, myShape As Shape, mySubLocation As Variant)
+ On Error GoTo HandleErrors
+ Dim currentFunctionName As String
+ currentFunctionName = "Analyze_Gradients"
+
+ If myShape.Fill.Type <> msoFillGradient Then Exit Sub
+
+ Dim bUsesPresetGradient, bUsesFromCorner, bUsesFromCenter
+ bUsesPresetGradient = False
+ bUsesFromCorner = False
+ bUsesFromCenter = False
+
+ On Error Resume Next
+ If myShape.Fill.PresetGradientType <> msoPresetGradientMixed Then
+ If Error.Number = 0 Then
+ bUsesPresetGradient = True
+ End If
+ End If
+ If myShape.Fill.GradientStyle <> msoGradientFromCorner Then
+ If Error.Number = 0 Then
+ bUsesFromCorner = True
+ End If
+ End If
+ If myShape.Fill.GradientStyle <> msoGradientFromCenter Then
+ If Error.Number = 0 Then
+ bUsesFromCenter = True
+ End If
+ End If
+
+ On Error GoTo HandleErrors
+ If Not bUsesPresetGradient And Not bUsesFromCorner _
+ And Not bUsesFromCenter Then Exit Sub
+
+ Dim myIssue As IssueInfo
+ Set myIssue = New IssueInfo
+
+ With myIssue
+ .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES
+ .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES
+ .SubType = RID_RESXLS_COST_GradientStyle
+ .Location = .CLocationSlide
+ .SubLocation = mySubLocation
+
+ .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES
+ .SubTypeXML = CSTR_SUBISSUE_GRADIENT
+ .locationXML = .CXMLLocationSlide
+
+ .Line = myShape.top
+ .column = myShape.Left
+
+ If myShape.name <> "" Then
+ .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME
+ .Values.Add myShape.name
+ End If
+
+ If bUsesPresetGradient Then
+ AddIssueDetailsNote myIssue, 0, RID_STR_COMMON_SUBISSUE_GRADIENT_PRESET_NOTE
+ ElseIf bUsesFromCorner Then
+ AddIssueDetailsNote myIssue, 0, RID_STR_COMMON_SUBISSUE_GRADIENT_CORNER_NOTE
+ Else
+ AddIssueDetailsNote myIssue, 0, RID_STR_COMMON_SUBISSUE_GRADIENT_CENTER_NOTE
+ End If
+
+ docAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _
+ docAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1
+ End With
+
+ docAnalysis.Issues.Add myIssue
+
+FinalExit:
+ Set myIssue = Nothing
+ Exit Sub
+
+HandleErrors:
+ WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
+ Resume FinalExit
+End Sub
+
+Private Function CreateFullPath(newPath As String, fso As FileSystemObject)
+ 'We don't want to create 'c:\'
+ If (Len(newPath) < 4) Then
+ Exit Function
+ End If
+
+ 'Create parent folder first
+ If (Not fso.FolderExists(fso.GetParentFolderName(newPath))) Then
+ CreateFullPath fso.GetParentFolderName(newPath), fso
+ End If
+
+ If (Not fso.FolderExists(newPath)) Then
+ fso.CreateFolder (newPath)
+ End If
+End Function
+
+Function GetPreparedFullPath(sourceDocPath As String, startDir As String, storeToDir As String, _
+ fso As FileSystemObject) As String
+ On Error GoTo HandleErrors
+ Dim currentFunctionName As String
+ currentFunctionName = "GetPreparedFullPath"
+ GetPreparedFullPath = ""
+
+ Dim preparedPath As String
+
+ preparedPath = Right(sourceDocPath, Len(sourceDocPath) - Len(startDir))
+ If Left(preparedPath, 1) = "\" Then
+ preparedPath = Right(preparedPath, Len(preparedPath) - 1)
+ End If
+
+ 'Allow for root folder C:\
+ If Right(storeToDir, 1) <> "\" Then
+ preparedPath = storeToDir & "\" & CSTR_COMMON_PREPARATION_FOLDER & "\" & preparedPath
+ Else
+ preparedPath = storeToDir & CSTR_COMMON_PREPARATION_FOLDER & "\" & preparedPath
+ End If
+
+ 'Debug: MsgBox "Preppath: " & preparedPath
+ CreateFullPath fso.GetParentFolderName(preparedPath), fso
+
+ 'Only set if folder to save to exists or has been created, otherwise return ""
+ GetPreparedFullPath = preparedPath
+
+FinalExit:
+ Exit Function
+
+HandleErrors:
+ WriteDebugLevelTwo currentFunctionName & " : " & sourceDocPath & ": " & Err.Number & " " & Err.Description & " " & Err.Source
+ Resume FinalExit
+End Function
+
+Function ClassifyDocOverallMacroClass(docAnalysis As DocumentAnalysis) As EnumDocOverallMacroClass
+ ClassifyDocOverallMacroClass = enMacroNone
+
+ If Not docAnalysis.HasMacros Then Exit Function
+
+ If (docAnalysis.MacroTotalNumLines >= CMACRO_LINECOUNT_MEDIUM_LBOUND) Then
+ If (docAnalysis.MacroNumExternalRefs > 0) Or _
+ (docAnalysis.MacroNumOLEControls > 0 Or docAnalysis.MacroNumFieldsUsingMacros > 0) Or _
+ docAnalysis.MacroNumUserForms > 0 Then
+ ClassifyDocOverallMacroClass = enMacroComplex
+ Else
+ ClassifyDocOverallMacroClass = enMacroMedium
+ End If
+ Else
+ ClassifyDocOverallMacroClass = enMacroSimple
+ End If
+
+End Function
+
|