1Attribute VB_Name = "CommonMigrationAnalyser"
2'*************************************************************************
3'
4'  Licensed to the Apache Software Foundation (ASF) under one
5'  or more contributor license agreements.  See the NOTICE file
6'  distributed with this work for additional information
7'  regarding copyright ownership.  The ASF licenses this file
8'  to you under the Apache License, Version 2.0 (the
9'  "License"); you may not use this file except in compliance
10'  with the License.  You may obtain a copy of the License at
11'
12'    http://www.apache.org/licenses/LICENSE-2.0
13'
14'  Unless required by applicable law or agreed to in writing,
15'  software distributed under the License is distributed on an
16'  "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
17'  KIND, either express or implied.  See the License for the
18'  specific language governing permissions and limitations
19'  under the License.
20'
21'*************************************************************************
22Option Explicit
23
24
25'***********************************************
26'**** APPLICATION COMMON ANALYSIS FUNCTIONS ****
27'***********************************************
28
29'** Common - XML Issue and SubIssue strings
30'For preparation - need access to some Word/ Excel or PP consts
31Public Const CSTR_ISSUE_OBJECTS_GRAPHICS_AND_FRAMES = "ObjectsGraphicsAndFrames"
32Public Const CSTR_SUBISSUE_OBJECT_IN_HEADER_FOOTER = "ObjectInHeaderFooter"
33
34Public Const CSTR_ISSUE_INFORMATION = "Information"
35Public Const CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES = "ContentAndDocumentProperties"
36Public Const CSTR_ISSUE_FORMAT = "Format"
37Public Const CSTR_ISSUE_PORTABILITY = "Portability"
38Public Const CSTR_ISSUE_VBA_MACROS = "VBAMacros"
39
40Public Const CSTR_SUBISSUE_DOCUMENT_PARTS_PROTECTION = "DocumentPartsProtection"
41Public Const CSTR_SUBISSUE_EXTERNAL_REFERENCES_IN_MACRO = "ExternalReferencesInMacro"
42Public Const CSTR_SUBISSUE_EXTERNAL_REFERENCES_IN_MACRO_COUNT = "ExternalReferencesInMacroCount"
43Public Const CSTR_SUBISSUE_GRADIENT = "Gradient"
44Public Const CSTR_SUBISSUE_INVALID_PASSWORD_ENTERED = "InvalidPasswordEntered"
45Public Const CSTR_SUBISSUE_LINE = "Line"
46Public Const CSTR_SUBISSUE_MACRO_PASSWORD_PROTECTION = "PasswordProtected"
47Public Const CSTR_SUBISSUE_OLD_WORKBOOK_VERSION = "OldWorkbookVersion"
48Public Const CSTR_SUBISSUE_OLE_EMBEDDED = "EmbeddedOLEObject"
49Public Const CSTR_SUBISSUE_OLE_LINKED = "LinkedOLEObject"
50Public Const CSTR_SUBISSUE_OLE_CONTROL = "OLEControl"
51Public Const CSTR_SUBISSUE_OLE_FIELD_LINK = "OLEFieldLink"
52Public Const CSTR_SUBISSUE_OLE_UNKNOWN = "UnknownType"
53Public Const CSTR_SUBISSUE_PASSWORDS_PROTECTION = "PasswordProtection"
54Public Const CSTR_SUBISSUE_PROPERTIES = "Properties"
55Public Const CSTR_SUBISSUE_REFERENCES = "References"
56Public Const CSTR_SUBISSUE_TRANSPARENCY = "Transparency"
57Public Const CSTR_SUBISSUE_VBA_MACROS_NUMLINES = "NumberOfLines"
58Public Const CSTR_SUBISSUE_VBA_MACROS_USERFORMS_COUNT = "UserFormsCount"
59Public Const CSTR_SUBISSUE_VBA_MACROS_USERFORMS_CONTROL_COUNT = "UserFormsControlCount"
60Public Const CSTR_SUBISSUE_VBA_MACROS_USERFORMS_CONTROLTYPE_COUNT = "UserFormsControlTypeCount"
61Public Const CSTR_SUBISSUE_VBA_MACROS_UNIQUE_MODULE_COUNT = "UniqueModuleCount"
62Public Const CSTR_SUBISSUE_VBA_MACROS_UNIQUE_LINE_COUNT = "UniqueLineCount"
63'** END Common - XML Issue and SubIssue strings
64
65'Macro classification bounds
66Public Const CMACRO_LINECOUNT_MEDIUM_LBOUND = 50
67
68'Don't localize folder name
69Public Const CSTR_COMMON_PREPARATION_FOLDER = "prepared"
70
71
72Public Enum EnumDocOverallMacroClass
73    enMacroNone = 0
74    enMacroSimple = 1
75    enMacroMedium = 2
76    enMacroComplex = 3
77End Enum
78Public Enum EnumDocOverallIssueClass
79    enNone = 0
80    enMinor = 1
81    enComplex = 2
82End Enum
83
84Sub EmptyCollection(docAnalysis As DocumentAnalysis, coll As Collection)
85    On Error GoTo HandleErrors
86    Dim currentFunctionName As String
87    currentFunctionName = "EmptyCollection"
88    Dim Num As Long
89    For Num = 1 To coll.count    ' Remove name from the collection.
90        coll.Remove 1    ' Default collection numeric indexes
91    Next    ' begin at 1.
92    Exit Sub
93
94HandleErrors:
95    WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
96End Sub
97
98Public Function Analyze_Macros(docAnalysis As DocumentAnalysis, _
99                               userFormTypesDict As Scripting.Dictionary, _
100                               currDoc As Object)
101    On Error GoTo HandleErrors
102    Dim currentFunctionName As String
103    currentFunctionName = "Analyze_Macros"
104    Dim macroDetails As String
105    Dim cmpDetails As String
106    Dim myProject As VBProject
107    Dim myComponent As VBComponent
108    Dim numLines As Long
109    Dim myIssue As IssueInfo
110    Dim wrd As Object
111    Dim bUserFormWithEmptyCodeModule As Boolean
112
113    On Error Resume Next
114    Set myProject = getAppSpecificVBProject(currDoc)
115    If Err.Number <> 0 Then
116        ' Failed to get access to VBProject
117        WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & _
118            RID_STR_COMMON_ATTRIBUTE_UNABLE_TO_ACCESS_VBPROJECT & ":" & _
119            RID_STR_COMMON_ATTRIBUTE_FURTHER_MACRO_ANALYSIS_NOT_POSSIBLE
120
121        GoTo FinalExit
122    End If
123
124    On Error GoTo HandleErrors
125    If myProject.Protection = vbext_pp_locked Then
126        Set myIssue = New IssueInfo
127        With myIssue
128            .IssueID = CID_VBA_MACROS
129            .IssueType = RID_STR_COMMON_ISSUE_VBA_MACROS
130            .SubType = RID_STR_COMMON_SUBISSUE_MACRO_PASSWORD_PROTECTION
131            .Location = .CLocationDocument
132
133            .IssueTypeXML = CSTR_ISSUE_VBA_MACROS
134            .SubTypeXML = CSTR_SUBISSUE_MACRO_PASSWORD_PROTECTION
135            .locationXML = .CXMLLocationDocument
136
137            .Attributes.Add RID_STR_COMMON_ATTRIBUTE_VBPROJECT_PASSWORD
138            .Values.Add RID_STR_COMMON_ATTRIBUTE_FURTHER_MACRO_ANALYSIS_NOT_POSSIBLE
139        End With
140        docAnalysis.IssuesCountArray(CID_VBA_MACROS) = _
141            docAnalysis.IssuesCountArray(CID_VBA_MACROS) + 1
142        docAnalysis.Issues.Add myIssue
143        docAnalysis.MacroIssuesCount = docAnalysis.MacroIssuesCount + 1
144
145        docAnalysis.HasMacros = True
146        GoTo FinalExit
147    End If
148
149    Dim myContolDict As Scripting.Dictionary
150    For Each myComponent In myProject.VBComponents
151
152        bUserFormWithEmptyCodeModule = False
153        If CheckEmptyProject(docAnalysis, myProject, myComponent) Then
154            If myComponent.Type <> vbext_ct_MSForm Then
155                GoTo FOREACH_CONTINUE
156            Else
157                bUserFormWithEmptyCodeModule = True
158            End If
159        End If
160
161        Analyze_MacrosForPortabilityIssues docAnalysis, myProject, myComponent
162
163        Set myIssue = New IssueInfo
164        With myIssue
165            .IssueID = CID_VBA_MACROS
166            .IssueType = RID_STR_COMMON_ISSUE_VBA_MACROS
167            .SubType = RID_STR_COMMON_SUBISSUE_PROPERTIES
168            .Location = .CLocationDocument
169
170            .IssueTypeXML = CSTR_ISSUE_VBA_MACROS
171            .SubTypeXML = CSTR_SUBISSUE_PROPERTIES
172            .locationXML = .CXMLLocationDocument
173
174            .SubLocation = VBComponentType(myComponent)
175            .Attributes.Add RID_STR_COMMON_ATTRIBUTE_PROJECT
176            .Values.Add myProject.name
177            .Attributes.Add RID_STR_COMMON_ATTRIBUTE_COMPONENT
178            .Values.Add myComponent.name
179            .Attributes.Add RID_STR_COMMON_ATTRIBUTE_PROCEDURES
180            .Values.Add VBNumFuncs(docAnalysis, myComponent.CodeModule), RID_STR_COMMON_ATTRIBUTE_PROCEDURES
181            .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NUMBER_OF_LINES
182            numLines = VBNumLines(docAnalysis, myComponent.CodeModule)
183            .Values.Add numLines, RID_STR_COMMON_ATTRIBUTE_NUMBER_OF_LINES
184
185            If bUserFormWithEmptyCodeModule Then
186                .Attributes.Add RID_STR_COMMON_ATTRIBUTE_SIGNATURE
187                .Values.Add RID_STR_COMMON_NA, RID_STR_COMMON_ATTRIBUTE_SIGNATURE
188            Else
189                .Attributes.Add RID_STR_COMMON_ATTRIBUTE_SIGNATURE
190                .Values.Add MD5HashString( _
191                    myComponent.CodeModule.Lines(1, myComponent.CodeModule.CountOfLines)), _
192                    RID_STR_COMMON_ATTRIBUTE_SIGNATURE
193            End If
194
195            docAnalysis.MacroTotalNumLines = numLines + docAnalysis.MacroTotalNumLines
196        End With
197
198        ' User Forms - control details
199        If (myComponent.Type = vbext_ct_MSForm) And Not bUserFormWithEmptyCodeModule Then
200            myIssue.Attributes.Add RID_STR_COMMON_ATTRIBUTE_CONTROLS
201            myIssue.Values.Add myComponent.Designer.Controls.count, RID_STR_COMMON_ATTRIBUTE_CONTROLS
202            docAnalysis.MacroNumUserForms = 1 + docAnalysis.MacroNumUserForms
203            docAnalysis.MacroNumUserFormControls = myComponent.Designer.Controls.count + docAnalysis.MacroNumUserFormControls
204
205            Dim myControl As Control
206            Dim controlTypes As String
207            Dim myType As String
208
209            Set myContolDict = New Scripting.Dictionary
210
211            For Each myControl In myComponent.Designer.Controls
212                myType = TypeName(myControl)
213                If myContolDict.Exists(myType) Then
214                   myContolDict.item(myType) = myContolDict.item(myType) + 1
215                Else
216                   myContolDict.Add myType, 1
217                End If
218                If userFormTypesDict.Exists(myType) Then
219                   userFormTypesDict.item(myType) = userFormTypesDict.item(myType) + 1
220                Else
221                   userFormTypesDict.Add myType, 1
222                End If
223            Next
224
225            If myComponent.Designer.Controls.count > 0 Then
226                Dim count As Long
227                Dim vKeyArray As Variant
228                Dim vItemArray As Variant
229
230                vKeyArray = myContolDict.Keys
231                vItemArray = myContolDict.Items
232
233                controlTypes = ""
234                For count = 0 To myContolDict.count - 1
235                    controlTypes = controlTypes & vKeyArray(count) & " " & CInt(vItemArray(count)) & " "
236                Next count
237                myIssue.Attributes.Add RID_STR_COMMON_ATTRIBUTE_USERFORM_TYPE
238                myIssue.Values.Add controlTypes, RID_STR_COMMON_ATTRIBUTE_USERFORM_TYPE
239
240                myIssue.Attributes.Add RID_STR_COMMON_ATTRIBUTE_USERFORM_TYPES_COUNT
241                myIssue.Values.Add myContolDict.count, RID_STR_COMMON_ATTRIBUTE_USERFORM_TYPES_COUNT
242
243                docAnalysis.MacroNumUserFormControlTypes = myContolDict.count + docAnalysis.MacroNumUserFormControlTypes
244            End If
245            Set myContolDict = Nothing
246        End If
247
248        'Check for occurrence of " Me " in Form and Class Modules
249        If myComponent.Type = vbext_ct_MSForm Or _
250            myComponent.Type = vbext_ct_ClassModule Then
251
252            Dim strFind As String
253            strFind = ""
254            count = 0
255            strFind = VBFindLines(docAnalysis, myComponent.CodeModule, "Me", count, bWholeWord:=True)
256'            If (strFind <> "") Then MsgBox strFind
257
258            If count > 0 Then
259                myIssue.Attributes.Add RID_STR_COMMON_ATTRIBUTE_CLASS_ME_COUNT
260                myIssue.Values.Add count, RID_STR_COMMON_ATTRIBUTE_CLASS_ME_COUNT
261            End If
262        End If
263
264        docAnalysis.IssuesCountArray(CID_VBA_MACROS) = _
265            docAnalysis.IssuesCountArray(CID_VBA_MACROS) + 1
266        docAnalysis.Issues.Add myIssue
267        docAnalysis.MacroIssuesCount = docAnalysis.MacroIssuesCount + 1
268
269        Set myIssue = Nothing
270
271FOREACH_CONTINUE:
272        'No equiv to C continue in VB
273    Next myComponent 'End - For Each myComponent
274
275    If docAnalysis.IssuesCountArray(CID_VBA_MACROS) > 0 Then
276        Analyze_VBEReferences docAnalysis, currDoc
277        docAnalysis.HasMacros = True
278    End If
279
280FinalExit:
281    docAnalysis.MacroOverallClass = ClassifyDocOverallMacroClass(docAnalysis)
282
283    Set myProject = Nothing
284    Set myIssue = Nothing
285    Set myContolDict = Nothing
286    Exit Function
287
288HandleErrors:
289    WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
290    Resume FinalExit
291End Function
292
293Function CheckOnlyEmptyProject(docAnalysis As DocumentAnalysis, currDoc As Object) As Boolean
294    On Error GoTo HandleErrors
295    Dim currentFunctionName As String
296    currentFunctionName = "CheckOnlyEmptyProject"
297    Dim myProject As VBProject
298    Set myProject = getAppSpecificVBProject(currDoc)
299    Dim myVBComponent As VBComponent
300
301    For Each myVBComponent In myProject.VBComponents
302        If Not CheckEmptyProject(docAnalysis, myProject, myVBComponent) Then
303            CheckOnlyEmptyProject = False
304            GoTo FinalExit
305        End If
306    Next myVBComponent
307
308    CheckOnlyEmptyProject = True
309
310FinalExit:
311    Set myProject = Nothing
312    Exit Function
313
314HandleErrors:
315    WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
316    Resume FinalExit
317End Function
318
319Sub Analyze_VBEReferences(docAnalysis As DocumentAnalysis, currDoc As Object)
320    On Error GoTo HandleErrors
321    Dim currentFunctionName As String
322    currentFunctionName = "Analyze_VBEReferences"
323    'References
324    Dim Ref As Reference
325    Dim fso As Scripting.FileSystemObject
326    Dim myVBProject As VBProject
327    Dim myVBComponent As VBComponent
328
329    Set fso = New Scripting.FileSystemObject
330
331    If CheckOnlyEmptyProject(docAnalysis, currDoc) Then
332        Exit Sub
333    End If
334    Set myVBProject = getAppSpecificVBProject(currDoc)
335
336    For Each Ref In myVBProject.References
337        Analyze_VBEReferenceSingle docAnalysis, Ref, fso
338    Next Ref
339
340FinalExit:
341    Set myVBProject = Nothing
342    Set fso = Nothing
343    Exit Sub
344
345HandleErrors:
346    WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
347    Resume FinalExit
348End Sub
349
350Sub Analyze_VBEReferenceSingle(docAnalysis As DocumentAnalysis, Ref As Reference, fso As Scripting.FileSystemObject)
351    On Error GoTo HandleErrors
352    Dim currentFunctionName As String
353    currentFunctionName = "Analyze_VBEReferenceSingle"
354    'References
355    Dim myIssue As IssueInfo
356    Dim bBadRef As Boolean
357
358    Set myIssue = New IssueInfo
359    With myIssue
360        .IssueID = CID_INFORMATION_REFS
361        .IssueType = RID_STR_COMMON_ISSUE_INFORMATION
362        .SubType = RID_STR_COMMON_SUBISSUE_REFERENCES
363        .Location = .CLocationDocument
364
365        .IssueTypeXML = CSTR_ISSUE_INFORMATION
366        .SubTypeXML = CSTR_SUBISSUE_REFERENCES
367        .locationXML = .CXMLLocationDocument
368
369        If Ref.GUID = "" Then
370            bBadRef = True
371        Else
372            bBadRef = False
373        End If
374        If Not bBadRef Then
375            .SubLocation = LCase(fso.GetFileName(Ref.FullPath))
376            .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME
377            .Values.Add Ref.name, RID_STR_COMMON_ATTRIBUTE_NAME
378            .Attributes.Add RID_STR_COMMON_ATTRIBUTE_DESCRIPTION
379            .Values.Add Ref.Description, RID_STR_COMMON_ATTRIBUTE_DESCRIPTION
380            .Attributes.Add RID_STR_COMMON_ATTRIBUTE_FILE
381            .Values.Add LCase(fso.GetFileName(Ref.FullPath)), RID_STR_COMMON_ATTRIBUTE_FILE
382            .Attributes.Add RID_STR_COMMON_ATTRIBUTE_PATH
383            .Values.Add LCase(Ref.FullPath), RID_STR_COMMON_ATTRIBUTE_PATH
384        Else
385            .SubLocation = RID_STR_COMMON_NA
386            .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME
387            .Values.Add RID_STR_COMMON_ATTRIBUTE_MISSING, RID_STR_COMMON_ATTRIBUTE_NAME
388            .Attributes.Add RID_STR_COMMON_ATTRIBUTE_DESCRIPTION
389            .Values.Add RID_STR_COMMON_ATTRIBUTE_CHECK_DOCUMENT_REFERENCES, RID_STR_COMMON_ATTRIBUTE_DESCRIPTION
390        End If
391
392        .Attributes.Add RID_STR_COMMON_ATTRIBUTE_MAJOR
393        .Values.Add IIf(Not bBadRef, Ref.Major, ""), RID_STR_COMMON_ATTRIBUTE_MAJOR
394        .Attributes.Add RID_STR_COMMON_ATTRIBUTE_MINOR
395        .Values.Add IIf(Not bBadRef, Ref.Minor, ""), RID_STR_COMMON_ATTRIBUTE_MINOR
396
397        .Attributes.Add RID_STR_COMMON_ATTRIBUTE_TYPE
398        .Values.Add IIf(Ref.Type = vbext_rk_Project, RID_STR_COMMON_ATTRIBUTE_PROJECT, RID_STR_COMMON_ATTRIBUTE_TYPELIB), RID_STR_COMMON_ATTRIBUTE_TYPE
399
400        .Attributes.Add RID_STR_COMMON_ATTRIBUTE_BUILTIN
401        .Values.Add IIf(Ref.BuiltIn, RID_STR_COMMON_ATTRIBUTE_BUILTIN, RID_STR_COMMON_ATTRIBUTE_CUSTOM), RID_STR_COMMON_ATTRIBUTE_BUILTIN
402        .Attributes.Add RID_STR_COMMON_ATTRIBUTE_ISBROKEN
403        .Values.Add IIf(bBadRef, RID_STR_COMMON_ATTRIBUTE_BROKEN, RID_STR_COMMON_ATTRIBUTE_INTACT), RID_STR_COMMON_ATTRIBUTE_ISBROKEN
404        .Attributes.Add RID_STR_COMMON_ATTRIBUTE_GUID
405        .Values.Add IIf(Ref.Type = vbext_rk_TypeLib, Ref.GUID, ""), RID_STR_COMMON_ATTRIBUTE_GUID
406    End With
407
408    docAnalysis.References.Add myIssue
409
410FinalExit:
411    Set myIssue = Nothing
412    Exit Sub
413
414HandleErrors:
415    WriteDebugLevelTwo currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
416    Resume FinalExit
417End Sub
418
419Sub Analyze_MacrosForPortabilityIssues(docAnalysis As DocumentAnalysis, myProject As VBProject, myComponent As VBComponent)
420    On Error GoTo HandleErrors
421    Dim currentFunctionName As String
422    currentFunctionName = "Analyze_MacrosForPortabilityIssues"
423    Dim myIssue As IssueInfo
424    Dim count As Long
425
426    ' Code Modules
427    Dim strFind As String
428    strFind = VBFindLines(docAnalysis, myComponent.CodeModule, "CreateObject", count, bWholeWord:=True) & _
429        VBFindLines(docAnalysis, myComponent.CodeModule, "GetObject", count, bWholeWord:=True) & _
430        VBFindLines(docAnalysis, myComponent.CodeModule, "ADODB.", count, True, True) & _
431        VBFindLines(docAnalysis, myComponent.CodeModule, "Word.", count, True, True) & _
432        VBFindLines(docAnalysis, myComponent.CodeModule, "Excel.", count, True, True) & _
433        VBFindLines(docAnalysis, myComponent.CodeModule, "PowerPoint.", count, True, True) & _
434        VBFindLines(docAnalysis, myComponent.CodeModule, "Access.", count, True, True) & _
435        VBFindLines(docAnalysis, myComponent.CodeModule, "Declare Function ", count, False) & _
436        VBFindLines(docAnalysis, myComponent.CodeModule, "Declare Sub ", count, False)
437
438
439    If (strFind <> "") And (myComponent.Type <> vbext_ct_Document) Then
440        Set myIssue = New IssueInfo
441        With myIssue
442            .IssueID = CID_PORTABILITY
443            .IssueType = RID_STR_COMMON_ISSUE_PORTABILITY
444            .SubType = RID_STR_COMMON_SUBISSUE_EXTERNAL_REFERENCES_IN_MACROS
445            .Location = .CLocationDocument
446
447            .IssueTypeXML = CSTR_ISSUE_PORTABILITY
448            .SubTypeXML = CSTR_SUBISSUE_EXTERNAL_REFERENCES_IN_MACRO
449            .locationXML = .CXMLLocationDocument
450
451            .SubLocation = VBComponentType(myComponent)
452
453            .Attributes.Add RID_STR_COMMON_ATTRIBUTE_PROJECT
454            .Values.Add myProject.name
455            .Attributes.Add RID_STR_COMMON_ATTRIBUTE_COMPONENT
456            .Values.Add myComponent.name
457            .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NON_PORTABLE_EXTERNAL_REFERENCES
458            .Values.Add RID_STR_COMMON_ATTRIBUTE_INCLUDING & vbLf & Left(strFind, Len(strFind) - 1)
459            .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NON_PORTABLE_EXTERNAL_REFERENCES_COUNT
460            .Values.Add count, RID_STR_COMMON_ATTRIBUTE_NON_PORTABLE_EXTERNAL_REFERENCES_COUNT
461        End With
462        docAnalysis.IssuesCountArray(CID_PORTABILITY) = _
463            docAnalysis.IssuesCountArray(CID_PORTABILITY) + 1
464        docAnalysis.Issues.Add myIssue
465        docAnalysis.MacroNumExternalRefs = count + docAnalysis.MacroNumExternalRefs
466        docAnalysis.MacroIssuesCount = docAnalysis.MacroIssuesCount + 1
467    End If
468
469FinalExit:
470    Set myIssue = Nothing
471    Exit Sub
472
473
474HandleErrors:
475    WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
476Resume FinalExit
477End Sub
478
479'Find Lines in  code module containing strFind and return list of them
480Function VBFindLines(docAnalysis As DocumentAnalysis, vbcm As CodeModule, strFind As String, _
481    count As Long, _
482    Optional bInProcedure As Boolean = True, _
483    Optional bUsingNew As Boolean = False, _
484    Optional bWholeWord As Boolean = False, _
485    Optional bMatchCase As Boolean = False) As String
486    On Error GoTo HandleErrors
487    Dim currentFunctionName As String
488    currentFunctionName = "VBFindLines"
489    Dim lngStartLine As Long
490    Dim lngStartCol As Long
491    Dim lngEndLine As Long
492    Dim lngEndCol As Long
493    Dim strLine As String
494    lngStartLine = 1
495    lngStartCol = 1
496    lngEndLine = vbcm.CountOfLines
497    Dim tmpString As String
498    If (vbcm.CountOfLines = 0) Then
499        Exit Function
500    End If
501    tmpString = vbcm.Lines(vbcm.CountOfLines, 1)
502    lngEndCol = Len(vbcm.Lines(vbcm.CountOfLines, 1))
503    Dim lngType As Long
504    Dim strProc As String
505    Dim retStr As String
506
507    ' Search
508    Do While vbcm.Find(strFind, lngStartLine, _
509        lngStartCol, lngEndLine, lngEndCol, bWholeWord, bMatchCase)
510
511        'Ignore any lines using this func
512        If InStr(1, vbcm.Lines(lngStartLine, 1), "VBFindLines") <> 0 Then
513            GoTo CONTINUE_LOOP
514        End If
515
516        If bInProcedure Then
517            If bUsingNew Then
518                If InStr(1, vbcm.Lines(lngStartLine, 1), "New") <> 0 Then
519                    strProc = vbcm.ProcOfLine(lngStartLine, lngType)
520                Else
521                    strProc = ""
522                End If
523            Else
524                strProc = vbcm.ProcOfLine(lngStartLine, lngType)
525            End If
526            If strProc = "" Then GoTo CONTINUE_LOOP
527
528            VBFindLines = VBFindLines & "[" & strProc & " ( ) - " & lngStartLine & " ]" & _
529                vbLf & vbcm.Lines(lngStartLine, 1) & vbLf
530        Else
531            strProc = vbcm.Lines(lngStartLine, 1)
532            If strProc = "" Then GoTo CONTINUE_LOOP
533
534            'Can be External refs, Const, Type or variable declarations
535            If InStr(1, vbcm.Lines(lngStartLine, 1), "Declare Function") <> 0 Then
536            VBFindLines = VBFindLines & "[" & RID_STR_COMMON_DEC_TO_EXTERNAL_LIBRARY & " - " & lngStartLine & " ]" & _
537                vbLf & strProc & vbLf
538            Else
539                VBFindLines = VBFindLines & "[" & RID_STR_COMMON_VB_COMPONENT_MODULE & " " & strFind & _
540                    " - " & lngStartLine & " ]" & vbLf
541            End If
542        End If
543        count = count + 1
544
545CONTINUE_LOOP:
546        'Reset Params to search for next hit
547        lngStartLine = lngEndLine + 1
548        lngStartCol = 1
549        lngEndLine = vbcm.CountOfLines
550        lngEndCol = Len(vbcm.Lines(vbcm.CountOfLines, 1))
551
552        If lngStartLine >= lngEndLine Then Exit Function
553
554    Loop 'End - Do While vbcm.Find
555    VBFindLines = VBFindLines
556    Exit Function
557
558HandleErrors:
559    WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
560End Function
561Function VBNumLines(docAnalysis As DocumentAnalysis, vbcm As CodeModule) As Long
562    On Error GoTo HandleErrors
563    Dim currentFunctionName As String
564    currentFunctionName = "VBNumLines"
565    Dim cLines As Long
566    Dim lngType As Long
567    Dim strProc As String
568
569    'Issue: Just give line count in module to be in sync with Macro Analysis and Migration Wizard
570    VBNumLines = vbcm.CountOfLines
571
572    'For cLines = 1 To vbcm.CountOfLines
573    '    strProc = vbcm.ProcOfLine(cLines, lngType)
574    '    If strProc <> "" Then
575    '        VBNumLines = VBNumLines - _
576    '            (vbcm.ProcBodyLine(strProc, lngType) - vbcm.ProcStartLine(strProc, lngType))
577    '        cLines = cLines + vbcm.ProcCountLines(strProc, lngType) - 1
578    '    End If
579    'Next
580    Exit Function
581
582HandleErrors:
583    WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
584End Function
585Function VBNumFuncs(docAnalysis As DocumentAnalysis, vbcm As CodeModule) As Long
586    On Error GoTo HandleErrors
587    Dim currentFunctionName As String
588    currentFunctionName = "VBNumFuncs"
589    Dim cLines As Long
590    Dim lngType As Long
591    Dim strProc As String
592
593    For cLines = 1 To vbcm.CountOfLines
594        strProc = vbcm.ProcOfLine(cLines, lngType)
595        If strProc <> "" Then
596            VBNumFuncs = VBNumFuncs + 1
597            cLines = cLines + vbcm.ProcCountLines(strProc, lngType) - 1
598        End If
599    Next
600    Exit Function
601HandleErrors:
602    WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
603End Function
604
605Function VBComponentType(vbc As VBComponent) As String
606    Select Case vbc.Type
607        Case vbext_ct_StdModule
608            VBComponentType = RID_STR_COMMON_VB_COMPONENT_STANDARD
609        Case vbext_ct_ClassModule
610            VBComponentType = RID_STR_COMMON_VB_COMPONENT_CLASS
611        Case vbext_ct_MSForm
612            VBComponentType = RID_STR_COMMON_VB_COMPONENT_USER_FORM
613        Case vbext_ct_Document
614            VBComponentType = RID_STR_COMMON_VB_COMPONENT_DOCUMENT
615        Case 11 'vbext_ct_ActiveX Designer
616            VBComponentType = RID_STR_COMMON_VB_COMPONENT_ACTIVEX_DESIGNER
617        Case Else
618            VBComponentType = RID_STR_COMMON_UNKNOWN
619    End Select
620End Function
621
622Function CheckEmptyProject(docAnalysis As DocumentAnalysis, myProject As VBProject, myComponent As VBComponent) As Boolean
623    On Error GoTo HandleErrors
624    Dim currentFunctionName As String
625    currentFunctionName = "CheckEmptyProject"
626    Dim bEmptyProject As Boolean
627
628    'Bug: Can have empty project with different name from default, would be picked up
629    ' as not empty.
630    'bEmptyProject = _
631    '        (StrComp(myProject.name, CTOPLEVEL_PROJECT) = 0) And _
632    '        (VBNumFuncs(docAnalysis, myComponent.CodeModule) = 0) And _
633    '        (VBNumLines(docAnalysis, myComponent.CodeModule) < 3)
634
635    ' Code Modules
636    Dim strFind As String
637    Dim count As Long
638    'Check for:
639    'Public Const myFoo ....
640    'Public Declare Function ....
641    'Public myVar As ...
642    strFind = VBFindLines(docAnalysis, myComponent.CodeModule, "Public", _
643        count, bInProcedure:=False, bWholeWord:=True, bMatchCase:=True)
644
645    bEmptyProject = _
646            (VBNumFuncs(docAnalysis, myComponent.CodeModule) = 0) And _
647            (VBNumLines(docAnalysis, myComponent.CodeModule) < 3) And _
648            (strFind = "")
649
650    CheckEmptyProject = IIf(bEmptyProject, True, False)
651    Exit Function
652
653
654HandleErrors:
655    WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
656End Function
657
658Function getCustomDocPropTypeAsString(propType As MsoDocProperties)
659    Dim Str As String
660
661    Select Case propType
662    Case msoPropertyTypeBoolean
663        Str = RID_STR_COMMON_YES_OR_NO
664    Case msoPropertyTypeDate
665        Str = RID_STR_COMMON_DATE
666    Case msoPropertyTypeFloat
667        Str = RID_STR_COMMON_NUMBER
668    Case msoPropertyTypeNumber
669        Str = RID_STR_COMMON_NUMBER
670    Case msoPropertyTypeString
671        Str = RID_STR_COMMON_TEXT
672    Case Else
673        Str = "Unknown"
674    End Select
675
676    getCustomDocPropTypeAsString = Str
677End Function
678
679Sub HandleProtectedDocInvalidPassword(docAnalysis As DocumentAnalysis, strError As String, fso As FileSystemObject)
680    On Error GoTo HandleErrors
681    Dim currentFunctionName As String
682    currentFunctionName = "HandleProtectedDocInvalidPassword"
683    Dim f As File
684    Set f = fso.GetFile(docAnalysis.name)
685
686    docAnalysis.Application = RID_STR_COMMON_PASSWORD_SKIPDOC
687
688    On Error Resume Next
689    docAnalysis.PageCount = 0
690    docAnalysis.Created = f.DateCreated
691    docAnalysis.Modified = f.DateLastModified
692    docAnalysis.Accessed = f.DateLastAccessed
693    docAnalysis.Printed = DateValue("01/01/1900")
694    docAnalysis.SavedBy = RID_STR_COMMON_NA
695    docAnalysis.Revision = 0
696    docAnalysis.Template = RID_STR_COMMON_NA
697    On Error GoTo HandleErrors
698
699    Dim myIssue As IssueInfo
700    Set myIssue = New IssueInfo
701
702    With myIssue
703        .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES
704        .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES
705        .SubType = RID_STR_COMMON_SUBISSUE_INVALID_PASSWORD_ENTERED
706        .Location = .CLocationDocument
707
708        .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES
709        .SubTypeXML = CSTR_SUBISSUE_INVALID_PASSWORD_ENTERED
710        .locationXML = .CXMLLocationDocument
711
712        .Attributes.Add RID_STR_COMMON_ATTRIBUTE_PASSWORD
713        .Values.Add strError
714
715        docAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _
716                docAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1
717    End With
718
719    docAnalysis.Issues.Add myIssue
720
721FinalExit:
722    Set myIssue = Nothing
723    Set f = Nothing
724    Exit Sub
725
726HandleErrors:
727    WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
728    Resume FinalExit
729End Sub
730
731Sub Analyze_OLEEmbeddedSingleShape(docAnalysis As DocumentAnalysis, aShape As Shape, mySubLocation As Variant)
732
733    On Error GoTo HandleErrors
734    Dim currentFunctionName As String
735    currentFunctionName = "Analyze_OLEEmbeddedSingleShape"
736    Dim myIssue As IssueInfo
737    Dim bOleObject As Boolean
738    Dim TypeAsString As String
739    Dim XMLTypeAsString As String
740    Dim objName As String
741
742    bOleObject = (aShape.Type = msoEmbeddedOLEObject) Or _
743                    (aShape.Type = msoLinkedOLEObject) Or _
744                    (aShape.Type = msoOLEControlObject)
745
746    If Not bOleObject Then Exit Sub
747
748    aShape.Select
749    Select Case aShape.Type
750        Case msoEmbeddedOLEObject
751            TypeAsString = RID_STR_COMMON_OLE_EMBEDDED
752            XMLTypeAsString = CSTR_SUBISSUE_OLE_EMBEDDED
753        Case msoLinkedOLEObject
754            TypeAsString = RID_STR_COMMON_OLE_LINKED
755            XMLTypeAsString = CSTR_SUBISSUE_OLE_LINKED
756        Case msoOLEControlObject
757            TypeAsString = RID_STR_COMMON_OLE_CONTROL
758            XMLTypeAsString = CSTR_SUBISSUE_OLE_CONTROL
759        Case Else
760            TypeAsString = RID_STR_COMMON_OLE_UNKNOWN
761            XMLTypeAsString = CSTR_SUBISSUE_OLE_UNKNOWN
762    End Select
763
764    Dim appStr As String
765    appStr = getAppSpecificApplicationName
766
767    Set myIssue = New IssueInfo
768    With myIssue
769        .IssueID = CID_PORTABILITY
770        .IssueType = RID_STR_COMMON_ISSUE_PORTABILITY
771        .SubType = TypeAsString
772        .Location = .CLocationPage
773        .SubLocation = mySubLocation
774
775        .IssueTypeXML = CSTR_ISSUE_PORTABILITY
776        .SubTypeXML = XMLTypeAsString
777        .locationXML = .CXMLLocationPage
778
779        .Line = aShape.top
780        .column = aShape.Left
781
782        If aShape.name <> "" Then
783            .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME
784            .Values.Add aShape.name
785        End If
786
787        If aShape.Type = msoEmbeddedOLEObject Or _
788           aShape.Type = msoOLEControlObject Then
789            Dim objType As String
790            On Error Resume Next
791
792            objType = getAppSpecificOLEClassType(aShape)
793
794            If objType = "" Then GoTo FinalExit
795            .Attributes.Add RID_STR_COMMON_ATTRIBUTE_OBJECT_TYPE
796            .Values.Add objType
797
798            If aShape.Type = msoOLEControlObject Then
799                docAnalysis.MacroNumOLEControls = 1 + docAnalysis.MacroNumOLEControls
800            End If
801
802            If appStr = CAPPNAME_POWERPOINT Then
803            '#114127: Too many open windows
804            'Checking for OLEFormat.Object is Nothing or IsEmpty still causes problem
805                If objType <> "Equation.3" Then
806                    objName = aShape.OLEFormat.Object.name
807                    If Err.Number = 0 Then
808                        If aShape.name <> objName Then
809                            .Attributes.Add RID_STR_COMMON_ATTRIBUTE_OBJECT_NAME
810                            .Values.Add objName
811                       End If
812                    End If
813                End If
814            Else
815                If Not (aShape.OLEFormat.Object) Is Nothing Then
816                    objName = aShape.OLEFormat.Object.name
817                    If Err.Number = 0 Then
818                        If aShape.name <> objName Then
819                            .Attributes.Add RID_STR_COMMON_ATTRIBUTE_OBJECT_NAME
820                            .Values.Add objName
821                        End If
822                    End If
823                End If
824            End If
825
826            On Error GoTo HandleErrors
827        End If
828
829        If aShape.Type = msoLinkedOLEObject Then
830            If appStr <> CAPPNAME_WORD Then
831                On Error Resume Next
832                Dim path As String
833                path = aShape.OLEFormat.Object.SourceFullName
834                If Err.Number = 0 Then
835                    .Attributes.Add RID_STR_COMMON_ATTRIBUTE_SOURCE
836                    .Values.Add path
837                End If
838                On Error GoTo HandleErrors
839            Else
840                .Attributes.Add RID_STR_COMMON_ATTRIBUTE_SOURCE
841                .Values.Add aShape.LinkFormat.SourceFullName
842            End If
843        End If
844
845        docAnalysis.IssuesCountArray(CID_PORTABILITY) = _
846            docAnalysis.IssuesCountArray(CID_PORTABILITY) + 1
847    End With
848    docAnalysis.Issues.Add myIssue
849
850FinalExit:
851    Set myIssue = Nothing
852    Exit Sub
853
854HandleErrors:
855    WriteDebugLevelTwo currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
856    Resume FinalExit
857End Sub
858
859Sub Analyze_Lines(docAnalysis As DocumentAnalysis, myShape As Shape, mySubLocation As Variant)
860    On Error GoTo HandleErrors
861    Dim currentFunctionName As String
862    currentFunctionName = "Analyze_Lines"
863
864    If myShape.Line.Style = msoLineSingle Or _
865       myShape.Line.Style = msoLineStyleMixed Then Exit Sub
866
867    Dim myIssue As IssueInfo
868    Set myIssue = New IssueInfo
869
870    With myIssue
871        .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES
872        .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES
873        .SubType = RID_RESXLS_COST_LineStyle
874        .Location = .CLocationPage
875        .SubLocation = mySubLocation
876
877        .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES
878        .SubTypeXML = CSTR_SUBISSUE_LINE
879        .locationXML = .CXMLLocationPage
880
881        .Line = myShape.top
882        .column = myShape.Left
883
884        If myShape.name <> "" Then
885            .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME
886            .Values.Add myShape.name
887        End If
888
889        AddIssueDetailsNote myIssue, 0, RID_STR_COMMON_SUBISSUE_LINE_NOTE
890
891        docAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _
892                docAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1
893    End With
894
895    docAnalysis.Issues.Add myIssue
896
897FinalExit:
898    Set myIssue = Nothing
899    Exit Sub
900
901HandleErrors:
902    WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
903    Resume FinalExit
904End Sub
905
906Sub Analyze_Transparency(docAnalysis As DocumentAnalysis, myShape As Shape, mySubLocation As Variant)
907    On Error GoTo HandleErrors
908    Dim currentFunctionName As String
909    currentFunctionName = "Analyze_Transparency"
910
911    If Not myShape.Type = msoPicture Then Exit Sub
912
913    Dim bHasTransparentBkg
914    bHasTransparentBkg = False
915
916    On Error Resume Next
917    If myShape.PictureFormat.TransparentBackground = msoTrue Then
918        If Error.Number = 0 Then
919            bHasTransparentBkg = True
920        End If
921    End If
922
923    On Error GoTo HandleErrors
924    If Not bHasTransparentBkg Then Exit Sub
925
926    Dim myIssue As IssueInfo
927    Set myIssue = New IssueInfo
928
929    With myIssue
930        .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES
931        .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES
932        .SubType = RID_RESXLS_COST_Transparent
933        .Location = .CLocationSlide
934        .SubLocation = mySubLocation
935
936        .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES
937        .SubTypeXML = CSTR_SUBISSUE_TRANSPARENCY
938        .locationXML = .CXMLLocationPage
939
940        .Line = myShape.top
941        .column = myShape.Left
942
943        If myShape.name <> "" Then
944            .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME
945            .Values.Add myShape.name
946        End If
947
948        AddIssueDetailsNote myIssue, 0, RID_STR_COMMON_SUBISSUE_TRANSPARENCY_NOTE
949
950        docAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _
951                docAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1
952    End With
953
954    docAnalysis.Issues.Add myIssue
955
956FinalExit:
957    Set myIssue = Nothing
958    Exit Sub
959
960HandleErrors:
961    WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
962    Resume FinalExit
963End Sub
964
965Sub Analyze_Gradients(docAnalysis As DocumentAnalysis, myShape As Shape, mySubLocation As Variant)
966    On Error GoTo HandleErrors
967    Dim currentFunctionName As String
968    currentFunctionName = "Analyze_Gradients"
969
970    If myShape.Fill.Type <> msoFillGradient Then Exit Sub
971
972    Dim bUsesPresetGradient, bUsesFromCorner, bUsesFromCenter
973    bUsesPresetGradient = False
974    bUsesFromCorner = False
975    bUsesFromCenter = False
976
977    On Error Resume Next
978    If myShape.Fill.PresetGradientType <> msoPresetGradientMixed Then
979        If Error.Number = 0 Then
980            bUsesPresetGradient = True
981        End If
982    End If
983    If myShape.Fill.GradientStyle <> msoGradientFromCorner Then
984        If Error.Number = 0 Then
985            bUsesFromCorner = True
986        End If
987    End If
988    If myShape.Fill.GradientStyle <> msoGradientFromCenter Then
989        If Error.Number = 0 Then
990            bUsesFromCenter = True
991        End If
992    End If
993
994    On Error GoTo HandleErrors
995    If Not bUsesPresetGradient And Not bUsesFromCorner _
996       And Not bUsesFromCenter Then Exit Sub
997
998    Dim myIssue As IssueInfo
999    Set myIssue = New IssueInfo
1000
1001    With myIssue
1002        .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES
1003        .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES
1004        .SubType = RID_RESXLS_COST_GradientStyle
1005        .Location = .CLocationSlide
1006        .SubLocation = mySubLocation
1007
1008        .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES
1009        .SubTypeXML = CSTR_SUBISSUE_GRADIENT
1010        .locationXML = .CXMLLocationSlide
1011
1012        .Line = myShape.top
1013        .column = myShape.Left
1014
1015        If myShape.name <> "" Then
1016            .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME
1017            .Values.Add myShape.name
1018        End If
1019
1020        If bUsesPresetGradient Then
1021            AddIssueDetailsNote myIssue, 0, RID_STR_COMMON_SUBISSUE_GRADIENT_PRESET_NOTE
1022        ElseIf bUsesFromCorner Then
1023            AddIssueDetailsNote myIssue, 0, RID_STR_COMMON_SUBISSUE_GRADIENT_CORNER_NOTE
1024        Else
1025            AddIssueDetailsNote myIssue, 0, RID_STR_COMMON_SUBISSUE_GRADIENT_CENTER_NOTE
1026        End If
1027
1028        docAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _
1029                docAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1
1030    End With
1031
1032    docAnalysis.Issues.Add myIssue
1033
1034FinalExit:
1035    Set myIssue = Nothing
1036    Exit Sub
1037
1038HandleErrors:
1039    WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
1040    Resume FinalExit
1041End Sub
1042
1043Private Function CreateFullPath(newPath As String, fso As FileSystemObject)
1044    'We don't want to create 'c:\'
1045    If (Len(newPath) < 4) Then
1046        Exit Function
1047    End If
1048
1049    'Create parent folder first
1050    If (Not fso.FolderExists(fso.GetParentFolderName(newPath))) Then
1051        CreateFullPath fso.GetParentFolderName(newPath), fso
1052    End If
1053
1054    If (Not fso.FolderExists(newPath)) Then
1055        fso.CreateFolder (newPath)
1056    End If
1057End Function
1058
1059Function GetPreparedFullPath(sourceDocPath As String, startDir As String, storeToDir As String, _
1060    fso As FileSystemObject) As String
1061    On Error GoTo HandleErrors
1062    Dim currentFunctionName As String
1063    currentFunctionName = "GetPreparedFullPath"
1064    GetPreparedFullPath = ""
1065
1066    Dim preparedPath As String
1067
1068    preparedPath = Right(sourceDocPath, Len(sourceDocPath) - Len(startDir))
1069    If Left(preparedPath, 1) = "\" Then
1070        preparedPath = Right(preparedPath, Len(preparedPath) - 1)
1071    End If
1072
1073    'Allow for root folder C:\
1074    If Right(storeToDir, 1) <> "\" Then
1075        preparedPath = storeToDir & "\" & CSTR_COMMON_PREPARATION_FOLDER & "\" & preparedPath
1076    Else
1077        preparedPath = storeToDir & CSTR_COMMON_PREPARATION_FOLDER & "\" & preparedPath
1078    End If
1079
1080    'Debug: MsgBox "Preppath: " & preparedPath
1081    CreateFullPath fso.GetParentFolderName(preparedPath), fso
1082
1083    'Only set if folder to save to exists or has been created, otherwise return ""
1084    GetPreparedFullPath = preparedPath
1085
1086FinalExit:
1087    Exit Function
1088
1089HandleErrors:
1090    WriteDebugLevelTwo currentFunctionName & " : " & sourceDocPath & ": " & Err.Number & " " & Err.Description & " " & Err.Source
1091    Resume FinalExit
1092End Function
1093
1094Function ClassifyDocOverallMacroClass(docAnalysis As DocumentAnalysis) As EnumDocOverallMacroClass
1095    ClassifyDocOverallMacroClass = enMacroNone
1096
1097    If Not docAnalysis.HasMacros Then Exit Function
1098
1099    If (docAnalysis.MacroTotalNumLines >= CMACRO_LINECOUNT_MEDIUM_LBOUND) Then
1100        If (docAnalysis.MacroNumExternalRefs > 0) Or _
1101            (docAnalysis.MacroNumOLEControls > 0 Or docAnalysis.MacroNumFieldsUsingMacros > 0) Or _
1102            docAnalysis.MacroNumUserForms > 0 Then
1103            ClassifyDocOverallMacroClass = enMacroComplex
1104        Else
1105            ClassifyDocOverallMacroClass = enMacroMedium
1106        End If
1107    Else
1108        ClassifyDocOverallMacroClass = enMacroSimple
1109    End If
1110
1111End Function
1112
1113