insertion image avec macro sans doublon lors de la réexécution

Version imprimable

Bonjour,

j'explique en quelques mots mon projet:

1: sur la première sheet, je voudrais insérer une image automatique par article avec prix, réf, ... que j'ajouterai moi-meme
2: ensuite par article j'aimerai faire une feuille automatique reprenant divers information pour une gestion des stocks

j'ai déjà réussi à insérer les images automatiquement mais comme il y aura sans doute de nouveaux articles, mon code insère de nouveau les meme photo déjà présente et donc je me retrouve avec deux photos superposées.

Serait-il possible de vérifier la présence de photo et intégrer seulement celles manquantes et par la meme occasion ajuster la largeur des cellules à celle de la photo la plus grande?

voici mon code pour la première partie insertion d'image sheet 1:
Code:

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 Sub insertion_image() Dim i As Integer, path As String, sep As String, img As String sep = Application.PathSeparator path = ActiveWorkbook.path & sep & "images" & sep ' balaye les xxx lignes For i = 1 To 15 ' indique à Excel où insérer l'image Cells(i, 2).Select ' insère une image jpg img = path & Cells(i, 1).Value & ".jpg" If Dir(img) = "" Then MsgBox "Image """ & img & """ non trouvée" Else ActiveSheet.Pictures.Insert(path & Cells(i, 1).Value & ".jpg").Select End If With Selection .ShapeRange.LockAspectRatio = msoFalse .ShapeRange.Height = 30# .ShapeRange.Width = 100# .ShapeRange.Rotation = 0# End With ' ajuste la hauteur de la ligne, avec une marge inférieure de 10 pts Rows(i).RowHeight = Selection.Height + 10 Selection.Top = Cells(i, 2).Top Selection.Left = Cells(i, 2).Left Next Columns(2).ColumnWidth = Selection.Width End Sub
Pour la seconde partie j'ai pas encore essayé mais j'espère régler le premier point avant.

Merci d'avance

Peut être en ajoutant en dernière colonne de la feuille un indicateur de présence de l'image lors de son insertion

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
For i = 1 To 15
    If Cells(i, Application.Columns.Count).Value = "" Then
        ' indique à Excel où insérer l'image
        Cells(i, 2).Select
        ' insère une image jpg
        img = path & Cells(i, 1).Value & ".jpg"
        If Dir(img) = "" Then
            MsgBox "Image """ & img & """ non trouvée"
        Else
            ActiveSheet.Pictures.Insert(path & Cells(i, 1).Value & ".jpg").Select
            Cells(i, Application.Columns.Count).Value = "X"
        End If
'...
   End If
Next i

bonjour,

alors, j'ai pas tout testé mais cela devrai ressembler à quelque chose du genre

Code:

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
Sub insertion_image()
Dim I As Integer, path As String, sep As String, IMG As String, IMG2 as String
Dim ImgSet As Shape, ShapeName As String
 
sep = Application.PathSeparator
path = ActiveWorkbook.path & sep & "images" & sep
 
' balaye les xxx lignes
For I = 1 To 15
    'test si image existe
    ShapeName=""
    IMG2 = I & " _" & Cells(I, 1).Text
    On Error Resume Next
        Set ImgSet = ActiveSheet.Shapes(IMG2)
        ShapeName = ImgSet.Name
    On Error GoTo 0
    If ShapeName = "" Then
        ' indique à Excel où insérer l'image
        Cells(I, 2).Select
 
        ' insère une image jpg
        IMG = path & Cells(i, 1).Value & ".jpg"
        If Dir(IMG) = "" Then
            MsgBox "Image """ & IMG & """ non trouvée"
        Else
            ActiveSheet.Pictures.Insert(IMG & ".jpg").Select
        'format shape
            With Selection
                .Name = I & " _" & Cells(I, 1).Text
                .ShapeRange.LockAspectRatio = msoFalse
                .ShapeRange.Height = 30#
                .ShapeRange.Width = 100#
                .ShapeRange.Rotation = 0#
            End With
        End If
 
        ' ajuste la hauteur de la ligne, avec une marge inférieure de 10 pts
        Rows(I).RowHeight = Selection.Height + 10
        Selection.Top = Cells(I, 2).Top
        Selection.Left = Cells(I, 2).Left
 
        'change la largeur pour le plus grand
        If Columns(2).ColumnWidth > Selection.Width Then Columns(2).ColumnWidth = Selection.Width
    End If
Next
 
 
End Sub

08/07/2010, 13h35
picogunsy

salut mayekeul,

j'ai testyé ta proposition et malheureusement il me met une erreur, je ne sais pas dire d'où ça vient et comme je suis vraiment débutant dans le VBA :s j'ai du mal à voir comment régler le problème :(

Donc quand je lance la macro, il m'ouvre une box avec le rond rouge et X blanc et il marque 400

c'est vraiment pas clair :-s

j'espère que tu pourras m'aider

merci d'avance
08/07/2010, 13h37
mayekeul

bonjour,

euh pas trop lol

tu peux me dire à quel moment il envoie ce message
tu as essayé en pas à pas (en lançant la macro avec F8)??

mercatog,

j'ai essayé de remplacer ta partie de code dans ce que j'avais fait et j'ai aussi des problèmes :s

excusé moi mais j'essaye de comprendre un peu toute cette programmation et j'ai un peu de mal.

donc j'ai essayé :

Code:

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
Sub j_espere_que_ca_marche()
    Dim i As Integer, path As String, sep As String, img As String
    sep = Application.PathSeparator
    path = ActiveWorkbook.path & sep & "images" & sep
' balaye les 700 lignes
For i = 1 To 15
    If Cells(i, Application.Columns.Count).Value = "" Then
        ' indique à Excel où insérer l'image
        Cells(i, 2).Select
        ' insère une image jpg
        img = path & Cells(i, 1).Value & ".jpg"
        If Dir(img) = "" Then
            MsgBox "Image """ & img & """ non trouvée"
        Else
            ActiveSheet.Pictures.Insert(path & Cells(i, 1).Value & ".jpg").Select
            Cells(i, Application.Columns.Count).Value = "X"
        End If
'...
   End If
Next i
 
With Selection
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 30#
.ShapeRange.Width = 100#
.ShapeRange.Rotation = 0#
End With
 
' ajuste la hauteur de la ligne, avec une marge inférieure de 10 pts
            Rows(i).RowHeight = Selection.Height + 10
    Selection.Top = Cells(i, 2).Top
Selection.Left = Cells(i, 2).Left
    Next
Columns(2).ColumnWidth = Selection.Width
 
End Sub

Conclusion pour le dernier next il me met une erreur de compilation, next sans for

merci d'avance

lorsque je fais pas à pas avec F8,

il passe chaque étape en surlignant en jaune et il me met une erreur juste après cette ligne:

ActiveSheet.Pictures.Insert(IMG & ".jpg").Select

Texte de l'erreur:

Citation:

erreur d'exécution 1004
erreur définie par l'application ou par l'objet.

essaye avec ceci

Code:

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
Sub j_espere_que_ca_marche()
Dim i As Long, path As String, sep As String, img As String
Dim sh As Worksheet
sep = Application.PathSeparator
path = ActiveWorkbook.path & sep & "images" & sep
 
' balaye les 700 lignes
For i = 1 To 15
    If Cells(i, Application.Columns.Count).Value = "" Then
        ' indique à Excel où insérer l'image
        Cells(i, 2).Select
        ' insère une image jpg
        img = path & Cells(i, 1).Value & ".jpg"
        If Dir(img) = "" Then
            MsgBox "Image """ & img & """ non trouvée"
        Else
            MettreImageDansCellule path & sep & Cells(i, 1) & ".jpg", i, 2
            Cells(i, Application.Columns.Count).Value = "X"
        End If
        '...
    End If
Next i
 
End Sub
 
Sub MettreImageDansCellule(NomImage As String, Ligne As Long, Colonne As Long)
'definir variable
Dim P As Object
Dim T As Double, TR As Double, TP As Double
Dim L As Double, LR As Double, LP As Double
Dim W As Double, WR As Double, WP As Double
Dim H As Double, HR As Double, HP As Double
 
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    If Dir(NomImage) = "" Then Exit Sub
    ' import picture
    Set P = ActiveSheet.Pictures.Insert(NomImage)
    ' determiner positions
    With P
        .Top = Rows(Ligne).Top + 5
        .Left = Columns(Colonne).Left
        .ShapeRange.LockAspectRatio = msoFalse
        .ShapeRange.Height = 30#
        .ShapeRange.Width = 100#
        .ShapeRange.Rotation = 0#
    End With
    'adapter largeur colonne
    If Columns(Colonne).ColumnWidth < P.Width Then Columns(Colonne).ColumnWidth = P.Width
    'adapter hauteur ligne
    Rows(Ligne).RowHeight = P.Height + 10
    Set P = Nothing
End Sub

08/07/2010, 15h24
picogunsy

je viens de tester, j'ai remis tout à zéro dans le fichier, supprimer toutes les images de la sheet et puis j'ai lancé la macro.

l'intégration des images se fait correctement mais la largeur des cellules s'agrandit fortement près du tripple de la largeur des images. :oops:

après ça j'ai effectué un petit test en ajoutant un articles et la tout va bien il intègre la photo sans doubler celle qui était présente. (grand merci :ccool::D)