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