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 '/************************************************************************* ' * ' DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER. ' ' Copyright 2000, 2010 Oracle and/or its affiliates. ' ' OpenOffice.org - a multi-platform office productivity suite ' ' This file is part of OpenOffice.org. ' ' OpenOffice.org is free software: you can redistribute it and/or modify ' it under the terms of the GNU Lesser General Public License version 3 ' only, as published by the Free Software Foundation. ' ' OpenOffice.org is distributed in the hope that it will be useful, ' but WITHOUT ANY WARRANTY; without even the implied warranty of ' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ' GNU Lesser General Public License version 3 for more details ' (a copy is included in the LICENSE file that accompanied this code). ' ' You should have received a copy of the GNU Lesser General Public License ' version 3 along with OpenOffice.org. If not, see ' ' for a copy of the LGPLv3 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 \prepared\ 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