Discussion :

[tiber33]

Bonjour,

Je cherche, depuis une macro excel, à aller voir si des valeurs présentes dans une colonne excel sont présentes dans des shapes ppt.
L'idée étant que si une valeur est présente, un oui apparait dans la case en face de cette valeur dans excel, sinon un non.

J'ai tenté une macro, qui semble planter avant même le début...
Et par la suite, l'utilisation de la fonction 'find' me parait naïve, n'ayant pu la tester...

Ci-dessous mon code, en espérant que ça pourra en inspirer certains pour me guider

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
Sub vérifier_si_présent()
 
 
    ' Start PowerPoint.
    Dim ppApp As PowerPoint.Application
    Dim ppPres As PowerPoint.presentation
    Set ppApp = CreateObject("Powerpoint.Application")
    Set ppPres = ppApp.presentation.Open("C:\Users\NG2F637\Desktop\tools\détection shapes\test.pptx")  ' chemin vers fichier ppt
 
    ' Make it visible.
    ppApp.Visible = True
 
    Dim ppSlide As PowerPoint.slide
    Dim ppShape As PowerPoint.Shape
    Dim cherche, trouve As String
 
Application.ScreenUpdating = False
 
Sheets("ici").Select
 
 
    k = 3 ' Parcourir
 
    While Sheets("ici").Cells(k, 2) <> "" ' tant que la cellule n'est pas vide
 
    cherche = Sheets("ici").Cells(k, 2)  ' mettre la valeur à remplacer dans la variable
 
 
 
    For Each ppSlide In ppPres.Slides  ' parcourir les slides
 
        For Each ppShape In ppSlide.Shapes    ' parcourir les shapes
 
 
    On Error Resume Next
 
            Set oTxtRng = ppShape.TextFrame.TextRange()
            Set oTmpRng = oTxtRng.Search(cherche, cherche)
 
            Do While Not oTmpRng Is Nothing
 
 
                Set oTxtRng = oTxtRng.Characters _
                (oTmpRng.Start + oTmpRng.Length, oTxtRng.Length)
                Set oTmpRng = oTxtRng.Search(cherche, cherche)
 
            Loop
        Next ppShape
    Next ppSlide
 
    If oTmpRng = True Then   'au bluffe...
    Sheets("ici").Cells(k, 8).Range = "OUI"
    Else: Sheets("ici").Cells(k, 8).Range = "NON"
    End If
 
    k = k + 1
    Wend
 
ppApp.Quit
 
Set ppApp = Nothing
Application.ScreenUpdating = True
End Sub

Merci pour votre aide et bonne soirée !

[Invité]

Bonjour

J'ai tenté une macro, qui semble planter avant même le début...

C'est à dire ? Message d'erreur ?

Philippe

[tiber33]

"Erreur de compilation - type défini par l'utilisateur non défini" pour la ligne 5

[Invité]

RE

Il faut que tu déclares la référence PowerPoint.

Editeur VB Outils/Référence et tu coches PowerPoint.

Philippe

[tiber33]

En effet, je l'avais oublié celui là, pour d'autres macro de ppt qui appelle excel j'y avais pensé mais là non...

Du coup ça la lance, mais là où je rame méchament, c'est pour le vocabulaire de vba concernant ppt (les presentation, shapes and co...)

J'ai cherché mais n'ai rien trouvé de construit (à l'inverse de vba excel), si tu as une doc je suis preneur, ça m'éviterait de poser 36000 questions pour des broutilles...

Là, nouvelle erreur, ligne 8:
"erreur de compilation: Membre de méthode ou de données introuvable"
en surlignant le '.presentation'

[clementmarcotte]

Bonjour,

J'ai cherché mais n'ai rien trouvé de construit (à l'inverse de vba excel), si tu as une doc je suis preneur, ça m'éviterait de poser 36000 questions pour des broutilles...

Tu peux utiliser l'aide de VBA pour PowerPoint à partir de l'aide de VBA pour Excel.

1-Tu places le pointeur de souris sur ton mot-clef de VBA-Powerpoint
2-Tu appuies plus ou moins fort (c'est à ton goût ) sur la touche F1.
3-Tu choisis l'objet PowerPoint dans la boîte de dialogue

P.S. Je pense que j'ai réglé ce problème-ci dans ma réponse dans ton autre fil.

[tiber33]

Ce problème-ci est sensiblment différent en fait... j'ai pas mal pianoté avec l'aide (merci !) et je suis arrivé à ceci:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
Sub vérifier_présence()
 
 
    Dim chemin, chemin_final As String
 
    chemin = Workbooks(ActiveWorkbook.Name).Path
 
    Set AppPPoint = New PowerPoint.Application
    Dim Presentation As PowerPoint.Presentation
    Dim aubout, commence As Integer
 
Application.ScreenUpdating = False
 
'ouverture du ppt placé dans le répertoire du fichier excel et de nom donné en i1
Sheets("ici").Select
chemin_final = chemin & "\" & ActiveSheet.Range("i1").Value & ".ppt"
 
    Set Presentation = AppPPoint.Presentations.Open(chemin_final)
 
        commence = 3
    While ActiveSheet.Cells(commence, 2).Value <> ""
        For Each diapo In Presentation.Slides  'parcourir les slides
          For Each Forme In diapo.Shapes 'parcourir les formes
 
                    If Forme.TextFrame.TextRange = ActiveSheet.Cells(commence, 2).Value Then
                        ActiveSheet.Cells(commence, 19).Value = "Oui"
                        Exit For
                    End If
 
         Next
      Next
      commence = commence + 1
    Wend
 
Presentation.Close
 
 
AppPPoint.Quit
 
Application.ScreenUpdating = False
 
End Sub

La macro balaye une colonne, et pour chaque ligne non vide regarde dans ppt si une shape contient cette info. (dans excel, en face de l'info, on renvoie oui si trouvée, non si pas dans une shape)


La macro fonctionne pour un ppt où seules des shapes sont présentes, mais lorsque des tableaux sont présents (que je ne veux pas "visiter") la macro plante.

alors la macro avance, j'arrive à la faire marcher sauf quand des 'shapes' contenant des caractères particuliers (je suppose, du genre - LH -...)sont à lire (ou qu'un tableau à 1 colonne est à lire, mais ça je m'en suis défait en ne lisant pas les premières slides qui peuvent contenir ce tableau...)

La macro donne ça, si des gens peuvent m'aider... l'idéal serait une fonction qui cherche et renvoi true si elle a trouvé la chaine dans une shape, false sinon ...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
Option Explicit
    Dim appPPoint As PowerPoint.Application
    Dim Presentation As PowerPoint.Presentation
    Dim diapositive As PowerPoint.Slide
    Dim forme As PowerPoint.Shapes
    Dim latable As PowerPoint.Table
    Dim chemin_final, chemin As String
    Dim i As Long
    Dim commence As Integer
 
Sub lire
 
 
'chemin du répertoire
chemin = Workbooks(ActiveWorkbook.Name).Path
 
Set appPPoint = New PowerPoint.Application
 
'masquer màj de excel
Application.ScreenUpdating = False
 
'Récupération données pour 1er ppt
Sheets("ici").Select
Call Parcourir
 
'Récupération donnée pour 2° ppt
Sheets("là").Select
Call Parcourir
 
'Retour onglet "ici"
Sheets("ici").Select
 
appPPoint.Quit
 
'réactiver màj de excel
Application.ScreenUpdating = True
 
End Sub
 
Sub Parcourir()
 
chemin_final = chemin & "\" & ActiveSheet.Range("i1").Value & ".ppt"
 
    Set Presentation = appPPoint.Presentations.Open(chemin_final, withWindow:=msoFalse)
 
        commence = 3
    Do While ActiveSheet.Cells(commence, 2).Value <> ""
        For Each diapositive In Presentation.Slides 'parcourir les slides
            If diapositive.SlideNumber >= 4 Then
            Set forme = diapositive.Shapes
                For i = 1 To forme.Count  'parcourir les formes
                    If forme(i).HasTable = False Then
                        If forme(i).TextFrame.TextRange = ActiveSheet.Cells(commence, 2).Value Then
                            ActiveSheet.Cells(commence, 19).Value = "Oui"
                            Exit For
                        End If
                    Else
                    Exit For
                    End If
 
 
                Next
            End If
       Next
       commence = commence + 1
    Loop
 
Presentation.Close
 
 
End Sub

ce code là, pour certaines shape contenant un texte particulier me renvoit l'erreur:

Erreur d’exécution ‘-2147024809 (80070057)’ :
La valeur tapée est en dehors des limites

Un grand merci à celui qui me dépannera

[tiber33]

Bon alors j'ai trouvé la solution.

Sait on jamais si ça aide qqn par la suite.

La macro est qq peu différente, au lieu de lire dans les ppt, elle ramène tous les textes contenus dans les shapes des ppt, les colle dans excel.
Puis dans excel on regarde si les shapes sont en accord avec la base de données et on met un message en fonction de cette comparaison, ce pour chaque donnée de la base

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
Option Explicit
    Dim appPPoint As PowerPoint.Application
    Dim Presentation As PowerPoint.Presentation
    Dim diapositive As PowerPoint.Slide
    Dim forme As PowerPoint.Shapes
    Dim chemin, chemin_final, strCherche, strTrouve As String
    Dim numShapes, i As Long
    Dim commence, numTextShapes, f As Integer
    Dim shpTextArray() As Variant
    Dim oldstatusbar As Boolean
 
 
Sub Vérifs_shapes()
 
'activer barre d'attente
oldstatusbar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.StatusBar = "patientez"
 
'chemin du répertoire
chemin = Workbooks(ActiveWorkbook.Name).Path
 
Set appPPoint = New PowerPoint.Application
 
'masquer màj de excel
Application.ScreenUpdating = False
 
'appeler la sous-macro pour chaque onglet
    For k = 1 To 2  'de l'onglet 1 à 2...ou autre
        Sheets("test 0" & k).Select
        Call Parcourir
        Call Colorier
 
        Range("Q3:Q3000").Select  ' effacer les contenus des shapes ramenés ds excel
        Selection.ClearContents
 
    Next k
 
Sheets("Général").Select
 
appPPoint.Quit
 
'réactiver màj de excel
Application.ScreenUpdating = True
 
'fin barre d'attente
Application.StatusBar = False
Application.DisplayStatusBar = oldstatusbar
 
End Sub
 
___________________________
Sub Parcourir()  'récupérer les shapes des ppt, les coller en colonne q
 
 
chemin_final = chemin  & ActiveSheet.Range("M1").Value & ".ppt"  'en M1 ds chq onglet est rangé le nom du fichier ppt que va contenir l'onglet (sans le .ppt) à ouvrir, la partie variable de leur nom seulement donc
 
 
'travail dans powerpoint
    Set Presentation = appPPoint.Presentations.Open(chemin_final, withWindow:=msoFalse)
 
numTextShapes = 2
For Each diapositive In Presentation.Slides 'parcourir les slides
With diapositive.Shapes 'Récupérer tous les textes de toutes les shapes et les coller dans la colonne Q excel
    numShapes = .Count
    If numShapes > 1 Then
 
        ReDim shpTextArray(1 To 2, 1 To numShapes)
        For i = 1 To numShapes
            If .Item(i).HasTextFrame Then
                numTextShapes = numTextShapes + 1
                ActiveSheet.Cells(numTextShapes, 17).Value = .Item(i).TextFrame.TextRange.Text
            End If
        Next
        ReDim Preserve shpTextArray(1 To 2, 1 To numTextShapes)
    End If
End With
Next
 
Presentation.Close
 
End Sub
 
 
_______________
Sub Colorier()
 
'identifier  si les textes récupérés sont en accord avec la base de données
commence = 3
 
Do While ActiveSheet.Cells(commence, 2).Value <> ""  'tant que la cellule n'est pas vide
strCherche = ActiveSheet.Cells(commence, 2).Value  'assigner cette valeur à une variable
 
 
    Columns("Q:Q").Select  'chercher dans la colonne Q si les mesures colonnes B figurent
    On Error Resume Next
    Selection.Find(What:=strCherche, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
 
 
    If Not Selection.Find(What:=strCherche, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False) Is Nothing Then
        ActiveSheet.Cells(commence, 18).Value = "NON"  'si présente, écrire "NON"
        ActiveSheet.Cells(commence, 18).Interior.ColorIndex = 0  'fond blanc
        Else
        ActiveSheet.Cells(commence, 18).Value = strCherche  'sinon, écrire cette mesure dans la colonne R
        ActiveSheet.Cells(commence, 18).Interior.ColorIndex = 3  'fond rouge
 
    End If
    commence = commence + 1
Loop
 
End Sub