Discussion :

[casper62110]

Bonsoir, et meilleur vœux a tous.

Voila j'ai plusieurs page intitulé 500, 501, 503, .... créer selon un modèle.
et un dossier a la racine de la cle usb qui contient des photos intituler 500, 501, 503, .... en jpg

dans ces page en B357 par exemple je souhaiterai qu'il m'affiche une image qui porte le même nom que la page en cour

donc en page 500 il m'affiche 500.jpg
501 il m affiche 501.jpg
est ce possible et si oui comment?

merci d'avance pour tous.

[Invité]

Bonjour,

Une solution possible :

La référence Microsoft Windows Image Acquisition Library doit être cochée.
A partir du tuto "Utiliser la librairie Windows Image Acquisition en VBA" de SilkyRoad et Bbil pour connaître les propriétés de l'image importée.

Il vous suffit de définir les largeurs souhaitées (portrait, paysage) pour vos feuilles et de redéfinir le répertoire de vos images.

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
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
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
Option Explicit
 
Public RatioImage As Single
Public FormatImage As String
 
Public LargeurImagePortrait As Single
Public LargeurImagePaysage As Single
 
Sub MettreAJourLesImages()
 
' La référence Microsoft Windows Image Acquisition Library doit être cochée.
 
Dim Sh As Worksheet
Dim CelluleImport As Range
 
      LargeurImagePaysage = 319
      LargeurImagePortrait = 212
 
      For Each Sh In Worksheets
        Set CelluleImport = Sh.Range("B357")
        RecupererLesImages Sh, CelluleImport, "C:\Users\Eric\Documents\VBA Excel\Développez-Com\Images" ' A remplacer par votre répertoire
        Set CelluleImport = Nothing
      Next Sh
 
End Sub
 
Sub RecupererLesImages(ByVal FeuilleEnCours As Worksheet, ByVal CelluleImage As Range, ByVal Repertoire As String)
 
Dim MonImage As Shape
Dim MonFichier As String
 
    FeuilleEnCours.Activate
    For Each MonImage In FeuilleEnCours.Shapes
        Select Case MonImage.Name
               Case "ImageFeuille"
                    Application.DisplayAlerts = False
                    ActiveSheet.Shapes("ImageFeuille").Delete
                    Application.DisplayAlerts = True
        End Select
    Next MonImage
 
    On Error Resume Next
    ChDir Repertoire
 
    MonFichier = Dir(Repertoire & "\*.jpg")
    Do While MonFichier <> ""   ' Commence la boucle.
       Select Case MonFichier
              Case FeuilleEnCours.Name & ".jpg", FeuilleEnCours.Name & ".JPG"
                    RecupererLesInformationsSurLImage Repertoire & "\" & MonFichier
                    Select Case FormatImage
                           Case "Paysage"
                                ActiveSheet.Shapes.AddShape(msoShapeRectangle, CelluleImage.Left, CelluleImage.Top, LargeurImagePaysage, LargeurImagePaysage / RatioImage).Select
                                Selection.Name = "ImageFeuille"
                                With Selection.ShapeRange.Fill
                                     .Visible = msoTrue
                                     .UserPicture Repertoire & "\" & MonFichier
                                     .TextureTile = msoFalse
                                     .ForeColor.ObjectThemeColor = msoThemeColorText1
                                End With
                                With Selection.ShapeRange.Line
                                     .Visible = msoTrue
                                     .Weight = 1
                                End With
                           Case "Portrait"
                                ActiveSheet.Shapes.AddShape(msoShapeRectangle, CelluleImage.Left, CelluleImage.Top, LargeurImagePortrait, LargeurImagePortrait / RatioImage).Select
                                Selection.Name = "ImageFeuille"
                                With Selection.ShapeRange.Fill
                                     .Visible = msoTrue
                                     .UserPicture Repertoire & "\" & MonFichier
                                     .TextureTile = msoFalse
                                     .ForeColor.ObjectThemeColor = msoThemeColorText1
                                End With
                                With Selection.ShapeRange.Line
                                    .Visible = msoTrue
                                    .Weight = 1
                                End With
                           End Select
 
                           With ActiveWindow
                                .ScrollRow = CelluleImage.Row - 1
                                .ScrollColumn = CelluleImage.Column - 1
                           End With
        End Select
        MonFichier = Dir   ' Extrait l'entrée suivante.
   Loop
 
End Sub
 
 
Sub RecupererLesInformationsSurLImage(ByVal CheminEtNomDeLImage As String)
 
' A partir du tuto "Utiliser la librairie Windows Image Acquisition en VBA" de SilkyRoad et Bbil
 
Dim Img As WIA.ImageFile
 
    Set Img = CreateObject("WIA.ImageFile")
    Img.LoadFile CheminEtNomDeLImage
    If Img.Width > Img.Height Then
        FormatImage = "Paysage"
        RatioImage = Img.Width / Img.Height
    Else
        FormatImage = "Portrait"
        RatioImage = Img.Width / Img.Height
    End If
    Set Img = Nothing
 
 
End Sub

Cordialement.