xref: /trunk/main/migrationanalysis/src/driver_docs/sources/powerpoint/MigrationAnalyser.cls (revision d4a3fa4b)

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "MigrationAnalyser"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'*************************************************************************
'
'  Licensed to the Apache Software Foundation (ASF) under one
'  or more contributor license agreements.  See the NOTICE file
'  distributed with this work for additional information
'  regarding copyright ownership.  The ASF licenses this file
'  to you under the Apache License, Version 2.0 (the
'  "License"); you may not use this file except in compliance
'  with the License.  You may obtain a copy of the License at
'
'    http://www.apache.org/licenses/LICENSE-2.0
'
'  Unless required by applicable law or agreed to in writing,
'  software distributed under the License is distributed on an
'  "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
'  KIND, either express or implied.  See the License for the
'  specific language governing permissions and limitations
'  under the License.
'
'*************************************************************************

Option Explicit


Private mAnalysis As DocumentAnalysis

'***ADDING-ISSUE: Use Following Skeleton as Guideline for Adding Issue
' For complete list of all RID_STR_... for Issues (IssueType), SubIssues (SubType) and Attributes refer to:
'   powerpoint_res.bas and common_res.bas
'
' For complete list of all CID_... for Issue Categories(IssueID) and
' CSTR_... for XML Issues (IssueTypeXML) and XML SubIssues (SubTypeXML) refer to:
'   ApplicationSpecific.bas and CommonMigrationAnalyser.bas
'
' You should not have to add any new Issue Categories or matching IssueTypes, only new SubIssues
Sub Analyze_SKELETON()
    On Error GoTo HandleErrors
    Dim currentFunctionName As String
    currentFunctionName = "Analyze_SKELETON"
    Dim myIssue As IssueInfo
    Set myIssue = New IssueInfo

    With myIssue
        .IssueID = CID_VBA_MACROS 'Issue Category
        .IssueType = RID_STR_COMMON_ISSUE_VBA_MACROS 'Issue String
        .SubType = RID_STR_COMMON_SUBISSUE_PROPERTIES 'SubIssue String
        .Location = .CLocationDocument 'Location string

        .IssueTypeXML = CSTR_ISSUE_VBA_MACROS 'Non localised XML Issue String
        .SubTypeXML = CSTR_SUBISSUE_PROPERTIES 'Non localised XML SubIssue String
        .locationXML = .CXMLLocationDocument 'Non localised XML location

        .SubLocation = 0 'if not set will default to RID_STR_NOT_AVAILABLE_SHORTHAND
        .Line = 0 'if not set will default to RID_STR_NOT_AVAILABLE_SHORTHAND
        .column = 0 'if not set will default to RID_STR_NOT_AVAILABLE_SHORTHAND

        ' Add as many Attribute Value pairs as needed
        ' Note: following must always be true - Attributes.Count = Values.Count
        .Attributes.Add "AAA"
        .Values.Add "foobar"

        ' Use AddIssueDetailsNote to add notes to the Issue Details if required
        ' Public Sub AddIssueDetailsNote(myIssue As IssueInfo, noteNum As Long, noteStr As String, _
        '   Optional preStr As String = RID_STR_COMMON_NOTE_PRE)
        ' Where preStr is prepended to the output, with "Note" as the default
         AddIssueDetailsNote myIssue, 0, RID_STR_COMMON_NOTE_DOCUMENT_PROPERTIES_LOST

         mAnalysis.IssuesCountArray(CID_VBA_MACROS) = _
                mAnalysis.IssuesCountArray(CID_VBA_MACROS) + 1
    End With

    mAnalysis.Issues.Add myIssue

FinalExit:
    Set myIssue = Nothing
    Exit Sub

HandleErrors:
    WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
    Resume FinalExit
End Sub

Sub DoAnalyse(fileName As String, userFormTypesDict As Scripting.Dictionary, _
    startDir As String, storeToDir As String, fso As FileSystemObject)
    On Error GoTo HandleErrors
    Dim containsInvalidChar As Boolean
    containsInvalidChar = False
    Dim currentFunctionName As String
    currentFunctionName = "DoAnalyse"
    mAnalysis.name = fileName
    Dim aPres As Presentation
    mAnalysis.TotalIssueTypes = CTOTAL_CATEGORIES

    If InStr(fileName, "[") = 0 And InStr(fileName, "]") = 0 Then 'If fileName does not contain [ AND ]
        containsInvalidChar = False
    Else
        containsInvalidChar = True
    End If

    'Cannot Turn off any AutoExce macros before loading the Presentation
    'WordBasic.DisableAutoMacros 1
    'On Error GoTo HandleErrors

    On Error Resume Next ' Ignore errors on setting
    If containsInvalidChar = True Then
        GoTo HandleErrors
    End If
    Set aPres = Presentations.Open(fileName:=fileName, ReadOnly:=True)
    If Err.Number <> 0 Then
        mAnalysis.Application = RID_STR_COMMON_CANNOT_OPEN
        GoTo HandleErrors
    End If
    On Error GoTo HandleErrors

    'MsgBox "Window: " & PPViewType(aPres.Windows(1).viewType) & _
    '    " Pane: " & PPViewType(aPres.Windows(1).ActivePane.viewType)

    'Set Doc Properties
    SetDocProperties mAnalysis, aPres, fso

    Analyze_SlideIssues aPres
    Analyze_Macros mAnalysis, userFormTypesDict, aPres

    ' Doc Preparation only
    ' Save document with any fixed issues under <storeToDir>\prepared\<source doc name>
    If mAnalysis.PreparableIssuesCount > 0 And CheckDoPrepare Then
        Dim preparedFullPath As String
        preparedFullPath = GetPreparedFullPath(mAnalysis.name, startDir, storeToDir, fso)
        If preparedFullPath <> "" Then
            If fso.FileExists(preparedFullPath) Then
                fso.DeleteFile preparedFullPath, True
            End If
            If fso.FolderExists(fso.GetParentFolderName(preparedFullPath)) Then
                aPres.SaveAs preparedFullPath
            End If
        End If
    End If

FinalExit:
    If Not aPres Is Nothing Then 'If Not IsEmpty(aDoc) Then
        aPres.Saved = True
        aPres.Close
    End If
    Set aPres = Nothing
    Exit Sub

HandleErrors:
    If containsInvalidChar = False Then
        WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
    Else
        WriteDebug currentFunctionName & " : " & mAnalysis.name & ": The file name contains the invalid character [ or ].  Please change the file name and run analysis again."
    End If
    Resume FinalExit
End Sub

Sub SetDocProperties(docAnalysis As DocumentAnalysis, pres As Presentation, fso As FileSystemObject)
    On Error GoTo HandleErrors
    Dim currentFunctionName As String
    currentFunctionName = "SetDocProperties"
    Dim f As File
    Set f = fso.GetFile(docAnalysis.name)

    Const appPropertyAppName = 9
    Const appPropertyLastAuthor = 7
    Const appPropertyRevision = 8
    Const appPropertyTemplate = 6
    Const appPropertyTimeCreated = 11
    Const appPropertyTimeLastSaved = 12

    On Error Resume Next
    docAnalysis.PageCount = pres.Slides.count
    docAnalysis.Created = f.DateCreated
    docAnalysis.Modified = f.DateLastModified
    docAnalysis.Accessed = f.DateLastAccessed
    docAnalysis.Printed = DateValue("01/01/1900")

    On Error Resume Next 'Some apps may not support all props
    DocAnalysis.Application = getAppSpecificApplicationName & " " & Application.Version

    'docAnalysis.Application = pres.BuiltInDocumentProperties(appPropertyAppName)
    'If InStr(docAnalysis.Application, "Microsoft") = 1 Then
    '    docAnalysis.Application = Mid(docAnalysis.Application, Len("Microsoft") + 2)
    'End If
    'If InStr(Len(docAnalysis.Application) - 2, docAnalysis.Application, ".") = 0 Then
    '    docAnalysis.Application = docAnalysis.Application & " " & Application.Version
    'End If

    docAnalysis.SavedBy = _
        pres.BuiltInDocumentProperties(appPropertyLastAuthor)
    docAnalysis.Revision = _
        val(pres.BuiltInDocumentProperties(appPropertyRevision))
    docAnalysis.Template = _
        fso.GetFileName(pres.BuiltInDocumentProperties(appPropertyTemplate))

FinalExit:
    Set f = Nothing
    Exit Sub

HandleErrors:
    WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
    Resume FinalExit
End Sub

Function PPViewType(viewType As PPViewType) As String

    Select Case viewType
        Case ppViewHandoutMaster
            PPViewType = RID_STR_PP_ENUMERATION_VIEW_HANDOUT_MASTER
        Case ppViewNormal
            PPViewType = RID_STR_PP_ENUMERATION_VIEW_NORMAL
        Case ppViewNotesMaster
            PPViewType = RID_STR_PP_ENUMERATION_VIEW_NOTES_MASTER
        Case ppViewNotesPage
            PPViewType = RID_STR_PP_ENUMERATION_VIEW_NOTES_PAGE
        Case ppViewOutline
            PPViewType = RID_STR_PP_ENUMERATION_VIEW_OUTLINE
        Case ppViewSlide
            PPViewType = RID_STR_PP_ENUMERATION_VIEW_SLIDE
        Case ppViewSlideMaster
            PPViewType = RID_STR_PP_ENUMERATION_VIEW_SLIDE_MASTER
        Case ppViewSlideSorter
            PPViewType = RID_STR_PP_ENUMERATION_VIEW_SLIDE_SORTER
        Case ppViewTitleMaster
            PPViewType = RID_STR_PP_ENUMERATION_VIEW_TITLE_MASTER
        Case Else
            PPViewType = RID_STR_PP_ENUMERATION_UNKNOWN
    End Select
End Function

Sub Analyze_SlideIssues(curPresentation As Presentation)
    On Error GoTo HandleErrors
    Dim currentFunctionName As String
    currentFunctionName = "Analyze_SlideIssues"

    Dim mySlide As Slide
    Dim SlideNum As Integer

    SlideNum = 1
    For Each mySlide In curPresentation.Slides
        ActiveWindow.View.GotoSlide index:=SlideNum
        Analyze_ShapeIssues mySlide
        Analyze_Hyperlinks mySlide
        Analyze_Templates mySlide
        SlideNum = SlideNum + 1
    Next mySlide

    Analyze_TabStops curPresentation

    Exit Sub
HandleErrors:
    WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
End Sub

Sub Analyze_TabStops(curPresentation As Presentation)
    On Error GoTo HandleErrors
    Dim currentFunctionName As String
    currentFunctionName = "Analyze_TabStops"

    'Dim firstSlide As Slide
    'Dim firstShape As Shape
    Dim mySlide As Slide
    Dim myShape As Shape
    Dim bInitialized, bHasDifferentDefaults As Boolean
    Dim curDefault, lastDefault As Single

    bInitialized = False
    bHasDifferentDefaults = False

    For Each mySlide In curPresentation.Slides
        For Each myShape In mySlide.Shapes
            If myShape.HasTextFrame Then
                If myShape.TextFrame.HasText Then
                    curDefault = myShape.TextFrame.Ruler.TabStops.DefaultSpacing
                    If Not bInitialized Then
                        bInitialized = True
                        lastDefault = curDefault
                        'Set firstSlide = mySlide
                        'Set firstShape = myShape
                    End If
                    If curDefault <> lastDefault Then
                        bHasDifferentDefaults = True
                        Exit For
                    End If
                End If
            End If
        Next myShape
        If bHasDifferentDefaults Then Exit For
    Next mySlide

    If Not bHasDifferentDefaults Then Exit Sub

    Dim myIssue As IssueInfo
    Set myIssue = New IssueInfo

    With myIssue
        .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES
        .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES
        .SubType = RID_RESXLS_COST_Tabstop
        .Location = .CLocationSlide

        .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES
        .SubTypeXML = CSTR_SUBISSUE_TABSTOP
        .locationXML = .CXMLLocationSlide

        .SubLocation = mySlide.name
        .Line = myShape.top
        .column = myShape.Left

        .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME
        .Values.Add myShape.name

        AddIssueDetailsNote myIssue, 0, RID_STR_PP_SUBISSUE_TABSTOP_NOTE

        mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _
                mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1
    End With

    mAnalysis.Issues.Add myIssue

FinalExit:
    Set myIssue = Nothing
    Exit Sub

HandleErrors:
    WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
    Resume FinalExit
End Sub

Sub Analyze_Fonts(curPresentation As Presentation)
    On Error GoTo HandleErrors
    Dim currentFunctionName As String
    currentFunctionName = "Analyze_Fonts"

    Dim myFont As Font
    Dim bHasEmbeddedFonts As Boolean

    bHasEmbeddedFonts = False
    For Each myFont In curPresentation.Fonts
        If myFont.Embedded Then
            bHasEmbeddedFonts = True
            Exit For
        End If
    Next

    If Not bHasEmbeddedFonts Then Exit Sub

    Dim myIssue As IssueInfo
    Set myIssue = New IssueInfo

    With myIssue
        .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES
        .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES
        .SubType = RID_STR_PP_SUBISSUE_FONTS
        .Location = .CLocationSlide

        .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES
        .SubTypeXML = CSTR_SUBISSUE_FONTS
        .locationXML = .CXMLLocationSlide

        .SubLocation = mySlide.name
        .Line = myShape.top
        .column = myShape.Left

        .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME
        .Values.Add myShape.name

        AddIssueDetailsNote myIssue, 0, RID_STR_PP_SUBISSUE_FONTS_NOTE

        mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _
                mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1
    End With

    mAnalysis.Issues.Add myIssue

FinalExit:
    Set myIssue = Nothing
    Exit Sub

HandleErrors:
    WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
    Resume FinalExit
End Sub

Sub Analyze_Templates(mySlide As Slide)
    On Error GoTo HandleErrors
    Dim currentFunctionName As String
    currentFunctionName = "Analyze_Templates"

    If mySlide.Layout <> ppLayoutTitle Then Exit Sub

    Dim myIssue As IssueInfo
    Set myIssue = New IssueInfo

    With myIssue
        .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES
        .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES
        .SubType = RID_RESXLS_COST_Template
        .Location = .CLocationSlide

        .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES
        .SubTypeXML = CSTR_SUBISSUE_TEMPLATE
        .locationXML = .CXMLLocationSlide
        .SubLocation = mySlide.name

        '.Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME
        '.Values.Add mySlide.name

        AddIssueDetailsNote myIssue, 0, RID_STR_PP_SUBISSUE_TEMPLATE_NOTE

        mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _
                mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1
    End With

    mAnalysis.Issues.Add myIssue

FinalExit:
    Set myIssue = Nothing
    Exit Sub

HandleErrors:
    WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
    Resume FinalExit
End Sub

Sub Analyze_Hyperlinks(mySlide As Slide)
    On Error GoTo HandleErrors
    Dim currentFunctionName As String
    currentFunctionName = "Analyze_Hyperlinks"

    Dim myIssue As IssueInfo
    Dim hl As Hyperlink
    Dim bHasMultipleFonts As Boolean
    Dim bHasMultipleLines As Boolean

    bHasMultipleFonts = False
    bHasMultipleLines = False

    For Each hl In mySlide.Hyperlinks
        If TypeName(hl.Parent.Parent) = "TextRange" Then
            Dim myTextRange As TextRange
            Dim currRun As TextRange
            Dim currLine As TextRange
            Dim first, last, noteCount As Long

            Set myTextRange = hl.Parent.Parent
            first = myTextRange.start
            last = first + myTextRange.Length - 1

            For Each currRun In myTextRange.Runs
                If (currRun.start > first And currRun.start < last) Then
                    bHasMultipleFonts = True
                    Exit For
                End If
            Next

            For Each currLine In myTextRange.Lines
                Dim lineEnd As Long
                lineEnd = currLine.start + currLine.Length - 1
                If (first <= lineEnd And last > lineEnd) Then
                    bHasMultipleLines = True
                    Exit For
                End If
            Next
        End If

        noteCount = 0

        If bHasMultipleFonts Then
            Set myIssue = New IssueInfo

            With myIssue
                .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES
                .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES
                .SubType = RID_RESXLS_COST_Hyperlink
                .Location = .CLocationSlide

                .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES
                .SubTypeXML = CSTR_SUBISSUE_HYPERLINK
                .locationXML = .CXMLLocationSlide
                .SubLocation = mySlide.name

                .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME
                .Values.Add myTextRange.Text

                AddIssueDetailsNote myIssue, 0, RID_STR_PP_SUBISSUE_HYPERLINK_NOTE

                mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _
                        mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1
            End With
            mAnalysis.Issues.Add myIssue
            Set myIssue = Nothing
            bHasMultipleFonts = False
        End If
        If bHasMultipleLines Then
            Set myIssue = New IssueInfo

            With myIssue
                .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES
                .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES
                .SubType = RID_RESXLS_COST_HyperlinkSplit
                .Location = .CLocationSlide

                .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES
                .SubTypeXML = CSTR_SUBISSUE_HYPERLINK_SPLIT
                .locationXML = .CXMLLocationSlide
                .SubLocation = mySlide.name

                .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME
                .Values.Add myTextRange.Text

                AddIssueDetailsNote myIssue, 0, RID_STR_PP_SUBISSUE_HYPERLINK_SPLIT_NOTE

                mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _
                        mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1
            End With
            mAnalysis.Issues.Add myIssue
            Set myIssue = Nothing
            bHasMultipleLines = False
        End If
    Next

FinalExit:
    Set myIssue = Nothing
    Exit Sub

HandleErrors:
    WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
    Resume FinalExit
End Sub

Sub Analyze_ShapeIssues(mySlide As Slide)
    On Error GoTo HandleErrors
    Dim currentFunctionName As String
    currentFunctionName = "Analyze_ShapeIssues"
    Dim myShape As Shape

    For Each myShape In mySlide.Shapes
        'myShape.Select msoTrue
        Analyze_Movie mySlide, myShape
        Analyze_Comments mySlide, myShape
        Analyze_Background mySlide, myShape
        Analyze_Numbering mySlide, myShape
        'Analyze global issues
        Analyze_OLEEmbeddedSingleShape mAnalysis, myShape, mySlide.name
        Analyze_Lines mAnalysis, myShape, mySlide.name
        Analyze_Transparency mAnalysis, myShape, mySlide.name
        Analyze_Gradients mAnalysis, myShape, mySlide.name
    Next myShape

    Exit Sub
HandleErrors:
    WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
End Sub

Sub Analyze_Numbering(mySlide As Slide, myShape As Shape)
    On Error GoTo HandleErrors
    Dim currentFunctionName As String
    currentFunctionName = "Analyze_Numbering"

    If Not myShape.HasTextFrame Then Exit Sub
    If Not myShape.TextFrame.HasText Then Exit Sub
    Dim shapeText As TextRange

    Set shapeText = myShape.TextFrame.TextRange

    If shapeText.Paragraphs.count < 2 Then Exit Sub
    If Not (shapeText.ParagraphFormat.Bullet.Type = ppBulletMixed Or _
            shapeText.ParagraphFormat.Bullet.Type = ppBulletNumbered) Then Exit Sub

    ' OpenOffice has Problems when the numbering does not start with the first
    ' paragraph or when there are empty paragraphs which do not have a number.
    ' Because PowerPoint does not give us the length of each paragraph ( .Length
    ' does not work ), we have to compute the length ourself.

    Dim I As Long
    Dim lastType As PpBulletType
    Dim currType As PpBulletType
    Dim lastStart As Long
    Dim lastLength As Long
    Dim currStart As Long
    Dim bHasNumProblem As Boolean
    Dim bHasEmptyPar As Boolean

    bHasNumProblem = False
    bHasEmptyPar = False

    lastType = shapeText.Paragraphs(1, 0).ParagraphFormat.Bullet.Type
    lastStart = shapeText.Paragraphs(1, 0).start

    For I = 2 To shapeText.Paragraphs.count
        currType = shapeText.Paragraphs(I, 0).ParagraphFormat.Bullet.Type
        currStart = shapeText.Paragraphs(I, 0).start
        lastLength = currStart - lastStart - 1

        If currType <> lastType Then
            lastType = currType
            If currType = ppBulletNumbered Then
                bHasNumProblem = True
                Exit For
            End If
        End If
        If lastLength = 0 Then
            bHasEmptyPar = True
        Else
            If (bHasEmptyPar) Then
                bHasNumProblem = True
                Exit For
            End If
        End If
        lastStart = currStart
    Next I

    lastLength = shapeText.Length - lastStart
    If (lastLength <> 0) And bHasEmptyPar Then
        bHasNumProblem = True
    End If

    If Not bHasNumProblem Then Exit Sub

    Dim myIssue As IssueInfo
    Set myIssue = New IssueInfo

    With myIssue
        .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES
        .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES
        .SubType = RID_RESXLS_COST_Numbering
        .Location = .CLocationSlide

        .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES
        .SubTypeXML = CSTR_SUBISSUE_NUMBERING
        .locationXML = .CXMLLocationSlide

        .SubLocation = mySlide.name
        .Line = myShape.top
        .column = myShape.Left

        .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME
        .Values.Add myShape.name

        AddIssueDetailsNote myIssue, 0, RID_STR_PP_SUBISSUE_NUMBERING_NOTE

        mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _
                mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1
    End With

    mAnalysis.Issues.Add myIssue

FinalExit:
    Set myIssue = Nothing
    Exit Sub

HandleErrors:
    WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
    Resume FinalExit
End Sub

Sub Analyze_Background(mySlide As Slide, myShape As Shape)
    On Error GoTo HandleErrors
    Dim currentFunctionName As String
    currentFunctionName = "Analyze_Background"

    If myShape.Fill.Type <> msoFillBackground Then Exit Sub

    Dim myIssue As IssueInfo
    Set myIssue = New IssueInfo
    Dim strCr As String
    strCr = "" & vbCr

    With myIssue
        .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES
        .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES
        .SubType = RID_RESXLS_COST_Background
        .Location = .CLocationSlide

        .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES
        .SubTypeXML = CSTR_SUBISSUE_BACKGROUND
        .locationXML = .CXMLLocationSlide

        .SubLocation = mySlide.name
        .Line = myShape.top
        .column = myShape.Left

        .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME
        .Values.Add myShape.name

        AddIssueDetailsNote myIssue, 0, RID_STR_PP_SUBISSUE_BACKGROUND_NOTE

        mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _
                mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1
    End With

    mAnalysis.Issues.Add myIssue

FinalExit:
    Set myIssue = Nothing
    Exit Sub

HandleErrors:
    WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
    Resume FinalExit
End Sub

Sub Analyze_Comments(mySlide As Slide, myShape As Shape)
    On Error GoTo HandleErrors
    Dim currentFunctionName As String
    currentFunctionName = "Analyze_Comments"

    If myShape.Type <> msoComment Then Exit Sub

    Dim myIssue As IssueInfo
    Set myIssue = New IssueInfo
    Dim strCr As String
    strCr = "" & vbCr

    With myIssue
        .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES
        .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES
        .SubType = RID_STR_PP_SUBISSUE_COMMENT
        .Location = .CLocationSlide

        .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES
        .SubTypeXML = CSTR_SUBISSUE_COMMENT
        .locationXML = .CXMLLocationSlide

        .SubLocation = mySlide.name
        .Line = myShape.top
        .column = myShape.Left

        .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME
        .Values.Add myShape.name
        .Attributes.Add RID_STR_PP_ATTRIBUTE_CONTENT
        .Values.Add Replace(myShape.TextFrame.TextRange.Text, strCr, "")

         mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _
                mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1
    End With

    mAnalysis.Issues.Add myIssue

FinalExit:
    Set myIssue = Nothing
    Exit Sub

HandleErrors:
    WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
    Resume FinalExit
End Sub
Sub Analyze_Movie(mySlide As Slide, myShape As Shape)
    On Error GoTo HandleErrors
    Dim currentFunctionName As String
    currentFunctionName = "Analyze_Movie"

    If myShape.Type <> msoMedia Then Exit Sub
    If myShape.MediaType <> ppMediaTypeMovie Then Exit Sub

    Dim myIssue As IssueInfo
    Set myIssue = New IssueInfo

    With myIssue
        .IssueID = CID_OBJECTS_GRAPHICS_TEXTBOXES
        .IssueType = RID_STR_PP_ISSUE_OBJECTS_GRAPHICS_AND_TEXTBOXES
        .SubType = RID_STR_PP_SUBISSUE_MOVIE
        .Location = .CLocationSlide

        .IssueTypeXML = CSTR_ISSUE_OBJECTS_GRAPHICS_AND_TEXTBOXES
        .SubTypeXML = CSTR_SUBISSUE_MOVIE
        .locationXML = .CXMLLocationSlide

        .SubLocation = mySlide.name
        .Line = myShape.top
        .column = myShape.Left

        .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME
        .Values.Add myShape.name
        .Attributes.Add RID_STR_COMMON_ATTRIBUTE_SOURCE
        .Values.Add myShape.LinkFormat.SourceFullName
        .Attributes.Add RID_STR_PP_ATTRIBUTE_PLAYONENTRY
        .Values.Add IIf(myShape.AnimationSettings.PlaySettings.PlayOnEntry, RID_STR_PP_TRUE, RID_STR_PP_FALSE)
        .Attributes.Add RID_STR_PP_ATTRIBUTE_LOOP
        .Values.Add IIf(myShape.AnimationSettings.PlaySettings.LoopUntilStopped, RID_STR_PP_TRUE, RID_STR_PP_FALSE)
        .Attributes.Add RID_STR_PP_ATTRIBUTE_REWIND
        .Values.Add IIf(myShape.AnimationSettings.PlaySettings.RewindMovie, RID_STR_PP_TRUE, RID_STR_PP_FALSE)

         mAnalysis.IssuesCountArray(CID_OBJECTS_GRAPHICS_TEXTBOXES) = _
                mAnalysis.IssuesCountArray(CID_OBJECTS_GRAPHICS_TEXTBOXES) + 1
    End With

    mAnalysis.Issues.Add myIssue

FinalExit:
    Set myIssue = Nothing
    Exit Sub

HandleErrors:
    WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
    Resume FinalExit
End Sub

Private Sub Class_Initialize()
    Set mAnalysis = New DocumentAnalysis
End Sub
Private Sub Class_Terminate()
    Set mAnalysis = Nothing
End Sub

Public Property Get Results() As DocumentAnalysis
    Set Results = mAnalysis
End Property