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