XL 2016 comment créer une Barre de défilement ou faire simplement défiler son texte ?

[melltel]

Bonjour,

Je suis consciente que ce que je demande est peut-être inexistant, mais j'ai une lueur d'espoir.

J'ai deux fichiers Excel et PowerPoint qui collaborent, Excel étant ma base.
Du fichier Excel, j'ai extrait des données texte pour les copier dans PowerPoint dans une zone de texte "espaceCom".

Cependant, le texte extrait est trop grand pour l'espace dédié. Je ne souhaite pas réduire la taille du texte, car il deviendrait illisible, et je ne peux pas non plus augmenter la taille de la zone 'espaceCom'.
Je me suis dit qu'en rendant le texte dynamique avec une barre de défilement ou un petit ascenseur sur le côté, cela pourrait fonctionner.
Mais, après avoir fouillé partout, je ne trouve aucune piste de solution.

S'il vous plaît, quelqu'un peut-il m'orienter ou m'aider dans ce sens ?
Merci

Sub Campus()
Dim c As Range
Dim texte As String
Dim PPApp As Object
Dim PPTPrésentation As Object
Dim slideIndex As Integer

' Ouverture du PowerPoint s'il n'est pas déjà ouvert
On Error Resume Next
Set PPApp = GetObject(, "PowerPoint.Application")
On Error GoTo 0
If PPApp Is Nothing Then
Set PPApp = CreateObject("PowerPoint.Application")
End If
PPApp.Visible = True

' Ouverure de la présentation PowerPoint existante ou creation d' une nouvelle présentation
On Error Resume Next
Set PPTPrésentation = PPApp.Presentations("ppt5E35.pptx")
On Error GoTo 0
If PPTPrésentation Is Nothing Then
Set PPTPrésentation = PPApp.Presentations.Open(ThisWorkbook.Path & "\ppt5E35.pptx")
End If

' Concaténation les données de la colonne 2 (C) de Tableau1 dans Excel
For Each c In ThisWorkbook.Sheets("Feuille1").Range("G2:G" & ThisWorkbook.Sheets("Feuille1").Cells(Rows.Count, 2).End(xlUp).Row)
If c.Offset(0, -1).Value >= 1 Then ' Vérifier si la note en colonne B est supérieure ou égale à 4
If c.Value <> "" Then
texte = texte & vbLf & "- " & c.Value ' Pour Ajouter un tiret devant chaque nouveau commentaire
End If
End If
Next
texte = Mid(texte, 2) ' Supprimer le premier retour à la ligne

' Insérer le texte dans le premier slide de la présentation
slideIndex = 2
With PPTPrésentation.Slides(slideIndex).Shapes("espaceCom").TextFrame.TextRange
.Text = texte
.ParagraphFormat.Alignment = 1 ' 1=alignement à gauche
End With

' Activer PowerPoint
AppActivate PPApp.Caption
End Sub

 

[crocrocro]

Bonjour Melltel,
ci-dessous, un exemple de défilement.
Dans l'exemple on boucle 5 fois sur le texte.
A adapter selon vos besoins (remplacer Range("A1") par .Text dans votre macro Campus), çà fonctionne.
J'imagine cependant qu'il existe des solutions plus adaptées,
Souhaitez-vous réellement lancer PowerPoint depuis Excel ?
Je ne sais pas si on peut récupérer les données des feuilles Excel depuis PowerPoint et donc déporter tout le code dans PowerPoint.
La macro pourrait alors être lancée à l'affichage de la diapo de présentation et s'achever au changement de diapo

'-> fait une pause pour un temps donné
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub FaireDéfiler()
Dim i As Integer
Dim Texte As String
    Texte = "Mon texte défilant"
    Range("A1") = TexteDefilantPPT(Texte, True)
    For i = 1 To Len(Texte) * 5 - 1 ' (5 fois la boucle) pour terminer sur le texte du début
        Range("A1") = TexteDefilantPPT(Texte)
        Sleep 100 'pause de 100 /1000 de secondes
    Next i
End Sub
Function TexteDefilantPPT(pTexte As String, Optional pPremiereFois As Boolean = False) As String
    Static ValTexteDefilant As String
    If pPremiereFois Then
        ValTexteDefilant = pTexte
    End If
    ValTexteDefilant = Right(ValTexteDefilant, 1) & Left(ValTexteDefilant, Len(ValTexteDefilant) - 1)
    TexteDefilantPPT = ValTexteDefilant
End Function

 

[melltel]

Une suggestion :
Pour les 2 fichiers excel dont dépend le texte PowerPoint :
sur l'événement WorkSheet_Change des cellules concernées, excéuter à peu de chose près votre macro Campus, mais au lieu d'ouvrir le fichier PP, simplement enregistrer avec la nouvelle valeur du texte.
Ainsi, le fichier PP sera toujours à jour.
Créer la La macro VBA dans le fichier PP qui à l'affichage de la diapo de présentation fait défiler le texte et s'achève au changement de diapo

Merci pour ton retour crocrocro, j'ai éssayé mais malheureusement ca ne s'execute pas, la fonction 'sleep' refuse

 

[crocrocro]

Autre proposition, plus simple, moins bricolage (elle utilise un textbox multi-ligne avec une barre de défilement intégrée mais avec toujours un problème que je n'arrive pas à résoudre et qui m'oblige à bidouiller :

Dans le fichier PP, il y a :
une seule zone de texte
- "ZoneTexte Complet" qui contient le texte complet mais qui est invisible (voir propriétés)
un contrôle ActiveX TextBox "TextBox1" en mode multi-ligne avec barre de défilement verticale.

Pour mettre à jour "TextBox1" (je n'ai pas réussi par excel ), il faut dans le fichier PP, exécuter la macro MajTxt manuellement comme suit :
- Onglet Développeur -> Visual Basic -> F5 sur le code de la macro

Le code Excel du Module 1

Option Explicit
Sub Campus()
Dim c As Range
Dim TexteComplet As String
Dim PPApp As Object
Dim PPTPrésentation As Object
Dim ScrollBar As Object
Dim slideIndex As Integer
    ' Ouverture du PowerPoint s'il n'est pas déjà ouvert
    On Error Resume Next
    Set PPApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0
    If PPApp Is Nothing Then
    Set PPApp = CreateObject("PowerPoint.Application")
    End If
    PPApp.Visible = True
    
    ' Ouverure de la présentation PowerPoint existante ou creation d' une nouvelle présentation
    On Error Resume Next
    Set PPTPrésentation = PPApp.Presentations("ppt5E35.pptm")
    On Error GoTo 0
    If PPTPrésentation Is Nothing Then
    Set PPTPrésentation = PPApp.Presentations.Open(ThisWorkbook.Path & "\ppt5E35.pptm")
    End If
    
    ' Concaténation les données de la colonne 2 (C) de Tableau1 dans Excel
    For Each c In ThisWorkbook.Sheets("Feuil1").Range("G2:G" & ThisWorkbook.Sheets("Feuil1").Cells(Rows.Count, 2).End(xlUp).Row)
        If c.Offset(0, -1).Value >= 1 Then ' Vérifier si la note en colonne B est supérieure ou égale à 4
            If c.Value <> "" Then
                TexteComplet = TexteComplet & vbLf & "- " & c.Value ' Pour Ajouter un tiret devant chaque nouveau commentaire
            End If
        End If
    Next
    TexteComplet = Mid(TexteComplet, 2) ' Supprimer le premier retour à la ligne
    ' Insérer le texte dans le premier slide de la présentation
    slideIndex = 2
    With PPTPrésentation.Slides(slideIndex).Shapes("ZoneTexte Complet").TextFrame.TextRange
        .TEXT = TexteComplet
        .ParagraphFormat.Alignment = 1 ' 1=alignement à gauche
    End With
    ' je ne trouve pas la syntaxe pour alimenter le Contrôle ActiveX "TextBox1"
    'With PPTPrésentation.Slides(slideIndex).Shapes("TextBox1").TextFrame.TextRange
    '    .TEXT = TexteComplet
    'End With

    ' Activer PowerPoint
    PPTPrésentation.Save
    PPTPrésentation.Close
    Set PPApp = Nothing
    Set PPTPrésentation = Nothing
End Sub

Le Code du fichier PP (slide2)

Sub MajTxt()
    With Application.ActivePresentation.Slides(2)
        TextBox1.Text = .Shapes("ZoneTexte Complet").TextFrame.TextRange.Text
    End With
End Sub

 

[melltel]

Bonjour Melltel,
en pj, la solution que je te propose dont voici le principe :
Dans le fichier PP, il y a :
2 zones de texte
- "ZoneTexte Complet" qui contient le texte complet mais qui est invisible (voir propriétés)
- "ZoneTexte 1" qui contient une ligne du texte et qui correspond à l'emplacement réservé dans la diapositive
une barre de défilement (scrollbar1) qui permet d'afficher la ligne précédente / suivante dans ZoneTexte 1
Dans le Fichier Excel, :
la macro Campus est appelé à chaque modification en G2:G10 (à adapter)
elle renseigne les 2 zones texte du PP.
Je n'ai pas réussi à paramétrer la barre de défilement (pour les valeurs min et max correspondant au nombre de lignes).
Dans la macro, j'ai remplacé le activate du fichier ppt par une fermeture avec sauvegarde.
Le code du fichier Excel
Feuille Feuil1

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not (Intersect(Target, Range("G2:G10")) Is Nothing) Then
        Campus
    End If
End Sub

Module 1

Option Explicit
Sub Campus()
Dim c As Range
Dim TexteComplet As String, Texte1 As String
Dim tableau
Dim PPApp As Object
Dim PPTPrésentation As Object
Dim slideIndex As Integer
    ' Ouverture du PowerPoint s'il n'est pas déjà ouvert
    On Error Resume Next
    Set PPApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0
    If PPApp Is Nothing Then
    Set PPApp = CreateObject("PowerPoint.Application")
    End If
    PPApp.Visible = True
   
    ' Ouverure de la présentation PowerPoint existante ou creation d' une nouvelle présentation
    On Error Resume Next
    Set PPTPrésentation = PPApp.Presentations("ppt5E35.pptm")
    On Error GoTo 0
    If PPTPrésentation Is Nothing Then
    Set PPTPrésentation = PPApp.Presentations.Open(ThisWorkbook.Path & "\ppt5E35.pptm")
    End If
   
    ' Concaténation les données de la colonne 2 (C) de Tableau1 dans Excel
    For Each c In ThisWorkbook.Sheets("Feuil1").Range("G2:G" & ThisWorkbook.Sheets("Feuil1").Cells(Rows.Count, 2).End(xlUp).Row)
        If c.Offset(0, -1).Value >= 1 Then ' Vérifier si la note en colonne B est supérieure ou égale à 4
            If c.Value <> "" Then
                TexteComplet = TexteComplet & vbLf & "- " & c.Value ' Pour Ajouter un tiret devant chaque nouveau commentaire
            End If
        End If
    Next
    TexteComplet = Mid(TexteComplet, 2) ' Supprimer le premier retour à la ligne
    tableau = Split(TexteComplet, vbLf)
    Texte1 = tableau(0)
    ' Insérer le texte dans le premier slide de la présentation
    slideIndex = 2
    With PPTPrésentation.Slides(slideIndex).Shapes("ZoneTexte Complet").TextFrame.TextRange
        .TEXT = TexteComplet
        .ParagraphFormat.Alignment = 1 ' 1=alignement à gauche
    End With
    With PPTPrésentation.Slides(slideIndex).Shapes("ZoneTexte 1").TextFrame.TextRange
        .TEXT = Texte1
        .ParagraphFormat.Alignment = 1 ' 1=alignement à gauche
    End With
    'With PPTPrésentation.Slides(slideIndex).ScrollBar("ScrollBar 1")
    '    .Min = LBound(tableau) + 1
    '    .Max = UBound(tableau) + 1
    '    .Value = LBound(tableau) + 1
    'End With
    ' Activer PowerPoint
    PPTPrésentation.Save
    PPTPrésentation.Close
    Set PPApp = Nothing
    Set PPTPrésentation = Nothing
End Sub

Le Code du fichier PP (slide2)

Private Sub ScrollBar1_Change()
Dim Tableau
    With Application.ActivePresentation.Slides(2)
        Tableau = Split(.Shapes("ZoneTexte Complet").TextFrame.TextRange.Text, vbLf)
        If ScrollBar1.Value > UBound(Tableau) Then ScrollBar1.Value = UBound(Tableau)
        .Shapes("ZoneTexte 1").TextFrame.TextRange.Text = Tableau(ScrollBar1.Value)
    End With
End Sub

Private Sub ScrollBar1_GotFocus()
Dim Tableau
    With Application.ActivePresentation.Slides(2)
        Tableau = Split(.Shapes("ZoneTexte Complet").TextFrame.TextRange.Text, vbLf)
        ScrollBar1.Min = LBound(Tableau)
        ScrollBar1.Max = UBound(Tableau)
    End With
End Sub

Merci Crocrocro, j'avoue que j'ai du mal à comprendre et a appliquer.
Cependant, j'ai un peu adapter à mon fichier , il ne présente pas d'erreur mais ferme le fichier PP directement à l'ouverture, j'ai donc commenter dans pp mais toujours rien.
' Fermer Excel
wb.Close False
appExcel.Quit
Set ws = Nothing
Set wb = Nothing
Set appExcel = Nothing

Merci pour ton investissement, je crois que je vais d'avantage fouiller.

 

[crocrocro]

Ce n'est pas compliqué, on peut voir çà pas à pas, éventuellement, pour ne pas encombrer la discussion, via les conversations par l'icone

sur le bandeau.

 

[crocrocro]

As-tu pu tester directement mes fichiers?
je vois que tu n'as pas activé la fonction Conversation

 

[crocrocro]

Je viens de trouver la syntaxe pour alimenter la TextBox1 depuis le fichier Excel.
Ce qui simplifie le code et les manipulations (rien à faire côté powerpoint).
Le fichier PP est sans macro, donc avec l'extension classique .pptx
Un bug (microsoft ?) : au 1er clic pour faire défiler vers le bas, on passe directement à la dernière ligne la 1ère fois. Ensuite tout est normal

Le code du module 1

Option Explicit
Public Const NomFichierPP = "ppt5E35.pptx"
Sub Campus()
Dim c As Range
Dim TexteComplet As String
Dim PPApp As Object
Dim PPTPrésentation As Object
Dim ScrollBar As Object
Dim slideIndex As Integer
    ' Ouverture du PowerPoint s'il n'est pas déjà ouvert
    On Error Resume Next
    Set PPApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0
    If PPApp Is Nothing Then
    Set PPApp = CreateObject("PowerPoint.Application")
    End If
    PPApp.Visible = True
    
    ' Ouverure de la présentation PowerPoint existante ou creation d' une nouvelle présentation
    On Error Resume Next
    Set PPTPrésentation = PPApp.Presentations(NomFichierPP)
    On Error GoTo 0
    If PPTPrésentation Is Nothing Then
    Set PPTPrésentation = PPApp.Presentations.Open(ThisWorkbook.Path & "\" & NomFichierPP)
    End If
    
    ' Concaténation les données de la colonne 2 (C) de Tableau1 dans Excel
    For Each c In ThisWorkbook.Sheets("Feuil1").Range("G2:G" & ThisWorkbook.Sheets("Feuil1").Cells(Rows.Count, 2).End(xlUp).Row)
        If c.Offset(0, -1).Value >= 1 Then ' Vérifier si la note en colonne B est supérieure ou égale à 4
            If c.Value <> "" Then
                TexteComplet = TexteComplet & vbLf & "- " & c.Value ' Pour Ajouter un tiret devant chaque nouveau commentaire
            End If
        End If
    Next
    TexteComplet = Mid(TexteComplet, 2) ' Supprimer le premier retour à la ligne
    ' Insérer le texte dans le premier slide de la présentation
    slideIndex = 2
    With PPTPrésentation.Slides(slideIndex).Shapes("ZoneTexte Complet").TextFrame.TextRange
        .TEXT = TexteComplet
        .ParagraphFormat.Alignment = 1 ' 1=alignement à gauche
    End With
    With PPTPrésentation.Slides(slideIndex).Shapes("TextBox1")
        .OLEFormat.Object.TEXT = TexteComplet
    End With

    ' Activer PowerPoint
    AppActivate PPApp.Caption
    PPTPrésentation.Save
    ''PPTPrésentation.Close
    Set PPApp = Nothing
    Set PPTPrésentation = Nothing
End Sub

 

[melltel]

Je viens de trouver la syntaxe pour alimenter la TextBox1 depuis le fichier Excel.
Ce qui simplifie le code et les manipulations (rien à faire côté powerpoint).
Le fichier PP est sans macro, donc avec l'extension classique .pptx
Un bug (microsoft ?) : au 1er clic pour faire défiler vers le bas, on passe directement à la dernière ligne la 1ère fois. Ensuite tout est normal

Le code du module 1

Option Explicit
Public Const NomFichierPP = "ppt5E35.pptx"
Sub Campus()
Dim c As Range
Dim TexteComplet As String
Dim PPApp As Object
Dim PPTPrésentation As Object
Dim ScrollBar As Object
Dim slideIndex As Integer
    ' Ouverture du PowerPoint s'il n'est pas déjà ouvert
    On Error Resume Next
    Set PPApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0
    If PPApp Is Nothing Then
    Set PPApp = CreateObject("PowerPoint.Application")
    End If
    PPApp.Visible = True
   
    ' Ouverure de la présentation PowerPoint existante ou creation d' une nouvelle présentation
    On Error Resume Next
    Set PPTPrésentation = PPApp.Presentations(NomFichierPP)
    On Error GoTo 0
    If PPTPrésentation Is Nothing Then
    Set PPTPrésentation = PPApp.Presentations.Open(ThisWorkbook.Path & "\" & NomFichierPP)
    End If
   
    ' Concaténation les données de la colonne 2 (C) de Tableau1 dans Excel
    For Each c In ThisWorkbook.Sheets("Feuil1").Range("G2:G" & ThisWorkbook.Sheets("Feuil1").Cells(Rows.Count, 2).End(xlUp).Row)
        If c.Offset(0, -1).Value >= 1 Then ' Vérifier si la note en colonne B est supérieure ou égale à 4
            If c.Value <> "" Then
                TexteComplet = TexteComplet & vbLf & "- " & c.Value ' Pour Ajouter un tiret devant chaque nouveau commentaire
            End If
        End If
    Next
    TexteComplet = Mid(TexteComplet, 2) ' Supprimer le premier retour à la ligne
    ' Insérer le texte dans le premier slide de la présentation
    slideIndex = 2
    With PPTPrésentation.Slides(slideIndex).Shapes("ZoneTexte Complet").TextFrame.TextRange
        .TEXT = TexteComplet
        .ParagraphFormat.Alignment = 1 ' 1=alignement à gauche
    End With
    With PPTPrésentation.Slides(slideIndex).Shapes("TextBox1")
        .OLEFormat.Object.TEXT = TexteComplet
    End With

    ' Activer PowerPoint
    AppActivate PPApp.Caption
    PPTPrésentation.Save
    ''PPTPrésentation.Close
    Set PPApp = Nothing
    Set PPTPrésentation = Nothing
End Sub

ooo Merci, Je crois qu'on a le meme là. Attend je t'envoi mes 2 fichiers et tu verra mieux les bugs

 

[crocrocro]

Je viens de récupérer tes fichiers.
j'ai ajouté mes modifications, tout fonctionne correctement.
Dans la diapo 2, j'ai supprimé la TextBox "espaceCom" et l'ai remplacé par une textbox ActiveX nommée "Commentaire" qui a 2 propriétés pour la gestion multi-lignes avec ascenseur (voir ci-dessous)

je t'envoie en suivant, les 2 fichiers

 

[melltel]

C'est Nickel, ca fonctionne
Merci beaucoup et désolé pour le dérangement

Merci Crocrocro

 

[crocrocro]

Avec plaisir,
dommage que tu n'es pas fourni tes fichiers quand tu as ouvert la discussion , j'aurais vu que mes premières propositions n'étaient pas bonnes. C'est toujours plus facile avec un fichier joint, même restreint

 

[melltel]

Avec plaisir,
dommage que tu n'es pas fourni tes fichiers quand tu as ouvert la discussion , j'aurais vu que mes premières propositions n'étaient pas bonnes. C'est toujours plus facile avec un fichier joint, même restreint

Bonjour Crocrocro,
Stp as tu essayé de lire le powerpoint sous forme de présentation? il y'a une doublure au niveau de la zone de commentaires et depuis je ne sais comment l'enlever. S'il te plait aurais tu une idée ?
Merci.

 

[crocrocro]

Bonjour Melltel,
j'ai refait un test avec le fichier que j'avais mis dans le post #10,
aucun problème.
Est-ce bien ce fichier que tu as utilisé ?
Sinon, renvoie-moi ton fichier.
Je soupçonne une duplication de la zone texte

 

[melltel]

Bonjour Melltel,
j'ai refait un test avec le fichier que j'avais mis dans le post #10,
aucun problème.
Est-ce bien ce fichier que tu as utilisé ?
Sinon, renvoie-moi ton fichier.
Je soupçonne une duplication de la zone texte

Oui j'ai bien utilisé ton fichier , celui du post #10
au visuel aucun problème mais en présentation on voit une doublure sur la zone de "commentaire avec la seule possibilité de modifier celui au dessus.
je te met ici mon fichier qui n'a pas trop changé