1VERSION 1.0 CLASS 2BEGIN 3 MultiUse = -1 'True 4END 5Attribute VB_Name = "MigrationAnalyser" 6Attribute VB_GlobalNameSpace = False 7Attribute VB_Creatable = False 8Attribute VB_PredeclaredId = False 9Attribute VB_Exposed = False 10'************************************************************************* 11' 12' Licensed to the Apache Software Foundation (ASF) under one 13' or more contributor license agreements. See the NOTICE file 14' distributed with this work for additional information 15' regarding copyright ownership. The ASF licenses this file 16' to you under the Apache License, Version 2.0 (the 17' "License"); you may not use this file except in compliance 18' with the License. You may obtain a copy of the License at 19' 20' http://www.apache.org/licenses/LICENSE-2.0 21' 22' Unless required by applicable law or agreed to in writing, 23' software distributed under the License is distributed on an 24' "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 25' KIND, either express or implied. See the License for the 26' specific language governing permissions and limitations 27' under the License. 28' 29'************************************************************************* 30 31Option Explicit 32 33 34Private mAnalysis As DocumentAnalysis 35 36'***ADDING-ISSUE: Use Following Skeleton as Guideline for Adding Issue 37' For complete list of all RID_STR_... for Issues (IssueType), SubIssues (SubType) and Attributes refer to: 38' powerpoint_res.bas and common_res.bas 39' 40' For complete list of all CID_... for Issue Categories(IssueID) and 41' CSTR_... for XML Issues (IssueTypeXML) and XML SubIssues (SubTypeXML) refer to: 42' ApplicationSpecific.bas and CommonMigrationAnalyser.bas 43' 44' You should not have to add any new Issue Categories or matching IssueTypes, only new SubIssues 45Sub Analyze_SKELETON() 46 On Error GoTo HandleErrors 47 Dim currentFunctionName As String 48 currentFunctionName = "Analyze_SKELETON" 49 Dim myIssue As IssueInfo 50 Set myIssue = New IssueInfo 51 52 With myIssue 53 .IssueID = CID_VBA_MACROS 'Issue Category 54 .IssueType = RID_STR_COMMON_ISSUE_VBA_MACROS 'Issue String 55 .SubType = RID_STR_COMMON_SUBISSUE_PROPERTIES 'SubIssue String 56 .Location = .CLocationDocument 'Location string 57 58 .IssueTypeXML = CSTR_ISSUE_VBA_MACROS 'Non localised XML Issue String 59 .SubTypeXML = CSTR_SUBISSUE_PROPERTIES 'Non localised XML SubIssue String 60 .locationXML = .CXMLLocationDocument 'Non localised XML location 61 62 .SubLocation = 0 'if not set will default to RID_STR_NOT_AVAILABLE_SHORTHAND 63 .Line = 0 'if not set will default to RID_STR_NOT_AVAILABLE_SHORTHAND 64 .column = 0 'if not set will default to RID_STR_NOT_AVAILABLE_SHORTHAND 65 66 ' Add as many Attribute Value pairs as needed 67 ' Note: following must always be true - Attributes.Count = Values.Count 68 .Attributes.Add "AAA" 69 .Values.Add "foobar" 70 71 ' Use AddIssueDetailsNote to add notes to the Issue Details if required 72 ' Public Sub AddIssueDetailsNote(myIssue As IssueInfo, noteNum As Long, noteStr As String, _ 73 ' Optional preStr As String = RID_STR_COMMON_NOTE_PRE) 74 ' Where preStr is prepended to the output, with "Note" as the default 75 AddIssueDetailsNote myIssue, 0, RID_STR_COMMON_NOTE_DOCUMENT_PROPERTIES_LOST 76 77 mAnalysis.IssuesCountArray(CID_VBA_MACROS) = _ 78 mAnalysis.IssuesCountArray(CID_VBA_MACROS) + 1 79 End With 80 81 mAnalysis.Issues.Add myIssue 82 83FinalExit: 84 Set myIssue = Nothing 85 Exit Sub 86 87HandleErrors: 88 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 89 Resume FinalExit 90End Sub 91 92Sub DoAnalyse(fileName As String, userFormTypesDict As Scripting.Dictionary, _ 93 startDir As String, storeToDir As String, fso As FileSystemObject) 94 On Error GoTo HandleErrors 95 Dim containsInvalidChar As Boolean 96 containsInvalidChar = False 97 Dim currentFunctionName As String 98 currentFunctionName = "DoAnalyse" 99 mAnalysis.name = fileName 100 Dim aPres As Presentation 101 mAnalysis.TotalIssueTypes = CTOTAL_CATEGORIES 102 103 If InStr(fileName, "[") = 0 And InStr(fileName, "]") = 0 Then 'If fileName does not contain [ AND ] 104 containsInvalidChar = False 105 Else 106 containsInvalidChar = True 107 End If 108 109 'Cannot Turn off any AutoExce macros before loading the Presentation 110 'WordBasic.DisableAutoMacros 1 111 'On Error GoTo HandleErrors 112 113 On Error Resume Next ' Ignore errors on setting 114 If containsInvalidChar = True Then 115 GoTo HandleErrors 116 End If 117 Set aPres = Presentations.Open(fileName:=fileName, ReadOnly:=True) 118 If Err.Number <> 0 Then 119 mAnalysis.Application = RID_STR_COMMON_CANNOT_OPEN 120 GoTo HandleErrors 121 End If 122 On Error GoTo HandleErrors 123 124 'MsgBox "Window: " & PPViewType(aPres.Windows(1).viewType) & _ 125 ' " Pane: " & PPViewType(aPres.Windows(1).ActivePane.viewType) 126 127 'Set Doc Properties 128 SetDocProperties mAnalysis, aPres, fso 129 130 Analyze_SlideIssues aPres 131 Analyze_Macros mAnalysis, userFormTypesDict, aPres 132 133 ' Doc Preparation only 134 ' Save document with any fixed issues under <storeToDir>\prepared\<source doc name> 135 If mAnalysis.PreparableIssuesCount > 0 And CheckDoPrepare Then 136 Dim preparedFullPath As String 137 preparedFullPath = GetPreparedFullPath(mAnalysis.name, startDir, storeToDir, fso) 138 If preparedFullPath <> "" Then 139 If fso.FileExists(preparedFullPath) Then 140 fso.DeleteFile preparedFullPath, True 141 End If 142 If fso.FolderExists(fso.GetParentFolderName(preparedFullPath)) Then 143 aPres.SaveAs preparedFullPath 144 End If 145 End If 146 End If 147 148FinalExit: 149 If Not aPres Is Nothing Then 'If Not IsEmpty(aDoc) Then 150 aPres.Saved = True 151 aPres.Close 152 End If 153 Set aPres = Nothing 154 Exit Sub 155 156HandleErrors: 157 If containsInvalidChar = False Then 158 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 159 Else 160 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": The file name contains the invalid character [ or ]. Please change the file name and run analysis again." 161 End If 162 Resume FinalExit 163End Sub 164 165Sub SetDocProperties(docAnalysis As DocumentAnalysis, pres As Presentation, fso As FileSystemObject) 166 On Error GoTo HandleErrors 167 Dim currentFunctionName As String 168 currentFunctionName = "SetDocProperties" 169 Dim f As File 170 Set f = fso.GetFile(docAnalysis.name) 171 172 Const appPropertyAppName = 9 173 Const appPropertyLastAuthor = 7 174 Const appPropertyRevision = 8 175 Const appPropertyTemplate = 6 176 Const appPropertyTimeCreated = 11 177 Const appPropertyTimeLastSaved = 12 178 179 On Error Resume Next 180 docAnalysis.PageCount = pres.Slides.count 181 docAnalysis.Created = f.DateCreated 182 docAnalysis.Modified = f.DateLastModified 183 docAnalysis.Accessed = f.DateLastAccessed 184 docAnalysis.Printed = DateValue("01/01/1900") 185 186 On Error Resume Next 'Some apps may not support all props 187 DocAnalysis.Application = getAppSpecificApplicationName & " " & Application.Version 188 189 'docAnalysis.Application = pres.BuiltInDocumentProperties(appPropertyAppName) 190 'If InStr(docAnalysis.Application, "Microsoft") = 1 Then 191 ' docAnalysis.Application = Mid(docAnalysis.Application, Len("Microsoft") + 2) 192 'End If 193 'If InStr(Len(docAnalysis.Application) - 2, docAnalysis.Application, ".") = 0 Then 194 ' docAnalysis.Application = docAnalysis.Application & " " & Application.Version 195 'End If 196 197 docAnalysis.SavedBy = _ 198 pres.BuiltInDocumentProperties(appPropertyLastAuthor) 199 docAnalysis.Revision = _ 200 val(pres.BuiltInDocumentProperties(appPropertyRevision)) 201 docAnalysis.Template = _ 202 fso.GetFileName(pres.BuiltInDocumentProperties(appPropertyTemplate)) 203 204FinalExit: 205 Set f = Nothing 206 Exit Sub 207 208HandleErrors: 209 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 210 Resume FinalExit 211End Sub 212 213Function PPViewType(viewType As PPViewType) As String 214 215 Select Case viewType 216 Case ppViewHandoutMaster 217 PPViewType = RID_STR_PP_ENUMERATION_VIEW_HANDOUT_MASTER 218 Case ppViewNormal 219 PPViewType = RID_STR_PP_ENUMERATION_VIEW_NORMAL 220 Case ppViewNotesMaster 221 PPViewType = RID_STR_PP_ENUMERATION_VIEW_NOTES_MASTER 222 Case ppViewNotesPage 223 PPViewType = RID_STR_PP_ENUMERATION_VIEW_NOTES_PAGE 224 Case ppViewOutline 225 PPViewType = RID_STR_PP_ENUMERATION_VIEW_OUTLINE 226 Case ppViewSlide 227 PPViewType = RID_STR_PP_ENUMERATION_VIEW_SLIDE 228 Case ppViewSlideMaster 229 PPViewType = RID_STR_PP_ENUMERATION_VIEW_SLIDE_MASTER 230 Case ppViewSlideSorter 231 PPViewType = RID_STR_PP_ENUMERATION_VIEW_SLIDE_SORTER 232 Case ppViewTitleMaster 233 PPViewType = RID_STR_PP_ENUMERATION_VIEW_TITLE_MASTER 234 Case Else 235 PPViewType = RID_STR_PP_ENUMERATION_UNKNOWN 236 End Select 237End Function 238 239Sub Analyze_SlideIssues(curPresentation As Presentation) 240 On Error GoTo HandleErrors 241 Dim currentFunctionName As String 242 currentFunctionName = "Analyze_SlideIssues" 243 244 Dim mySlide As Slide 245 Dim SlideNum As Integer 246 247 SlideNum = 1 248 For Each mySlide In curPresentation.Slides 249 ActiveWindow.View.GotoSlide index:=SlideNum 250 Analyze_ShapeIssues mySlide 251 Analyze_Hyperlinks mySlide 252 Analyze_Templates mySlide 253 SlideNum = SlideNum + 1 254 Next mySlide 255 256 Analyze_TabStops curPresentation 257 258 Exit Sub 259HandleErrors: 260 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 261End Sub 262 263Sub Analyze_TabStops(curPresentation As Presentation) 264 On Error GoTo HandleErrors 265 Dim currentFunctionName As String 266 currentFunctionName = "Analyze_TabStops" 267 268 'Dim firstSlide As Slide 269 'Dim firstShape As Shape 270 Dim mySlide As Slide 271 Dim myShape As Shape 272 Dim bInitialized, bHasDifferentDefaults As Boolean 273 Dim curDefault, lastDefault As Single 274 275 bInitialized = False 276 bHasDifferentDefaults = False 277 278 For Each mySlide In curPresentation.Slides 279 For Each myShape In mySlide.Shapes 280 If myShape.HasTextFrame Then 281 If myShape.TextFrame.HasText Then 282 curDefault = myShape.TextFrame.Ruler.TabStops.DefaultSpacing 283 If Not bInitialized Then 284 bInitialized = True 285 lastDefault = curDefault 286 'Set firstSlide = mySlide 287 'Set firstShape = myShape 288 End If 289 If curDefault <> lastDefault Then 290 bHasDifferentDefaults = True 291 Exit For 292 End If 293 End If 294 End If 295 Next myShape 296 If bHasDifferentDefaults Then Exit For 297 Next mySlide 298 299 If Not bHasDifferentDefaults Then Exit Sub 300 301 Dim myIssue As IssueInfo 302 Set myIssue = New IssueInfo 303 304 With myIssue 305 .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES 306 .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES 307 .SubType = RID_RESXLS_COST_Tabstop 308 .Location = .CLocationSlide 309 310 .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES 311 .SubTypeXML = CSTR_SUBISSUE_TABSTOP 312 .locationXML = .CXMLLocationSlide 313 314 .SubLocation = mySlide.name 315 .Line = myShape.top 316 .column = myShape.Left 317 318 .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME 319 .Values.Add myShape.name 320 321 AddIssueDetailsNote myIssue, 0, RID_STR_PP_SUBISSUE_TABSTOP_NOTE 322 323 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _ 324 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1 325 End With 326 327 mAnalysis.Issues.Add myIssue 328 329FinalExit: 330 Set myIssue = Nothing 331 Exit Sub 332 333HandleErrors: 334 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 335 Resume FinalExit 336End Sub 337 338Sub Analyze_Fonts(curPresentation As Presentation) 339 On Error GoTo HandleErrors 340 Dim currentFunctionName As String 341 currentFunctionName = "Analyze_Fonts" 342 343 Dim myFont As Font 344 Dim bHasEmbeddedFonts As Boolean 345 346 bHasEmbeddedFonts = False 347 For Each myFont In curPresentation.Fonts 348 If myFont.Embedded Then 349 bHasEmbeddedFonts = True 350 Exit For 351 End If 352 Next 353 354 If Not bHasEmbeddedFonts Then Exit Sub 355 356 Dim myIssue As IssueInfo 357 Set myIssue = New IssueInfo 358 359 With myIssue 360 .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES 361 .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES 362 .SubType = RID_STR_PP_SUBISSUE_FONTS 363 .Location = .CLocationSlide 364 365 .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES 366 .SubTypeXML = CSTR_SUBISSUE_FONTS 367 .locationXML = .CXMLLocationSlide 368 369 .SubLocation = mySlide.name 370 .Line = myShape.top 371 .column = myShape.Left 372 373 .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME 374 .Values.Add myShape.name 375 376 AddIssueDetailsNote myIssue, 0, RID_STR_PP_SUBISSUE_FONTS_NOTE 377 378 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _ 379 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1 380 End With 381 382 mAnalysis.Issues.Add myIssue 383 384FinalExit: 385 Set myIssue = Nothing 386 Exit Sub 387 388HandleErrors: 389 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 390 Resume FinalExit 391End Sub 392 393Sub Analyze_Templates(mySlide As Slide) 394 On Error GoTo HandleErrors 395 Dim currentFunctionName As String 396 currentFunctionName = "Analyze_Templates" 397 398 If mySlide.Layout <> ppLayoutTitle Then Exit Sub 399 400 Dim myIssue As IssueInfo 401 Set myIssue = New IssueInfo 402 403 With myIssue 404 .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES 405 .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES 406 .SubType = RID_RESXLS_COST_Template 407 .Location = .CLocationSlide 408 409 .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES 410 .SubTypeXML = CSTR_SUBISSUE_TEMPLATE 411 .locationXML = .CXMLLocationSlide 412 .SubLocation = mySlide.name 413 414 '.Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME 415 '.Values.Add mySlide.name 416 417 AddIssueDetailsNote myIssue, 0, RID_STR_PP_SUBISSUE_TEMPLATE_NOTE 418 419 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _ 420 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1 421 End With 422 423 mAnalysis.Issues.Add myIssue 424 425FinalExit: 426 Set myIssue = Nothing 427 Exit Sub 428 429HandleErrors: 430 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 431 Resume FinalExit 432End Sub 433 434Sub Analyze_Hyperlinks(mySlide As Slide) 435 On Error GoTo HandleErrors 436 Dim currentFunctionName As String 437 currentFunctionName = "Analyze_Hyperlinks" 438 439 Dim myIssue As IssueInfo 440 Dim hl As Hyperlink 441 Dim bHasMultipleFonts As Boolean 442 Dim bHasMultipleLines As Boolean 443 444 bHasMultipleFonts = False 445 bHasMultipleLines = False 446 447 For Each hl In mySlide.Hyperlinks 448 If TypeName(hl.Parent.Parent) = "TextRange" Then 449 Dim myTextRange As TextRange 450 Dim currRun As TextRange 451 Dim currLine As TextRange 452 Dim first, last, noteCount As Long 453 454 Set myTextRange = hl.Parent.Parent 455 first = myTextRange.start 456 last = first + myTextRange.Length - 1 457 458 For Each currRun In myTextRange.Runs 459 If (currRun.start > first And currRun.start < last) Then 460 bHasMultipleFonts = True 461 Exit For 462 End If 463 Next 464 465 For Each currLine In myTextRange.Lines 466 Dim lineEnd As Long 467 lineEnd = currLine.start + currLine.Length - 1 468 If (first <= lineEnd And last > lineEnd) Then 469 bHasMultipleLines = True 470 Exit For 471 End If 472 Next 473 End If 474 475 noteCount = 0 476 477 If bHasMultipleFonts Then 478 Set myIssue = New IssueInfo 479 480 With myIssue 481 .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES 482 .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES 483 .SubType = RID_RESXLS_COST_Hyperlink 484 .Location = .CLocationSlide 485 486 .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES 487 .SubTypeXML = CSTR_SUBISSUE_HYPERLINK 488 .locationXML = .CXMLLocationSlide 489 .SubLocation = mySlide.name 490 491 .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME 492 .Values.Add myTextRange.Text 493 494 AddIssueDetailsNote myIssue, 0, RID_STR_PP_SUBISSUE_HYPERLINK_NOTE 495 496 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _ 497 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1 498 End With 499 mAnalysis.Issues.Add myIssue 500 Set myIssue = Nothing 501 bHasMultipleFonts = False 502 End If 503 If bHasMultipleLines Then 504 Set myIssue = New IssueInfo 505 506 With myIssue 507 .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES 508 .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES 509 .SubType = RID_RESXLS_COST_HyperlinkSplit 510 .Location = .CLocationSlide 511 512 .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES 513 .SubTypeXML = CSTR_SUBISSUE_HYPERLINK_SPLIT 514 .locationXML = .CXMLLocationSlide 515 .SubLocation = mySlide.name 516 517 .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME 518 .Values.Add myTextRange.Text 519 520 AddIssueDetailsNote myIssue, 0, RID_STR_PP_SUBISSUE_HYPERLINK_SPLIT_NOTE 521 522 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _ 523 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1 524 End With 525 mAnalysis.Issues.Add myIssue 526 Set myIssue = Nothing 527 bHasMultipleLines = False 528 End If 529 Next 530 531FinalExit: 532 Set myIssue = Nothing 533 Exit Sub 534 535HandleErrors: 536 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 537 Resume FinalExit 538End Sub 539 540Sub Analyze_ShapeIssues(mySlide As Slide) 541 On Error GoTo HandleErrors 542 Dim currentFunctionName As String 543 currentFunctionName = "Analyze_ShapeIssues" 544 Dim myShape As Shape 545 546 For Each myShape In mySlide.Shapes 547 'myShape.Select msoTrue 548 Analyze_Movie mySlide, myShape 549 Analyze_Comments mySlide, myShape 550 Analyze_Background mySlide, myShape 551 Analyze_Numbering mySlide, myShape 552 'Analyze global issues 553 Analyze_OLEEmbeddedSingleShape mAnalysis, myShape, mySlide.name 554 Analyze_Lines mAnalysis, myShape, mySlide.name 555 Analyze_Transparency mAnalysis, myShape, mySlide.name 556 Analyze_Gradients mAnalysis, myShape, mySlide.name 557 Next myShape 558 559 Exit Sub 560HandleErrors: 561 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 562End Sub 563 564Sub Analyze_Numbering(mySlide As Slide, myShape As Shape) 565 On Error GoTo HandleErrors 566 Dim currentFunctionName As String 567 currentFunctionName = "Analyze_Numbering" 568 569 If Not myShape.HasTextFrame Then Exit Sub 570 If Not myShape.TextFrame.HasText Then Exit Sub 571 Dim shapeText As TextRange 572 573 Set shapeText = myShape.TextFrame.TextRange 574 575 If shapeText.Paragraphs.count < 2 Then Exit Sub 576 If Not (shapeText.ParagraphFormat.Bullet.Type = ppBulletMixed Or _ 577 shapeText.ParagraphFormat.Bullet.Type = ppBulletNumbered) Then Exit Sub 578 579 ' OpenOffice has Problems when the numbering does not start with the first 580 ' paragraph or when there are empty paragraphs which do not have a number. 581 ' Because PowerPoint does not give us the length of each paragraph ( .Length 582 ' does not work ), we have to compute the length ourself. 583 584 Dim I As Long 585 Dim lastType As PpBulletType 586 Dim currType As PpBulletType 587 Dim lastStart As Long 588 Dim lastLength As Long 589 Dim currStart As Long 590 Dim bHasNumProblem As Boolean 591 Dim bHasEmptyPar As Boolean 592 593 bHasNumProblem = False 594 bHasEmptyPar = False 595 596 lastType = shapeText.Paragraphs(1, 0).ParagraphFormat.Bullet.Type 597 lastStart = shapeText.Paragraphs(1, 0).start 598 599 For I = 2 To shapeText.Paragraphs.count 600 currType = shapeText.Paragraphs(I, 0).ParagraphFormat.Bullet.Type 601 currStart = shapeText.Paragraphs(I, 0).start 602 lastLength = currStart - lastStart - 1 603 604 If currType <> lastType Then 605 lastType = currType 606 If currType = ppBulletNumbered Then 607 bHasNumProblem = True 608 Exit For 609 End If 610 End If 611 If lastLength = 0 Then 612 bHasEmptyPar = True 613 Else 614 If (bHasEmptyPar) Then 615 bHasNumProblem = True 616 Exit For 617 End If 618 End If 619 lastStart = currStart 620 Next I 621 622 lastLength = shapeText.Length - lastStart 623 If (lastLength <> 0) And bHasEmptyPar Then 624 bHasNumProblem = True 625 End If 626 627 If Not bHasNumProblem Then Exit Sub 628 629 Dim myIssue As IssueInfo 630 Set myIssue = New IssueInfo 631 632 With myIssue 633 .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES 634 .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES 635 .SubType = RID_RESXLS_COST_Numbering 636 .Location = .CLocationSlide 637 638 .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES 639 .SubTypeXML = CSTR_SUBISSUE_NUMBERING 640 .locationXML = .CXMLLocationSlide 641 642 .SubLocation = mySlide.name 643 .Line = myShape.top 644 .column = myShape.Left 645 646 .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME 647 .Values.Add myShape.name 648 649 AddIssueDetailsNote myIssue, 0, RID_STR_PP_SUBISSUE_NUMBERING_NOTE 650 651 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _ 652 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1 653 End With 654 655 mAnalysis.Issues.Add myIssue 656 657FinalExit: 658 Set myIssue = Nothing 659 Exit Sub 660 661HandleErrors: 662 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 663 Resume FinalExit 664End Sub 665 666Sub Analyze_Background(mySlide As Slide, myShape As Shape) 667 On Error GoTo HandleErrors 668 Dim currentFunctionName As String 669 currentFunctionName = "Analyze_Background" 670 671 If myShape.Fill.Type <> msoFillBackground Then Exit Sub 672 673 Dim myIssue As IssueInfo 674 Set myIssue = New IssueInfo 675 Dim strCr As String 676 strCr = "" & vbCr 677 678 With myIssue 679 .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES 680 .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES 681 .SubType = RID_RESXLS_COST_Background 682 .Location = .CLocationSlide 683 684 .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES 685 .SubTypeXML = CSTR_SUBISSUE_BACKGROUND 686 .locationXML = .CXMLLocationSlide 687 688 .SubLocation = mySlide.name 689 .Line = myShape.top 690 .column = myShape.Left 691 692 .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME 693 .Values.Add myShape.name 694 695 AddIssueDetailsNote myIssue, 0, RID_STR_PP_SUBISSUE_BACKGROUND_NOTE 696 697 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _ 698 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1 699 End With 700 701 mAnalysis.Issues.Add myIssue 702 703FinalExit: 704 Set myIssue = Nothing 705 Exit Sub 706 707HandleErrors: 708 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 709 Resume FinalExit 710End Sub 711 712Sub Analyze_Comments(mySlide As Slide, myShape As Shape) 713 On Error GoTo HandleErrors 714 Dim currentFunctionName As String 715 currentFunctionName = "Analyze_Comments" 716 717 If myShape.Type <> msoComment Then Exit Sub 718 719 Dim myIssue As IssueInfo 720 Set myIssue = New IssueInfo 721 Dim strCr As String 722 strCr = "" & vbCr 723 724 With myIssue 725 .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES 726 .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES 727 .SubType = RID_STR_PP_SUBISSUE_COMMENT 728 .Location = .CLocationSlide 729 730 .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES 731 .SubTypeXML = CSTR_SUBISSUE_COMMENT 732 .locationXML = .CXMLLocationSlide 733 734 .SubLocation = mySlide.name 735 .Line = myShape.top 736 .column = myShape.Left 737 738 .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME 739 .Values.Add myShape.name 740 .Attributes.Add RID_STR_PP_ATTRIBUTE_CONTENT 741 .Values.Add Replace(myShape.TextFrame.TextRange.Text, strCr, "") 742 743 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _ 744 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1 745 End With 746 747 mAnalysis.Issues.Add myIssue 748 749FinalExit: 750 Set myIssue = Nothing 751 Exit Sub 752 753HandleErrors: 754 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 755 Resume FinalExit 756End Sub 757Sub Analyze_Movie(mySlide As Slide, myShape As Shape) 758 On Error GoTo HandleErrors 759 Dim currentFunctionName As String 760 currentFunctionName = "Analyze_Movie" 761 762 If myShape.Type <> msoMedia Then Exit Sub 763 If myShape.MediaType <> ppMediaTypeMovie Then Exit Sub 764 765 Dim myIssue As IssueInfo 766 Set myIssue = New IssueInfo 767 768 With myIssue 769 .IssueID = CID_OBJECTS_GRAPHICS_TEXTBOXES 770 .IssueType = RID_STR_PP_ISSUE_OBJECTS_GRAPHICS_AND_TEXTBOXES 771 .SubType = RID_STR_PP_SUBISSUE_MOVIE 772 .Location = .CLocationSlide 773 774 .IssueTypeXML = CSTR_ISSUE_OBJECTS_GRAPHICS_AND_TEXTBOXES 775 .SubTypeXML = CSTR_SUBISSUE_MOVIE 776 .locationXML = .CXMLLocationSlide 777 778 .SubLocation = mySlide.name 779 .Line = myShape.top 780 .column = myShape.Left 781 782 .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME 783 .Values.Add myShape.name 784 .Attributes.Add RID_STR_COMMON_ATTRIBUTE_SOURCE 785 .Values.Add myShape.LinkFormat.SourceFullName 786 .Attributes.Add RID_STR_PP_ATTRIBUTE_PLAYONENTRY 787 .Values.Add IIf(myShape.AnimationSettings.PlaySettings.PlayOnEntry, RID_STR_PP_TRUE, RID_STR_PP_FALSE) 788 .Attributes.Add RID_STR_PP_ATTRIBUTE_LOOP 789 .Values.Add IIf(myShape.AnimationSettings.PlaySettings.LoopUntilStopped, RID_STR_PP_TRUE, RID_STR_PP_FALSE) 790 .Attributes.Add RID_STR_PP_ATTRIBUTE_REWIND 791 .Values.Add IIf(myShape.AnimationSettings.PlaySettings.RewindMovie, RID_STR_PP_TRUE, RID_STR_PP_FALSE) 792 793 mAnalysis.IssuesCountArray(CID_OBJECTS_GRAPHICS_TEXTBOXES) = _ 794 mAnalysis.IssuesCountArray(CID_OBJECTS_GRAPHICS_TEXTBOXES) + 1 795 End With 796 797 mAnalysis.Issues.Add myIssue 798 799FinalExit: 800 Set myIssue = Nothing 801 Exit Sub 802 803HandleErrors: 804 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 805 Resume FinalExit 806End Sub 807 808Private Sub Class_Initialize() 809 Set mAnalysis = New DocumentAnalysis 810End Sub 811Private Sub Class_Terminate() 812 Set mAnalysis = Nothing 813End Sub 814 815Public Property Get Results() As DocumentAnalysis 816 Set Results = mAnalysis 817End Property 818 819