Bonjour,

J'ai lu cette discussion.
Suis novice en VBA, ma macro fonctionne mais je n'arrive pas à la modifier afin que mes images soient sauvegardées avec le fichier (lien brisé).

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
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
Sub TestInsertPictureInRange()
 
Dim rep As String
 
'rep = InputBox "C:\Users\YESS\Documents\YESS\ECT\0-MATRICES"
 
rep = "C:\export_yess\thumbs"
 
 
If Len(rep) > 0 Then
 
    ActiveSheet.Pictures.Delete
 
    Dim i As Integer
 
    i = 11
 
    Dim est_fini As Boolean
    est_fini = False
 
    With Worksheets(1)
 
        Dim tmpref1 As String
 
        While Not est_fini
 
            tmpref1 = Trim(CStr(.Range("J" & i)))
 
            If Len(tmpref1) > 0 Then
 
 
                Dim tabfiles(4) As String
 
                tabfiles(1) = ".jpg"
                tabfiles(2) = ".bmp"
                tabfiles(3) = ".gif"
                tabfiles(4) = ".png"
 
                Dim trouve As Boolean
                trouve = 0
 
                Dim y As Integer
 
                Dim nomficimage1 As String
 
                nomficimage1 = ""
 
                y = 1
 
                While Not trouve And y <= 4
 
                    If Dir(rep + "\" + tmpref1 + tabfiles(y), vbNormal + vbHidden + vbReadOnly + vbSystem + vbArchive) <> "" Then
 
                        trouve = 1
 
                        nomficimage1 = rep + "\" + tmpref1 + tabfiles(y)
 
                    End If
 
                    y = y + 1
 
                Wend
 
                If trouve Then
 
                    InsertPictureInRange nomficimage1, Range("A" & i)
 
                End If
 
            Else
 
                est_fini = 1
 
            End If
 
 
            If i >= 3000 Then
 
                est_fini = 1
 
            End If
 
            i = i + 1
 
        Wend
 
 
    End With
 
 
End If
 
MsgBox "Import terminé"
 
 
End Sub
 
Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
 
Dim p As Object, t As Double, l As Double, w As Double, h As Double
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    If Dir(PictureFileName) = "" Then Exit Sub
 
    Set p = ActiveSheet.Pictures.Insert(PictureFileName)
 
    With TargetCells
        t = .Top
        l = .Left
        w = .Offset(0, .Columns.Count).Left - .Left
        h = .Offset(.Rows.Count, 0).Top - .Top
    End With
 
    Dim w1, w2, h1, h2, prcent1 As Single
 
    w1 = p.Width
    h1 = p.Height
 
    w2 = w
    h2 = h
 
    Dim prop As Single
 
    prop = (w / w1)
 
    If ((h1 * (prop)) > h) Then
 
        prop = (h / h1)
 
    End If
 
    w2 = w1 * prop
 
    h2 = h1 * prop
 
    With p
        .Top = t
        .Left = l
        .Width = w2
        .Height = h2
    End With
    Set p = Nothing
End Sub
Je suis donc en quete d'une bonne ame suceptible de m'aider :