(apwp) analyseur de fichiers power point - class diapo

Soyez le premier à donner votre avis sur cette source.

Snippet vu 13 670 fois - Téléchargée 45 fois

Contenu du snippet

à partir d'un document Power Point, il est posible d'obtenir des résumés, l'auteur, les titres ...

Source / Exemple :


Public Class diapo
    Dim ppApp As PowerPoint.Application
    Dim prsPres As PowerPoint.Presentation

    Public Sub New()
        MyBase.new()
        ppApp = New PowerPoint.Application()
    End Sub

    Public Sub Ouvrir(ByVal nomFichier As String)
        With ppApp
            .Visible = True
            .WindowState = PowerPoint.PpWindowState.ppWindowMinimized
        End With
        prsPres = ppApp.Presentations.Open(nomFichier, , , True)
    End Sub

    Public Function Fermer()
        prsPres.Close()
        ppApp.Quit()
    End Function
    '''''''''''''''''''''''''''''''''' Slides ''''''''''''''''''''''''''''''''''''''
    Public Function NombreSlides() As Integer
        NombreSlides = prsPres.Slides.Count
    End Function

    Sub tNombreSlides()
        MsgBox(NombreSlides())
    End Sub

    Public Function NomSlide(ByVal indice) As String
        NomSlide = prsPres.Slides.Item(indice).Name
    End Function

    Sub tNomSlide()
        REM cible = Int(Rnd * NombreSlides + 1)
        Dim cible
        cible = 51
        MsgBox(NomSlide(cible))
    End Sub

    Public Function TitreSlide(ByVal indice) As String
        Dim elementTitre As PowerPoint.Shapes
        elementTitre = prsPres.Slides.Item(indice).Shapes
        If elementTitre.HasTitle Then
            TitreSlide = elementTitre.Title.TextFrame.TextRange.Text
        Else
            TitreSlide = NomSlide(indice)
        End If
    End Function

    Sub tTitreSlide()
        Dim cible
        cible = 1
        MsgBox(TitreSlide(cible))
    End Sub

    Function Description(ByVal indice) As String
        REM différentes vérifictions (grace aux if)
        REM  - le nombre de lignes < 5
        REM  - uniquement du text
        REM  - des lignes > 1 caractère
        REM  - ne pas remettre le titre sur la première ligne
        Dim element As PowerPoint.Shapes
        Dim tampon, nb, e
        element = prsPres.Slides.Item(indice).Shapes
        tampon = ""
        nb = 0
        For Each e In element
            If nb < 5 Then
                If e.HasTextFrame Then
                    If e.TextFrame.TextRange.Length > 1 Then
                        If e.TextFrame.TextRange.Text <> TitreSlide(indice) Then
                            tampon = tampon + e.TextFrame.TextRange.Text & Chr(10) & Chr(13)
                            nb = nb + 1
                        End If
                    End If
                End If
            End If
        Next
        Description = tampon
    End Function

    Sub tDescription()
        Dim diapos As PowerPoint.Slides
        Dim d
        diapos = prsPres.Slides
        For Each d In diapos
            MsgBox(Description(d.SlideIndex))
        Next
    End Sub

    Function Fiche(ByVal indice, ByVal selection) As String
        Dim tampon
        If selection = 1 Or selection = 3 Then
            tampon = TitreSlide(indice)
            tampon = tampon + "  << " + NomSlide(indice) + " >>"
            tampon = tampon & Chr(10) & Chr(10) & Chr(13)
        End If
        If selection = 2 Or selection = 3 Then
            tampon = tampon + Description(indice)
        End If
        Fiche = tampon
    End Function

    Sub tFiche()
        Dim diapos As PowerPoint.Slides
        Dim d
        diapos = prsPres.Slides
        For Each d In diapos
            MsgBox(Fiche(d.SlideIndex, 3))
        Next
    End Sub

    Sub Ecrire(ByVal Nomfichier As String)
        With prsPres.WebOptions
            .IncludeNavigation = True
            .FrameColors = 1
            .ResizeGraphics = True
            .ShowSlideAnimation = False
            .OrganizeInFolder = True
            .UseLongFileNames = True
            .RelyOnVML = False
            .AllowPNG = False
            .ScreenSize = Microsoft.Office.Core.MsoScreenSize.msoScreenSize800x600
            .Encoding = 1252
        End With
        With ppApp.DefaultWebOptions
            .UpdateLinksOnSave = True
            .CheckIfOfficeIsHTMLEditor = True
            .AlwaysSaveInDefaultEncoding = False
            .SaveNewWebPagesAsWebArchives = False
        End With
        prsPres.SaveAs(Nomfichier, PowerPoint.PpSaveAsFileType.ppSaveAsHTMLv3, False)

    End Sub

    Sub tEcrire()
        Dim Nomfichier As String = "P:\testFctEcrire"
        Ecrire(Nomfichier)
    End Sub

    Function Fichier(ByVal indice As Integer) As String
        Dim tampon As String
        Dim i As Integer = NomSlide(indice).Length
        tampon = NomSlide(indice)

        While tampon.Chars(i - 1) <> "e" And i > 1
            i = i - 1
        End While
        tampon = tampon.Substring(i)

        While tampon.Length < 4
            tampon = "0" & tampon
        End While

        Fichier = "slide" & tampon & ".htm"
    End Function

    '''''''''''''''''''''''''''''''''''''' Diapo '''''''''''''''''''''''''''''''''''''
    Public Function PropTitre()
        If ppApp.ActivePresentation.BuiltInDocumentProperties.item(1).value <> "" Then
            PropTitre = ppApp.ActivePresentation.BuiltInDocumentProperties.item(1).value
        End If
    End Function

    Sub tPropTitre()
        MsgBox(PropTitre())
    End Sub

    Public Function PropDescription()
        Dim tampon
        If ppApp.ActivePresentation.BuiltInDocumentProperties.item(2).value <> "" Then
            tampon = ppApp.ActivePresentation.BuiltInDocumentProperties.item(2).value
            tampon = tampon + Chr(13) + Chr(10) + Chr(10)
        End If
        If ppApp.ActivePresentation.BuiltInDocumentProperties.item(5).value <> "" Then
            tampon = tampon + ppApp.ActivePresentation.BuiltInDocumentProperties.item(5).value
        End If
        PropDescription = tampon
    End Function

    Public Function tPropDescription()
        MsgBox(PropDescription())
    End Function

    Function PropAuteur()
        If ppApp.ActivePresentation.BuiltInDocumentProperties.item(3).value <> "" Then
            PropAuteur = PropAuteur + ppApp.ActivePresentation.BuiltInDocumentProperties.item(3).value
        End If
    End Function

    Public Function tPopAuteur()
        MsgBox(PropAuteur())
    End Function

    Public Function PropDate()
        PropDate = System.DateTime.Now.ToLongDateString()
    End Function

    Public Function tPropDate()
        MsgBox(PropDate())
    End Function

    Public Function Identifiant() As String
        Dim i As Integer
        Dim tampon As String
        tampon = System.DateTime.Now.ToShortDateString() + PropTitre()
        For i = 0 To (tampon.Length - 1)
            If tampon.Chars(i) <> "\" And tampon.Chars(i) <> "/" And tampon.Chars(i) <> " " Then
                Identifiant = Identifiant + tampon.Chars(i)
            End If
        Next
    End Function

    Function ListeTout(ByVal selection As Integer)
        Dim Texte(NombreSlides() - 1) As String
        Dim i
        For i = 0 To (NombreSlides() - 1)
            Select Case (selection)
                Case 1
                    Texte(i) = NomSlide(i + 1)
                Case 2
                    Texte(i) = TitreSlide(i + 1)
                Case Else
                    Texte(i) = TitreSlide(i + 1) & " (>-<'` " & NomSlide(i + 1)
            End Select
        Next
        ListeTout = Texte
    End Function

End Class

Conclusion :


Pour utiliser la classe, il faut commencer par ajouter la Référence COM "MicrosoftPowerPoint".
Ensuite il faut instancer la classe de manière habituelle en utilisant les fonctions new et Ouvrir(ByVal nomFichier As String).
Et n'oubliez pas la fonction Fermer() à la fin

A voir également

Ajouter un commentaire

Commentaire

KrSt94
Messages postés
3
Date d'inscription
jeudi 24 février 2005
Statut
Membre
Dernière intervention
15 février 2007
-
Salut, interressant !
Mais est il possible de naviguer dans le powerpoint (changer de slides etc) directement depuis l'appli VB ?

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.