Discussion :

[Louanne]

Bonjour à tous,

Je vous écris afin de vous demander votre aide !
Je cherche désespérément à créer une macro sur powerpoint afin d'insérer des images automatiquement dans une diapo sur laquelle un texte serait sélectionné.
Ce texte serait en fait une référence du type "086542" et je voudrais que en actionnant la macro : une image nommée "086542" soit insérée (elle est placée sur l'ordinateur dans un fichier type "P:\Direction Retail\CROQUIS\" )


J'ai réussi à faire cette macro sur excel et je voudrais en fait la même chose sur power point mais je n'y parviens pas...

Pourriez-vous m'aider ?

Je vous laisse ci-dessous le code de ma macro en EXCEL afin que vous vous rendiez compte de ce que j'aimerais faire à peu près.

J'espère que c'est bien expliqué sinon n'hésitez pas à me demander d'être plus claire


Merci par avance pour votre aide
Louanne.

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
 
Private AltRow As Single
 
Public Sub Sketches()
Dim sketchPath As String
Dim sketchExt As String
Dim i As Long
Dim hRel As Single, factor As Single
Dim strModPrec As String
Dim strFileName As String
Dim strDelSketchValue As String
Dim x As Range
Dim anyCode As Boolean
Dim SketchPhoto As Integer
 
anyCode = False
 
strSketchPath = "P:\Direction Retail\CROQUIS\"
strSketchExt = "jpg"
strDelSketchValue = "N"
 
    AltRow = 100
 
 
    On Error GoTo IsError
    If TypeOf Selection Is Range Then
        For Each x In Selection
            If Not IsEmpty(x.Value) Then
                If x = "0" Then x = "blank"
                AltRow = x.Width
                If x.Value <> sModPrec Then
                    strModPrec = x.Value
                    If Len(RTrim(x.Value)) >= 1 Then
                    SketchPhoto = 0
                        anyCode = True
 
                        strFileName = strSketchPath & RTrim(x.Value) & "." & strSketchExt
 
                        If (strDelSketchValue = "Y") Then
                            x.Value = ""
                        End If
 
                        ActiveSheet.Pictures.Insert(strFileName).Select
                    End If
 
 
 
                    If SketchPhoto > -1 Then
                        x.RowHeight = AltRow + x.Font.Size + 2
                        On Error GoTo IsError
 
                        factor = CSng(AltRow / Selection.ShapeRange.Height)
                        If factor > CSng(x.Width / Selection.ShapeRange.Width) Then
                            factor = CSng(x.Width / Selection.ShapeRange.Width)
                        End If
 
                            With Selection.ShapeRange
                            .LockAspectRatio = msoTrue 'conserver les proportions
                            .Height = x.Height - 4 'hauteur de l'image = hauteur des lignes - 4
                            .Top = x.Top
                            .Left = x.Left
                            End With
 
                    End If
                    On Error GoTo IsError
                End If
            End If
 
       Next
 
        If anyCode = False Then
            MsgBox "Please select a range that contains Style/StyleFabricColor codes", vbExclamation
        End If
 
 
    End If
    Exit Sub
 
IsError:
    If Err.Number = 1004 Then
    If SketchPhoto = 1 Then
    SketchPhoto = 0
    strFileName = strSketchPath & Left(RTrim(x.Value), 11) & "." & strSketchExt
    Resume
    Else
    SketchPhoto = -1
    Resume Next
    End If
Else
    MsgBox Err.Description, vbCritical
End If
End Sub

[Invité]

Bonjour,

Votre message est-il toujours d'actualité ?