| Attribute VB_Name = "CommonMigrationAnalyser" |
| '************************************************************************* |
| ' |
| ' Licensed to the Apache Software Foundation (ASF) under one |
| ' or more contributor license agreements. See the NOTICE file |
| ' distributed with this work for additional information |
| ' regarding copyright ownership. The ASF licenses this file |
| ' to you under the Apache License, Version 2.0 (the |
| ' "License"); you may not use this file except in compliance |
| ' with the License. You may obtain a copy of the License at |
| ' |
| ' http://www.apache.org/licenses/LICENSE-2.0 |
| ' |
| ' Unless required by applicable law or agreed to in writing, |
| ' software distributed under the License is distributed on an |
| ' "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY |
| ' KIND, either express or implied. See the License for the |
| ' specific language governing permissions and limitations |
| ' under the License. |
| ' |
| '************************************************************************* |
| Option Explicit |
| |
| |
| '*********************************************** |
| '**** 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 occurrence 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 |
| |