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