macro insertions images et redimensionnement

Version imprimable

1 pièce(s) jointe(s)

Bonjour à tous !:mrgreen:
Voici ce que je voudrais faire : Je dois générer des "fiches d'identité" de différents éléments de réseaux d'eau usée et potable. La fiche type est déjà prête.
Pour le moment, mon fichier excel comporte deux feuilles : "base de données" et "EU (1)"
la "base de données" contient tous les renseignements relatif à chaque élément du réseau, y compris une case pour le suffixe de la photo, et son numéro (exemple : suffixe DSCF et numéro de photo 003). Pour le moment, j'ai crée un spinbouton qui permet de remplir toute la fiche EU (1) à partir des éléments de base de donnée, en fonction du numéro de l'élément (simple copie de case à case).
Maintenant, ce que je voudrais faire, c'est aller chercher la photo correspondant à l'élément du réseau, l'insérer au bon endroit dans la fiche EU, et redimensionner la photo de façon à ce qu'elle rentre dans l'espace prévu, quelle que soit sa taille ou son orientation, en conservant ses proportions d'origine. Pour le moment, j'ai bricolé ç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 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 Private Sub SpinButton1_Change() Dim Image As Variant 'variable "nom du fichier" Dim sh As Shape ' variable pour image à effacer Dim L, T, W, H As Single 'futures dimensions de l'image Dim R, C, P As String ' variables "numéro de photo" ActiveSheet.[A20].Select 'sélection de la cellule cible dans EU (1) 'sélection de la cellule cible L = 15 ' ActiveCell.Left T = ActiveCell.Top W = 210 H = 210 For Each sh In ActiveSheet.Shapes ' Boucle d'effacement de l'image précédente If Not Intersect(Range(sh.TopLeftCell.Address), Range("A20:D33")) Is Nothing Or _ Not Intersect(Range(sh.BottomRightCell.Address), Range("A20:D33")) Is Nothing Then sh.Delete End If Next sh R = ActiveSheet.[H6].Value * 8 - 5 'prend le numéro de l'élément défini par le spinbouton et ajoute 8 lignes correspondantes aux informations de chaque élément sur la feuille "base de données" P = Sheets("Base de données").Cells(R, 14).Value 'numéro de la photo dans la feuille base de données Set suffixe = Sheets("Base de données").Cells(R, 13).Value 'là, j'ai un problème... If Sheets("Base de données").Cells(R, 14).Value = "" Then 'si pas de photo ' il faudrait sortir de la macro... Else Image = Application.ActiveWorkbook.Path + "\photos\" + suffixe + P + ".JPG" 'select° photo If Image <> False Then 'si taille photo différente de cellule ActiveSheet.Shapes.AddPicture Image, True, True, L, T, W, H 'redimensionne End If End If 'Insertion du radiant Sheets("Base de données").Select ActiveSheet.Shapes("Groupe 2").Select Selection.Copy Sheets("EU (1)").Select Range("A20 : D33").Select ActiveSheet.Paste Selection.ShapeRange.IncrementLeft 15 Selection.ShapeRange.IncrementTop 9.75 'générer la fiche dans une nouvelle feuille et passer à la suivante Sheets("EU (1)").Select Sheets("EU (1)").Copy After:=Sheets(2) 'il manque une boucle pour passer à l'élément n°2 End Sub
Donc mon gros problème, c'est que les suffixes DSCF etc... ne sont pas toujours les même et le nombre d'élément est parfois trop important pour renommer une à une les photos. Je voudrais que la macro trouve la photo à partir du suffixe défini dans la case R,13 de "base de données", de son numéro en R,14, ensuite qu'elle l'insère dans EU, garde les proportions et la redimensionne (sachant que dans mon code, je fixe les dimensions au départ, et ça déforme la photo; ce n'est pas ce que je voudrais).
Ensuite, il faudrait que la fiche ainsi crée soit copier en une nouvelle feuille en dernier, et on passe à l'élément 2, et ainsi de suite jusqu'à ce qu'il n'y ait plus de numéro d'élément.
pouvez-vous m'aider à réparer/modifier cette macro ? Je vous en remercie beaucoup par avance.:P
Cordialement

PS : je l'ai créer sous Excel 2003 car :
c'est celui que j'ai chez moi !
Plus facile d'accéder au VBA et aux macros (en tout cas pour moi)
Par contre, au boulot, c'est Office 2007 (pb de compatibilité ?).

Bonjour
Utilise plutôt un contrôle activeX Image sur ta feuille EU(1) (Qui prend en charge le zoom sans distortion) et adapte ce code sur le spinbutton

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
Private Sub SpinButton1_Change()
Dim Chemin As String, FichierImage As String, Suffixe As String, P As String
Dim R As Integer
 
Application.ScreenUpdating = False
With Sheets("EU (1)")
    R = .Range("H6").Value * 8 - 5
    If R > 0 Then
        .Image1.Picture = LoadPicture("")
        P = Sheets("Base de données").Cells(R, 14).Value
        Suffixe = Sheets("Base de données").Cells(R, 13).Value
        If P <> "" Then
            On Error Resume Next
            Application.DisplayAlerts = False
            Sheets(Suffixe & P).Delete
            Application.DisplayAlerts = True
            On Error GoTo 0
            Chemin = ThisWorkbook.Path & "\photos\"
            FichierImage = Suffixe & P & ".JPG"
            If Dir(Chemin & FichierImage) <> "" Then
                .Image1.Picture = LoadPicture(Chemin & FichierImage)
                .Image1.PictureSizeMode = 3
                .Copy After:=Worksheets(Worksheets.Count)
                Worksheets(Worksheets.Count).Name = Suffixe & P
                .Activate
            End If
        End If
    End If
End With
End Sub

Merci beaucoup pour la rapidité de la réponse.:D

Par rapport à la solution proposé, j'ai copié le code, mais il bug au niveau de cette ligne :

Code:

1
2
 
.Image1.Picture = LoadPicture("")

Il me dit "propriété ou méthode non géré par cet objet". Est-ce que ça vient du fait que Image1 n'existe pas dans la page (vu le nombre d'essai que j'ai fait, la prochaine image inséré sera peut-être la 250e !)
Question : une donnée définie comme string peut-elle stoker du texte (en l'occurrence, le suffixe)?

Par ailleurs, j'avoue ne connaître l'activeX que de nom uniquement (je n'ai aucune idée de ce que c'est ou de son fonctionnement).

Comment faire ?

Cordialement.

voici le code que j'ai ré-adapté :

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
77
78
79
80
 
Private Sub SpinButton1_Change()
Dim Image As Variant 'variable "nom du fichier"
Dim sh As Shape ' variable pour image à effacer
Dim L, T, W, H As Single 'futures dimensions de l'image
' variables "numéro de photo"
Dim Chemin As String, FichierImage As String, Suffixe As String, P As String
Dim R As Integer
 
ActiveSheet.[A20].Select 'sélection de la cellule cible dans EU (1)
 
'sélection de la cellule cible
'L = 15 ' ActiveCell.Left
'T = ActiveCell.Top
'W = 210
'H = 210
 
For Each sh In ActiveSheet.Shapes ' Boucle d'effacement de l'image précédente
If Not Intersect(Range(sh.TopLeftCell.Address), Range("A20 : D33")) Is Nothing Or _
Not Intersect(Range(sh.BottomRightCell.Address), Range("A20 : D33")) Is Nothing Then
sh.Delete
End If
Next sh
 
 
Application.ScreenUpdating = False
With Sheets("EU (1)")
    R = .Range("H6").Value * 8 - 5
    If R > 0 Then
        .Image1.Picture = LoadPicture("")
        P = Sheets("Base de données").Cells(R, 14).Value
        Suffixe = Sheets("Base de données").Cells(R, 13).Value
        If P <> "" Then
            On Error Resume Next
'            Application.DisplayAlerts = False
'            Sheets(Suffixe & P).Delete
'            Application.DisplayAlerts = True
'            On Error GoTo 0
            Chemin = ThisWorkbook.Path & "\photos\"
            FichierImage = Suffixe & P & ".JPG"
            If Dir(Chemin & FichierImage) <> "" Then
                .Image1.Picture = LoadPicture(Chemin & FichierImage)
                .Image1.PictureSizeMode = 3
                .Copy After:=Worksheets(Worksheets.Count)
                Worksheets(Worksheets.Count).Name = Suffixe & P
                .Activate
            End If
        End If
    End If
End With
 
 
'R = ActiveSheet.[H6].Value * 8 - 5 'prend le numéro de l'élément défini par le spinbouton et ajoute 8 lignes correspondantes aux informations de chaque élément sur la feuille "base de données"
'P = Sheets("Base de données").Cells(R, 14).Value 'numéro de la photo dans la feuille base de données
'Set Suffixe = Sheets("Base de données").Cells(R, 13).Value 'là, j'ai un problème...
'If Sheets("Base de données").Cells(R, 14).Value = "" Then 'si pas de photo
' il faudrait sortir de la macro...
'Else
'Image = Application.ActiveWorkbook.Path + "\photos\" + Suffixe + P + ".JPG" 'select° photo
 
'If Image <> False Then 'si taille photo différente de cellule
'ActiveSheet.Shapes.AddPicture Image, True, True, L, T, W, H 'redimensionne
'End If
 
'End If
'Insertion du radiant
Sheets("Base de données").Select
ActiveSheet.Shapes("Groupe 2").Select
Selection.Copy
Sheets("EU (1)").Select
Range("A20 : D33").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 15
Selection.ShapeRange.IncrementTop 9.75
 
'générer la fiche dans une nouvelle feuille et passer à la suivante
Sheets("EU (1)").Select
Sheets("EU (1)").Copy After:=Sheets(2)
'il manque une boucle pour passer à l'élément n°2
End Sub

Sauf qu'il bug sur le :

Code:

.Image1.Picture = LoadPicture("")

Merci de votre aide.

Non, peut être je n'étais pas assez clair
Sur ta feuille EU (1), tu insère un contrôle ActiveX Image (c'est comme l'insertion de ta spinbutton)
Ce contrôle est nommé Image1
Tu le place manuellement là où tu veux sur ta feuille EU (1)
Tu peux même régler les propriétés BackStyle et BorderStyle à transparent

Le code fourni permet de remplir Image1 par l'image choisie par son suffixe et n°

C-joint, code amélioré (sur Change de ta spinbutton)
J'ai considéré que le nom du fichier image et de type SuffixeNum.jpg (avec Suffixe: texte et Num nombre à 3 chiffre 001, 002...999)

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
Private Sub SpinButton1_Change()
Dim Chemin As String, FichierImage As String, SufImg As String, NumImg As String
Dim Lig As Integer
 
Application.ScreenUpdating = False
With Sheets("EU (1)")
    Lig = .Range("H6").Value * 8 - 5
    If Lig > 0 Then
        .Image1.Picture = LoadPicture("")
        With Sheets("Base de données")
            SufImg = .Range("M" & Lig).Value
            NumImg = CStr(Format(.Range("N" & Lig).Value, "000"))
        End With
        If NumImg <> "" Then
            On Error Resume Next
            Application.DisplayAlerts = False
            Sheets(SufImg & NumImg).Delete
            Application.DisplayAlerts = True
            On Error GoTo 0
            Chemin = ThisWorkbook.Path & "\photos\"
            FichierImage = SufImg & NumImg & ".JPG"
            If Dir(Chemin & FichierImage) <> "" Then
                .Image1.Picture = LoadPicture(Chemin & FichierImage)
                .Image1.PictureSizeMode = 3
                .Copy After:=Worksheets(Worksheets.Count)
                Worksheets(Worksheets.Count).Name = SufImg & NumImg
                Sheets(SufImg & NumImg).Shapes("SpinButton1").Delete
                .Activate
            End If
        End If
    End If
End With
End Sub

Edit: String = Chaine de caractères, c'est à dire texte

Ca marche !!

Merci beaucoup pour toutes ces précisions ! Je n'avais pas compris ce qu'était un activeX. Je l'ai intégré, j'ai fait des modifications mineurs et ça fonctionne parfaitement !
Un grand merci pour ton aide !!
voici le code :

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
Private Sub CommandButton1_Click()
Dim Image As Variant 'variable "nom du fichier"
Dim sh As Shape ' variable pour image à effacer
 
' variables "numéro de photo"
Dim Chemin As String, FichierImage As String, SufImg As String, NumImg As String, P As String, NSheets As String
'NSheets pour le nom de la nouvelle feuille générée à la fin
 
Dim Lig As Integer
Dim R As Integer, compteur As Integer
 
compteur = 1 ' afin de générer en boucle toutes les fiches
Sheets("EU (1)").Select
For compteur = 1 To 10 'à modifier plus tard pour définir le nombre de fiches à générer
 
Sheets("EU (1)").Select
ActiveSheet.[H6].Value = compteur
 
Application.ScreenUpdating = False
With Sheets("EU (1)")
    Lig = .Range("H6").Value * 8 - 5 ' 8 lignes d'informations et 3 lignes de titres au début d'où : numéro de fiche x 8 -5
    If Lig > 0 Then
        .Image1.Picture = LoadPicture("")
        With Sheets("Base de données")
            SufImg = .Range("M" & Lig).Value
            NumImg = CStr(Format(.Range("N" & Lig).Value, "000"))
        End With
        If NumImg <> "" Then
            On Error Resume Next
            Application.DisplayAlerts = False
            Sheets(SufImg & NumImg).Delete
            Application.DisplayAlerts = True
            On Error GoTo 0
            Chemin = ThisWorkbook.Path & "\photos\"
            FichierImage = SufImg & NumImg & ".JPG"
            If Dir(Chemin & FichierImage) <> "" Then
                .Image1.Picture = LoadPicture(Chemin & FichierImage)
                .Image1.PictureSizeMode = 3
                .Copy After:=Worksheets(Worksheets.Count)
                Worksheets(Worksheets.Count).Name = "EU " & compteur 'on renomme la nouvelle fiche en "EU 2" ou 3 etc... au fur et à mesure du compteur
                Sheets("EU " & compteur).Shapes("CommandButton1").Delete ' pour faire plus joli !!
                .Activate
            End If
        End If
    End If
End With
 
Next
 
End Sub

Ca fonctionne pour n'importe quel suffixe. Pour les numéros de photo, je n'ai pas vérifié au dessus de 009, mais je suppose que ça marche.
Maintenant, je vais plancher sur le fait d'avoir à ne modifier qu'une seule fiche, on en implémenter d'autres à partir de la dernière.
Merci encore de votre aide :ccool:

Cordialement

Les Select à éviter
Tu as oublier de supprimer par exemple la feuille EU 2 avant de créer une nouvelle.

Code modifié

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
Private Sub CommandButton1_Click()
Dim Chemin As String, FichierImage As String, SufImg As String, NumImg As String
Dim LastLig As Integer, Lig As Integer, Compteur As Integer
 
Application.ScreenUpdating = False
Chemin = ThisWorkbook.Path & "\photos\"
With Sheets("Base de données")
    LastLig = .Cells(.Rows.Count, "M").End(xlUp).Row
End With
With Sheets("EU (1)")
    For Lig = 3 To LastLig Step 8
        Compteur = Compteur + 1
        .Image1.Picture = LoadPicture("")
        With Sheets("Base de données")
            SufImg = .Range("M" & Lig).Value
            NumImg = CStr(Format(.Range("N" & Lig).Value, "000"))
        End With
        If NumImg <> "" Then
            Application.DisplayAlerts = False
            On Error Resume Next
            Sheets("EU " & Compteur).Delete
            On Error GoTo 0
            Application.DisplayAlerts = True
            FichierImage = SufImg & NumImg & ".JPG"
            If Dir(Chemin & FichierImage) <> "" Then
                .Image1.Picture = LoadPicture(Chemin & FichierImage)
                .Image1.PictureSizeMode = 3
                .Copy After:=Worksheets(Worksheets.Count)
                Worksheets(Worksheets.Count).Name = "EU " & Compteur    'on renomme la nouvelle fiche en "EU 2" ou 3 etc... au fur et à mesure du compteur
                Sheets("EU " & Compteur).Shapes("CommandButton1").Delete    ' pour faire plus joli !!
                .Activate
            End If
        End If
    Next Lig
End With
End Sub

Compléments

Bonsoir,

Et bien en fait, le but est de générer les fiches les unes après les autres, et de les conserver. Donc en l'état, ça a l'air de fonctionner. Par contre, j'ai rajouté quelques fonctions :

macro principale :

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
Private Sub CommandButton1_Click()
Dim Image As Variant 'variable "nom du fichier"
Dim sh As Shape ' variable pour image à effacer
' variables "numéro de photo"
Dim Chemin As String, FichierImage As String, SufImg As String, NumImg As String, P As String, NSheets As String
Dim Lig As Integer, R As Integer, compteur As Integer
 
compteur = 1
Sheets("EU (1)").Select
 
For compteur = 1 To 480
 
Sheets("EU (1)").Select
ActiveSheet.[H6].Value = compteur 'sélection de la cellule cible dans EU (1)
 
Application.ScreenUpdating = False
With Sheets("EU (1)")
    Lig = .Range("H6").Value * 8 - 5
    If Lig > 0 Then
        .Image1.Picture = LoadPicture("")
        With Sheets("Base de données")
            SufImg = .Range("M" & Lig).Value
            NumImg = CStr(Format(.Range("N" & Lig).Value, "000"))
        End With
        If NumImg <> "" Then
            On Error Resume Next
            Application.DisplayAlerts = False
            Sheets(SufImg & NumImg).Delete
            Application.DisplayAlerts = True
            On Error GoTo 0
            Chemin = ThisWorkbook.Path & "\photos\"
            FichierImage = SufImg & NumImg & ".JPG"
            If Dir(Chemin & FichierImage) <> "" Then
                .Image1.Picture = LoadPicture(Chemin & FichierImage)
                .Image1.PictureSizeMode = 3
                .Copy After:=Worksheets(Worksheets.Count)
                Worksheets(Worksheets.Count).Name = "EU " & compteur
                Sheets("EU " & compteur).Shapes("CommandButton1").Delete
                Sheets("EU " & compteur).Shapes("CommandButton2").Delete
                Sheets("EU " & compteur).Shapes("CommandButton3").Delete
                Sheets("EU " & compteur).Shapes("CommandButton4").Delete
                .Activate
            End If
        End If
    End If
End With
 
Next
 
End Sub

Les commandbutton 2 à 4 sont des bouton supplémentaires :

code commandbuton2 : il ouvre une fenêtre pour ne modifier que l'image d'une fiche précise, renseignée dans deux boites de texte (feuille et n° de photo) d'une userform

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
Private Sub CommandButton3_Click()
 
Dim no As String
Dim nom As String
no = UserForm2.fichebox.Value
nom = UserForm2.photobox.Value
 
Sheets("EU " & no).Select
 
Dim Chemin As String, FichierImage As String
'Dim SufImg As String, NumImg As String
Dim Lig As Integer
 
Application.ScreenUpdating = False
With Sheets("EU " & no)
'    Lig = .Range("H6").Value * 8 - 5
'    If Lig > 0 Then
        .Image1.Picture = LoadPicture("")
'        With Sheets("Base de données")
'            SufImg = .Range("M" & Lig).Value
'            NumImg = CStr(Format(.Range("N" & Lig).Value, "000"))
'        End With
'        If NumImg <> "" Then
'            On Error Resume Next
            Application.DisplayAlerts = False
'            Sheets(SufImg & NumImg).Delete
            Application.DisplayAlerts = True
            On Error GoTo 0
            Chemin = ThisWorkbook.Path & "\photos\"
            FichierImage = nom & ".JPG"
            If Dir(Chemin & FichierImage) <> "" Then
                .Image1.Picture = LoadPicture(Chemin & FichierImage)
                .Image1.PictureSizeMode = 3
'                .Copy After:=Worksheets(Worksheets.Count)
'                Worksheets(Worksheets.Count).Name = SufImg & NumImg
'                Sheets(SufImg & NumImg).Shapes("SpinButton1").Delete
                .Activate
            End If
'        End If
'    End If
End With
UserForm2.Hide
 
End Sub

En fait, j'ai repris le code de tout à l'heure et j'ai désactivé les lignes qui ne servait pas (à priori...)

et enfin le troisième bouton :

Code:

1
2
3
4
5
6
7
Private Sub CommandButton3_Click()
Dim ShtErase As Integer
For ShtErase = 1 To 480
On Error Resume Next
Sheets("EU " & ShtErase).Delete
Next
End Sub

pour effacer toutes les fiches générées, au cas où.

Le 4e bouton n'ouvre qu'une fenêtre avec quelques explications.
A ce point là, tout fonctionne très bien. Sauf...
Quand je génère, modifie, supprime génère,supprime, etc... Au bout de 2 ou trois fois, un bug apparaît dans la dénomination de la nouvelle feuille. Je ne sais pas pourquoi. Dans le même temps, ces fonctions supplémentaires ne sont là qu'en cas de modification exceptionnelle.

Je sauvegarde, Excel 2003, ça fonctionne très bien. Mais mon collègue me dit qu'en ouvrant le fichier .xls avec Excel 2007, il y a un mini bug :
Normalement, devant la zone d'insertion de la photo, il doit y avoir un radiant (un cercle avec l'orientation pour se repérer). Tant que je l'ouvre en 2003, pas de problème, les fiches sont générées avec ce fichier .png par dessus la zone d'insertion d'image. Mais en 2007, il semble que ce radiant soit en dessous de la zone d'insertion : comment le mettre et le maintenir au dessus ?

Je te remercie de ton aide.
Cordialement.

28/02/2011, 10h43
mercatog

Bonjour,
Sans tester mon dernier code et sans adapter le tien en conséquence, je pense qu'au lieu d'avancer, tu vas tourner en rond.
Au moins, il fallait reporter les résultats de ton éventuel test
PS: Mon dernier code proposé ci-haut était ton code modifié en sorte de prévenir certains bug (notamment éviter de nommer une feuille d'un nom déjà existant et éviter l'instabilité due aux Select).
à toi de voir comment continuer