| 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 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 | |