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
109
110
111
112
113
114
115
116
117
118
119
120
|
Option Explicit
'*******************************************************************************************************
' NAME : LoadPicture (PROCESS)
'*******************************************************************************************************
Sub LoadPicture()
Dim sRacinePath As String ' Chemin de destination
Dim sPictureName As String ' Nom de la photo (ex : Photo1.png)
Dim sPicturePath As String ' Nom complet de la photo
Dim sPictureUrl As String ' Url de la photo
Dim sMessage As String ' Message de complétude
Dim iRow As Integer ' Compteur
Dim iFirstRow As Integer ' Première ligne de la boucle
Dim iLastRow As Integer ' Dernière ligne de la boucle
Dim iColumn As Integer ' Colonne contenant les Url (A=1, B=2, ...)
Dim oWorksheet As Excel.Worksheet ' Feuille Excel où se trouve les Url
' Paramètrage des constantes
sRacinePath = "C:\Users\McEvee\Pictures\" '-- A Modifier avec ton chemin
Set oWorksheet = Feuil1 ' -- Selectionner la feuille avec les Url
iColumn = 1
iFirstRow = 1
iLastRow = oWorksheet.Cells(iFirstRow, iColumn).End(xlDown).Row
If VBA.Right$(sRacinePath, 1) <> "\" Then 'Vérification du format du chemin
sRacinePath = sRacinePath & "\"
End If
' Vérification de l'existance du chemin
If VBA.Len(VBA.Dir(sRacinePath, VBA.vbDirectory)) < 0 Then
VBA.MsgBox "Le chemin " & sRacinePath & " n'existe pas"
Exit Sub
End If
' Boucle de chargement des images
For iRow = iFirstRow To iLastRow
sPictureUrl = CStr(oWorksheet.Cells(iRow, iColumn).Value)
' Pour récupérer uniquement le nom de l'image avec
' son extension à partir de l'Url
sPictureName = VBA.Mid$(sPictureUrl, VBA.InStrRev(sPictureUrl, "/") + 1, _
VBA.Len(sPictureUrl))
' Sinon
' sPictureName = sPictureUrl
sPicturePath = sRacinePath & sPictureName
' Export de l'image
sMessage = ExportPicture(oWorksheet, sPictureUrl, sPicturePath)
If Not sMessage = "Export OK" Then
VBA.MsgBox "Ligne " & iRow & " : " & sMessage
Exit Sub
End If
Next iRow
End Sub
'*******************************************************************************************************
' NAME : ExportPicture (FUNCTION)
' INPUT : oWorksheet, sPictureUrl, sRacinePath
' OUTPUT : String
' DESCRIPTION : Le chemin de destination (sPicturePath) doit contenir le chemin complet de l'image a
' exporter (ex : "C:/Username/Image/Photo1.png"). La fonction teste sa valeur au moment de la méthode
' Export de l'objet Chart qui est de type boolean (par défaut valeur True)
'*******************************************************************************************************
Public Function ExportPicture(oWorksheet As Excel.Worksheet, sPictureUrl As String, _
sPicturePath As String) As String
Dim oPicture As Object
Dim oChart As Object
ExportPicture = VBA.vbNullString
If VBA.Len(sPicturePath) > 256 Then 'Vérification de la longueur du chemin
ExportPicture = "Le nom de l'image dépasse les capacités (Max 256)"
Exit Function
End If
' Insertion de l'image url dans la feuille (oWorksheet)
Set oPicture = oWorksheet.Pictures.Insert(sPictureUrl)
If oPicture Is Nothing Then 'Vérification du chargement
ExportPicture = "Le chargement de l'image n'a pas abouti"
Exit Function
End If
oPicture.CopyPicture 'On copie en mémoire
' On créer un graphique pour avoir accès à la méthode Export
' Le graphique est dimensioné en fonction de la photo
Set oChart = oWorksheet.ChartObjects.Add(oPicture.Left, oPicture.Top, _
oPicture.Width, oPicture.Height).Chart
oPicture.Delete ' On supprime la photo Url
Set oPicture = Nothing 'Vidange
' On Copie l'image et on l'export avec son nom complet
' La méthode export possède deux paramètres optionnels (voir l'aide Chart.Export)
With oChart
.Paste
If .Export(sPicturePath) Then
ExportPicture = "Export OK"
Else
ExportPicture = "Un problème est survenu lors de l'export"
End If
End With
Set oChart = Nothing
'Suppression du chart
For Each oChart In oWorksheet.ChartObjects
oChart.Delete
Next oChart
End Function |
Enregistrer une image unique dans une fenêtre Chrome et fermer la fenêtre
Répondre avec citation
en surveillant sur le 2eme ecran le résultat sur le repertoire, pour 4 photos ==> c'est OK
Partager