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