Insertion image : Amélioration du code

Version imprimable

Bonjour à toutes et à tous.

J'ai besoin de votre aide pour améliorer le code que j'ai écrit. Je suis novice dans le VBA mais j'ai réussi à faire une macro qui fonctionne. Voici un extrait de mon code
Code:

1 2 3 4 5 6 7 8 9 10 11 Sub Orientation_MP_BP_auto() Sheets("02-Dimensions_ColdBox").Select 'basculer sur la 02-Dimensions ColdBox If Range("M12") = ("NORD PLOT") Then 'si en M12 = "Choix liste déroulante" alors Sheets("04-Graphic_ColdBox").Select 'on bascule sur la feuille "04-Graphic ColdBox" Range("B6").Select 'on se positionne en B6 ActiveSheet.Pictures.Insert( _ "F:\Dev macro\Dev - Images BF\0 PLOT NORD.GIF" _ ).Select 'on colle l'image situé dans le répertoire désigné End If End Sub
Le problème s'est que ce n'est qu'un tout petit bout de la macro, cette condition va se répéter de très nombreuses fois avec des critéres différents et des images différentes, mais l'emplacement sera toujours le même.

Pour éviter de devoir recopier plusieurs fois le même chemin d'accès, et mettre à jour celui ci plus rapidement, j'ai essayé de définir le chemin de cette manière
Code:

1 2 3 4 5 Option Explicit Const LettreRessource = "F:\" Const Répertoire_cible As String = LettreRessource _ & "Dev macro\Dev - Images BF\"
Malheureusement je n'arrive pas à intégrer la référence Répertoire_cible dans ma macro :cry:

Pouvez-vous me donner un petit coup de pouce?

Par avance, merci de votre aide

Salut,
Je ne suis pas sûr d'avoir bien compris ton problème, mais j'ai un problème d'insertion d'image également il y a quelque temps e ton m'a donné ça:

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
Sub insertion()
 
 
           Dim Emplacement As Range
           Dim Img As Object
           Dim ShapeObj As Shape
 
           'Boucle pour supprimer l'ancienne image
           For Each ShapeObj In ActiveSheet.Shapes
               If ShapeObj.Name = "Cible" Then ActiveSheet.Shapes("Cible").Delete
           Next ShapeObj
 
           If Application.Dialogs(xlDialogInsertPicture).Show Then
               'Définit l'emplacement de l'image
               Set Emplacement = Range("A10:T54")
 
               Set Img = ActiveSheet.DrawingObjects(ActiveSheet.Shapes.Count)
 
               With Img.ShapeRange
                   'Nommer l'image insérée (Pour la supprimer plus facilement ensuite)
                   .Name = "Cible"
                   .LockAspectRatio = msoFalse
                   .Left = Emplacement.Left
                   .Top = Emplacement.Top
                   .Height = Emplacement.Height
                   '.Width = Emplacement.Width
               End With
 
           Else
               MsgBox "Insertion d'image interrompue."
           End If
 
End Sub

Avec cette macro, tu peux aller choisir l'image que tu souhaite sur ton disque dur, et lui définir un emplacement. Tu peux aussi choisir de forcer l'image à s'adapter à l'emplacement, ce qui la déformerait, ou de garder les bonnes proportions en modifiant .LockAspectRatio = msoFalse pour .LockAspectRatio = msoTrue

05/07/2012, 17h49
Laura-c

Je te remercie, mais ce n'est pas vraiment ce que je recherche. ;)

La macro pour insérer les images fonctionnes sauf que pour le moment je dois tout le temps indiquer le chemin exact du dossier dans lequel se trouve les images. Pour le moment les documents sont sur le disque F:\...\... mais dans le futur ils seront sur un disque T:\...\... et pour éviter de modifier toute la macro manuellement au risque de faire des erreurs je souhaite indiquer au tout début de la macro le nom du disque et le chemin d'accès. Jusque là je crois que j'y arrive, sauf que je n'arrive pas à ensuite y faire référence dans la macro.

Bonjour,

Tu peux faire comme ceci :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub Orientation_MP_BP_auto()
Dim Lecteur As String, Repertoire As String, NomImg As String
 
Lecteur = "F:\"
Repertoire = "Dev macro\Dev - Images BF\"
NomImg = "0 PLOT NORD.GIF"
 
Sheets("02-Dimensions_ColdBox").Select 'basculer sur la 02-Dimensions ColdBox
    If Range("M12") = ("NORD PLOT") Then 'si en M12 = "Choix liste déroulante" alors
    Sheets("04-Graphic_ColdBox").Select 'on bascule sur la feuille "04-Graphic ColdBox"
    Range("B6").Select 'on se positionne en B6
    ActiveSheet.Pictures.Insert(Lecteur & Repertoire & NomImg).Select 'on colle l'image situé dans le répertoire désigné
    End If
End Sub

Par contre j'écrirais plutôt le code comme 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
Sub Orientation_MP_BP_auto()
Dim Lecteur As String, Repertoire As String, NomImg As String
Dim Img As Object
 
Lecteur = "F:\"
Repertoire = "Dev macro\Dev - Images BF\"
NomImg = "0 PLOT NORD.GIF"
 
If Sheets("02-Dimensions_ColdBox").Range("M12") = "NORD PLOT" Then
    With Sheets("04-Graphic_ColdBox")
        Set Img = .Pictures.Insert(Lecteur & Repertoire & NomImg)
        With .Range("B6")
            Img.Left = .Left '<-- alignement gauche de l'image sur la cellule B6
            Img.Top = .Top '<-- alignement haut de l'image sur la cellule B6
            'd'autres paramètres possibles
            'Img.Height = 50 '<-- hauteur de l'image
            'Img.Width = 50 '<-- largeur de l'image
            'Img.Name = "Mon_Image" '<-- nom de l'objet image
        End With
    End With
End If
 
Set Img = Nothing
 
End Sub

Fring je te remercie pour ton aide, ça fonctionne parfaitement :)

J'ai choisi la première solution car elle me semble plus simple vu mon niveau, et je n'ai pas besoin de déterminer les dimensions des images car elles font toutes les mêmes.

Voici donc un bout de la macro. Il ne me reste plus qu'à appliquer la même chose pour tous les autres critéres...

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
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
Sub Procédure_principale() ' Procédure principale
'
' variables locales
'
Dim time0, time1, time2  As String ' controle du temps d execution
 
 
time0 = " Début du traitement des données importées " + CStr(Time)
 
'
Call Suppression_image ' suppression des images dans la feuille 04-Graphic_ColdBox
time1 = " Suppression des images dans l'onglet 04-Graphic_ColdBox -> " + CStr(Time)
'
 
Call Orientation_MP_BP_auto   ' import des images de l'orientation pour la MP BP
time2 = " Fin de l'import dans l'onglet 04-Graphic_ColdBox -> " + CStr(Time)
 
'
End Sub
 
 
Sub Suppression_image()
 
  ActiveSheet.Unprotect
  Sheets("04-Graphic_ColdBox").Pictures.Delete 'Supprime les images dans la feuille "04-Graphic ColdBox"
 
 
End Sub
 
Sub Orientation_MP_BP_auto()
Dim Lecteur As String, Repertoire As String, NomImg As String
 
Lecteur = "F:\"
Repertoire = "Dev macro\Dev - Images BF\"
 
 
NomImg = "0 PLOT NORD.GIF"
 
Sheets("02-Dimensions_ColdBox").Select 'basculer sur la 02-Dimensions ColdBox
  If Range("M12") = ("NORD PLOT") Then 'si en M12 = "Choix liste déroulante" alors
  Sheets("04-Graphic_ColdBox").Select 'on bascule sur la feuille "04-Graphic ColdBox"
  Range("B6").Select 'on se positionne en B6  ChDir Répertoire_cible 'Sélection du répertoire
  ActiveSheet.Pictures.Insert(Lecteur & Repertoire & NomImg).Select 'on colle l'image situé dans le répertoire désigné
  End If
 
 
NomImg = "0 PLOT EST.GIF"
 
Sheets("02-Dimensions_ColdBox").Select 'basculer sur la 02-Dimensions ColdBox
  If Range("M12") = ("EST PLOT") Then 'si en M12 = "Choix liste déroulante" alors
  Sheets("04-Graphic_ColdBox").Select 'on bascule sur la feuille "04-Graphic ColdBox"
  Range("B6").Select 'on se positionne en B6
  ActiveSheet.Pictures.Insert(Lecteur & Repertoire & NomImg).Select 'on colle l'image situé dans le répertoire désigné
  End If
 
 
NomImg = "0 PLOT SUD.GIF"
 
Sheets("02-Dimensions_ColdBox").Select 'basculer sur la 02-Dimensions ColdBox
  If Range("M12") = ("SUD PLOT") Then 'si en M12 = "Choix liste déroulante" alors
  Sheets("04-Graphic_ColdBox").Select 'on bascule sur la feuille "04-Graphic ColdBox"
  Range("B6").Select 'on se positionne en B6
  ActiveSheet.Pictures.Insert(Lecteur & Repertoire & NomImg).Select 'on colle l'image situé dans le répertoire désigné
  End If
 
 
NomImg = "0 PLOT OUEST.GIF"
 
  Sheets("02-Dimensions_ColdBox").Select 'basculer sur la 02-Dimensions ColdBox
  If Range("M12") = ("OUEST PLOT") Then 'si en M12 = "Choix liste déroulante" alors
  Sheets("04-Graphic_ColdBox").Select 'on bascule sur la feuille "04-Graphic ColdBox"
  Range("B6").Select 'on se positionne en B6
  ActiveSheet.Pictures.Insert(Lecteur & Repertoire & NomImg).Select 'on colle l'image situé dans le répertoire désigné
  End If
 
End Sub

J'ai de nouveau besoin de votre aide. Je croyais m'en sortir mais excel me fait des misères et ça commence à me rendre dingue :aie:

Voici des nouveaux morceaux de ma macro, je ne vous mets pas tout car je fais référence à 35 images avec de nombreux intervalles. Le code Tuyau_WN fonctionne. J'ai donc décidé de le copier et de l'adapter pour Tuyau_LPGAN. Et s'est là où je craque. Quand je lance ma procédure principale elle exécute correctement Sub Tuyau_WN mais pas la Sub Tuyau_LPGAN. Elle me récupére la première image au lieu de celle à laquelle je fais référence. Et vu que ça fonctionne je n'ai pas de message d'erreur...

Est ce que ça peut être dû au fait que j'ai trop de critère? Si s'est ça, normalement ce n'est que le début de la macro...

Si vous avez une astuce pour diminuer le nombre de ligne je suis preneuse

Code Tuyau_WN

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
53
54
55
56
57
Sub Tuyau_WN()
Dim Lecteur As String, Repertoire As String, NomImg As String
Dim Tuyau_WN As Integer
    Tuyau_WN = Range("M20")
 
Lecteur = "F:\"
Repertoire = "Dev macro\Dev - Images BF\"
 
NomImg0 = "2 PIPE 00°.GIF"
NomImg1 = "2 PIPE 10°.GIF"
NomImg2 = "2 PIPE 20°.GIF"
NomImg3 = "2 PIPE 30°.GIF"
NomImg4 = "2 PIPE 40°.GIF"
NomImg5 = "2 PIPE 50°.GIF"
NomImg6 = "2 PIPE 60°.GIF"
 
Sheets("02-Dimensions_ColdBox").Select 'basculer sur la 02-Dimensions ColdBox
  Select Case Tuyau_WN
 
  Case 0 To 5  'si en M20 est compris entre 0 et 5 alors
    Sheets("04-Graphic_ColdBox").Select 'on bascule sur la feuille "04-Graphic ColdBox"
    Range("B6").Select 'on se positionne en B6  ChDir Répertoire_cible 'Sélection du répertoire
    ActiveSheet.Pictures.Insert(Lecteur & Repertoire & NomImg0).Select 'on colle l'image situé dans le répertoire désigné
 
  Case 6 To 15  'si en M20 est compris entre 6 et 10 alors
    Sheets("04-Graphic_ColdBox").Select 'on bascule sur la feuille "04-Graphic ColdBox"
    Range("B6").Select 'on se positionne en B6  ChDir Répertoire_cible 'Sélection du répertoire
    ActiveSheet.Pictures.Insert(Lecteur & Repertoire & NomImg1).Select
 
 Case 16 To 25
    Sheets("04-Graphic_ColdBox").Select
    Range("B6").Select
    ActiveSheet.Pictures.Insert(Lecteur & Repertoire & NomImg2).Select
 
 Case 26 To 35
    Sheets("04-Graphic_ColdBox").Select
    Range("B6").Select
    ActiveSheet.Pictures.Insert(Lecteur & Repertoire & NomImg3).Select
 
 Case 36 To 45
    Sheets("04-Graphic_ColdBox").Select
    Range("B6").Select
    ActiveSheet.Pictures.Insert(Lecteur & Repertoire & NomImg4).Select
 
 Case 46 To 55
    Sheets("04-Graphic_ColdBox").Select
    Range("B6").Select
    ActiveSheet.Pictures.Insert(Lecteur & Repertoire & NomImg5).Select
 
 Case 56 To 65
    Sheets("04-Graphic_ColdBox").Select
    Range("B6").Select
    ActiveSheet.Pictures.Insert(Lecteur & Repertoire & NomImg6).Select
 
  End Select
 
End Sub

Code Tuyau_LPGAN

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
53
54
55
56
57
Sub Tuyau_LPGAN()
Dim Lecteur As String, Repertoire As String, NomImg As String
Dim Tuyau_LPGANAs Integer
    Tuyau_LPGAN= Range("M21")
 
Lecteur = "F:\"
Repertoire = "Dev macro\Dev - Images BF\"
 
NomImg0 = "2 PIPE 00°.GIF"
NomImg1 = "2 PIPE 10°.GIF"
NomImg2 = "2 PIPE 20°.GIF"
NomImg3 = "2 PIPE 30°.GIF"
NomImg4 = "2 PIPE 40°.GIF"
NomImg5 = "2 PIPE 50°.GIF"
NomImg6 = "2 PIPE 60°.GIF"
 
Sheets("02-Dimensions_ColdBox").Select 'basculer sur la 02-Dimensions ColdBox
  Select Case Tuyau_LPGAN
 
  Case 0 To 5  'si en M20 est compris entre 0 et 5 alors
    Sheets("04-Graphic_ColdBox").Select 'on bascule sur la feuille "04-Graphic ColdBox"
    Range("B6").Select 'on se positionne en B6  ChDir Répertoire_cible 'Sélection du répertoire
    ActiveSheet.Pictures.Insert(Lecteur & Repertoire & NomImg0).Select 'on colle l'image situé dans le répertoire désigné
 
  Case 6 To 15  'si en M20 est compris entre 6 et 10 alors
    Sheets("04-Graphic_ColdBox").Select 'on bascule sur la feuille "04-Graphic ColdBox"
    Range("B6").Select 'on se positionne en B6  ChDir Répertoire_cible 'Sélection du répertoire
    ActiveSheet.Pictures.Insert(Lecteur & Repertoire & NomImg1).Select
 
 Case 16 To 25
    Sheets("04-Graphic_ColdBox").Select
    Range("B6").Select
    ActiveSheet.Pictures.Insert(Lecteur & Repertoire & NomImg2).Select
 
 Case 26 To 35
    Sheets("04-Graphic_ColdBox").Select
    Range("B6").Select
    ActiveSheet.Pictures.Insert(Lecteur & Repertoire & NomImg3).Select
 
 Case 36 To 45
    Sheets("04-Graphic_ColdBox").Select
    Range("B6").Select
    ActiveSheet.Pictures.Insert(Lecteur & Repertoire & NomImg4).Select
 
 Case 46 To 55
    Sheets("04-Graphic_ColdBox").Select
    Range("B6").Select
    ActiveSheet.Pictures.Insert(Lecteur & Repertoire & NomImg5).Select
 
 Case 56 To 65
    Sheets("04-Graphic_ColdBox").Select
    Range("B6").Select
    ActiveSheet.Pictures.Insert(Lecteur & Repertoire & NomImg6).Select
 
  End Select
 
End Sub

merci de votre aide

Tu obtiens la même image parce que tes deux codes sont identiques.
Si M20 est compris entre 0 et 5 tu insères l'image "2 PIPE 00°.GIF" et si M21 est compris entre 0 et 5 tu insères la même image (idem pour les autres conditions), c'est normal ?

Autre chose, sélectionner la cellule B6 ne sert à rien parce que avec Pictures.Insert l'image sera toujours positionnée au même endroit que tu sélectionnes B6, F35 ou Z175... Pour positionner l'image à un endroit bien précis tu devras utiliser le second code que je te proposais.

Vu que tes variables sont identiques pour chaque macro, tu peux les déclarer une seule fois en début de module (avant les macros) et elles pourront être utilisées dans chaque macro.

Evite de nommer tes variables avec exactement les mêmes noms que tes macros

En clair, ça donne 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
53
54
55
56
Public Const NomImg0 As String = "2 PIPE 00°.GIF"
Public Const NomImg1 As String = "2 PIPE 10°.GIF"
Public Const NomImg2 As String = "2 PIPE 20°.GIF"
Public Const NomImg3 As String = "2 PIPE 30°.GIF"
Public Const NomImg4 As String = "2 PIPE 40°.GIF"
Public Const NomImg5 As String = "2 PIPE 50°.GIF"
Public Const NomImg6 As String = "2 PIPE 60°.GIF"
Public Const Lecteur As String = "F:\"
Public Const Repertoire As String = "Dev macro\Dev - Images BF\"
Public Img As Object, L As Long, T As Long
 
'***************************************************************************
 
Sub Tuyau_WN()
Dim Tuy_WN As Integer
 
Tuy_WN = Sheets("02-Dimensions_ColdBox").Range("M20")
 
With Sheets("04-Graphic_ColdBox")
    L = .Range("B6").Left
    T = .Range("B6").Top
    Select Case Tuy_WN
        Case 0 To 5: Set Img = .Pictures.Insert(Lecteur & Repertoire & NomImg0): Img.Left = L: Img.Top = T
        Case 6 To 15: Set Img = .Pictures.Insert(Lecteur & Repertoire & NomImg1): Img.Left = L: Img.Top = T
        Case 16 To 25: Set Img = .Pictures.Insert(Lecteur & Repertoire & NomImg2): Img.Left = L: Img.Top = T
        Case 26 To 35: Set Img = .Pictures.Insert(Lecteur & Repertoire & NomImg3): Img.Left = L: Img.Top = T
        Case 36 To 45: Set Img = .Pictures.Insert(Lecteur & Repertoire & NomImg4): Img.Left = L: Img.Top = T
        Case 46 To 55: Set Img = .Pictures.Insert(Lecteur & Repertoire & NomImg5): Img.Left = L: Img.Top = T
        Case 56 To 65: Set Img = .Pictures.Insert(Lecteur & Repertoire & NomImg6): Img.Left = L: Img.Top = T
    End Select
End With
 
End Sub
 
'***************************************************************************
 
Sub Tuyau_LPGAN()
Dim Tuy_LPGAN As Integer
 
Tuy_LPGAN = Sheets("02-Dimensions_ColdBox").Range("M21")
 
With Sheets("04-Graphic_ColdBox")
    L = .Range("B6").Left
    T = .Range("B6").Top
    Select Case Tuy_LPGAN 
        Case 0 To 5: Set Img = .Pictures.Insert(Lecteur & Repertoire & NomImg0): Img.Left = L: Img.Top = T
        Case 6 To 15: Set Img = .Pictures.Insert(Lecteur & Repertoire & NomImg1): Img.Left = L: Img.Top = T
        Case 16 To 25: Set Img = .Pictures.Insert(Lecteur & Repertoire & NomImg2): Img.Left = L: Img.Top = T
        Case 26 To 35: Set Img = .Pictures.Insert(Lecteur & Repertoire & NomImg3): Img.Left = L: Img.Top = T
        Case 36 To 45: Set Img = .Pictures.Insert(Lecteur & Repertoire & NomImg4): Img.Left = L: Img.Top = T
        Case 46 To 55: Set Img = .Pictures.Insert(Lecteur & Repertoire & NomImg5): Img.Left = L: Img.Top = T
        Case 56 To 65: Set Img = .Pictures.Insert(Lecteur & Repertoire & NomImg6): Img.Left = L: Img.Top = T
    End Select
End With
 
End Sub

06/07/2012, 21h37
Laura-c

Citation:

Tu obtiens la même image parce que tes deux codes sont identiques.
Si M20 est compris entre 0 et 5 tu insères l'image "2 PIPE 00°.GIF" et si M21 est compris entre 0 et 5 tu insères la même image (idem pour les autres conditions), c'est normal ?

Oui c'est normal pour cette partie, pour la suite les images seront différentes.

J'ai récupéré ton code qui est nettement plus lisible que le miens et il fonctionne parfaitement. Merci :ccool: