Bonjour à tous !
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 :
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).
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 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
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.
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é ?).
Partager