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 |
Partager