Discussion :

[jolebouyguiens]

Bonjour,

J'ai créé une fonction qui pilote internet explorer via VBA Ecxel.
Lorsque je charge la page X, je souhaite enregistrer sous une image en particulier. Helas, je ne trouve nul part une solution a mon probleme.

Merci de m'aider.

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
Sub Rectangle1_Clic()
 
Set dev = CreateObject("InternetExplorer.Application")  'crée un objet internet Explorer
dev.Visible = True
 
URLdev = "http://www.monsite.com"
dev.Navigate URLdev
While dev.Busy
Wend
 
Set IEdoc = dev.document
 
'enregistrement de l'image contenu dans la page internet explorer
'???
 
End Sub

l'image est dnamique, il me faut donc enregistrer celle affichée sur internet explorer

[Krovax]

Question est ce que l'url de l'image et fixe?
Si oui tu peux essayer directement

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
 
Sub AjoutImageFeuille_V03()
    Dim Shp As Shape
    Dim Fichier As String
 
    Fichier = "http://www.developpez.com/template/logo.gif"
    Set Shp = Feuil1.Shapes.AddPicture(Fichier, msoFalse, msoCTrue, 0, 0, 150, 70)
End Sub

Rendons à César ce qui appartient à César, cela est tiré tout droit de la Faq

Si non je continu de chercher il me semble avoir vu un post a ce sujet il y a quelque temps

[jolebouyguiens]

justement l'image est dynamique, on ne peut utiliser l'url de l'image pour la charger car l'image aura changé.

Il faudrait recuperer l'image qui est deja chargé dans internet explorer comme un enregistrer sous mais avec vba

Merci

[SilkyRoad]

Bonjour

justement l'image est dynamique, on ne peut utiliser l'url de l'image pour la charger car l'image aura changé.

Il faudra bien récupérer l'url à un moment donné afin de télécharger l'image :
http://excel.developpez.com/faq/?pag...rlDownloadFile

L'image sera toujours à la même position dans la page html ?
Est ce qu'il est possible de l'identifier par son index ?

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
'***************
'boucler sur toutes les images d'une page Web
'pour recuperer l'adresse et les dimensions
'*********************
'testé avec WinXP & Excel2002
'nécéssite d'activer la référence Microsoft HTML Objects Library
'nécéssite d'activer la référence Microsoft Internet Controls
Dim IE As InternetExplorer
Dim maPageHtml As HTMLDocument
Dim imgHtml As HTMLImg
Dim i As Integer
 
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
 
IE.navigate "http://nomdusite.htm"
Do Until IE.readyState = READYSTATE_COMPLETE
DoEvents
Loop 'attend la fin du chargement pour continuer la procedure
 
 
Set maPageHtml = IE.document
'compte le nombre d'images dans la page
MsgBox "nombre d'images dans la page : " & maPageHtml.images.Length
 
For i = 0 To maPageHtml.images.Length - 1 'boucle sur les images
    Set imgHtml = maPageHtml.images.Item(i)
 
    Debug.Print imgHtml.src 'adresse image
    Debug.Print imgHtml.Width 'largeur image
    Debug.Print imgHtml.Height 'hauteur image
Next i

bon après midi
michel

[jolebouyguiens]

Set imgHtml = maPageHtml.images.Item(i)

Ceci est interessant. Je vais examiner ce code est ces possibilité.

----------------

En faites, si on charge a nouveau l'adresse de l'image, celle ci necorrespondra plus a l'image affiché sur la page.

exemple:
http://www.monsite.com/xxx/image.php?genere=0.01245811

ceci pointe une image jpg
lorsque l'on recharge la page:

http://www.monsite.com/xxx/image.php?genere=0.1254656

l'adresse change et l'image aussi
Mais si on recharge l'adresse exact:
http://www.monsite.com/xxx/image.php?genere=0.1254656
L'image a elle aussi ete rechangé ca une page php génère cette photo

Conclusion:
Il me faut recuperer la photo chargé précédement dans internet explorer via VBA

-----------------------------
Piste actuelle afin de palier au probleme d'ici un script plus jolie:

Je suis en train de faire un screenshot de la page, et je vais essayer de redecouper la photo. Je ne sais pas si cela va marcher et sera fonctionnel car le screenshot altere l'image.
-----------------------------

Merci de m'aider

[jolebouyguiens]

J'ai trouvé une solution provisoir.
Je fais un screenshot de l'ecran puis rogne l'image afin d'obtenir celle voulu.
Cette solution n'est pas parfaite mais marche en attendant.

Voici le code pour ceux qui sont susceptible de recourir a cette methode

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
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
 
Private Declare Function BitBlt Lib "gdi32.dll" _
(ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _
ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
 
Private Declare Function CreateBitmap Lib "gdi32" _
(ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) _
As Long
 
Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hdc As Long) As Long
 
Private Declare Function CreateDIBSection Lib "gdi32" _
(ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, _
ByVal lplpVoid As Long, ByVal Handle As Long, ByVal dw As Long) As Long
 
Private Declare Function DeleteDC Lib "gdi32" _
(ByVal hdc As Long) As Long
 
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
 
Private Declare Function GetDC Lib "user32.dll" _
(ByVal hwnd As Long) As Long
 
Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long
 
Private Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hdc As Long, ByVal nIndex As Long) As Long
 
Private Declare Function GetDIBits Lib "gdi32" _
(ByVal aHDC As Long, ByVal hBitmap As Long, _
ByVal nStartScan As Long, ByVal nNumScans As Long, _
lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
 
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) As Long
 
Private Type BITMAPINFO
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biRUsed As Long
    biRImportant As Long
End Type
 
Private Type BITMAPFILEHEADER
    bfType As Integer
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits As Long
End Type
 
Private Const GHND = &H42
Private Const MAXSIZE = 4096
Private Const SRCCOPY = &HCC0020
Private Const DIB_RGB_COLORS = 0&
Private Const BI_RGB = 0&
 
Function ImprimEcran(strNomDuFichier As String)
On Error GoTo Finally
Dim lngLargeur As Long, lngHauteur As Long
Dim lngHdc As Long
Dim lngHBmp As Long
Dim bmiBitmapInfo As BITMAPINFO
Dim bmfBitmapFileHeader As BITMAPFILEHEADER
Dim lngFnum As Integer
Dim pixels() As Byte
Dim bolOuvert As Boolean
lngHdc = CreateCompatibleDC(0)
If lngHdc = 0 Then
  GoTo Finally
End If
'Récupère les dimensions de l'écran
lngHauteur = GetDeviceCaps(lngHdc, 10)
lngLargeur = GetDeviceCaps(lngHdc, 8)
'Crée un bitmap vierge
With bmiBitmapInfo
  .biBitCount = 32
  .biCompression = BI_RGB
  .biPlanes = 1
  .biSize = Len(bmiBitmapInfo)
  .biHeight = lngHauteur
  .biWidth = lngLargeur
  .biSizeImage = ((((.biWidth * .biBitCount) + 31) \ 32) * 4 - _
    (((.biWidth * .biBitCount) + 7) \ 8)) * .biHeight
End With
lngHBmp = CreateDIBSection(lngHdc, bmiBitmapInfo, DIB_RGB_COLORS, _
  ByVal 0&, ByVal 0&, ByVal 0&)
If lngHBmp = 0 Then
  GoTo Finally
End If
If SelectObject(lngHdc, lngHBmp) = 0 Then
  GoTo Finally
End If
'Copie le contenu de l'ecran
If BitBlt(lngHdc, 0&, 0&, lngLargeur, lngHauteur, _
  GetDC(GetDesktopWindow()), 0&, 0&, SRCCOPY) = 0 Then
  GoTo Finally
End If
'Crée l'entête du fichier bmp
With bmfBitmapFileHeader
  .bfType = &H4D42&
  .bfOffBits = Len(bmfBitmapFileHeader) + Len(bmiBitmapInfo)
  .bfSize = .bfOffBits + bmiBitmapInfo.biSizeImage
End With
'Lit les bits du bitmap et les places dans le tableau pixels
ReDim pixels(1 To 4, 1 To lngLargeur, 1 To lngHauteur)
If GetDIBits(lngHdc, lngHBmp, 0, lngHauteur, pixels(1, 1, 1), _
  bmiBitmapInfo, DIB_RGB_COLORS) = 0 Then
  GoTo Finally
End If
lngFnum = FreeFile
'Crée le fichier
Open strNomDuFichier For Binary As lngFnum
bolOuvert = True
'Ecrit l'entête
Put #lngFnum, , bmfBitmapFileHeader
'Ecrit les informations du bitmap
Put #lngFnum, , bmiBitmapInfo
'Ecrit les bits de l'image
Put #lngFnum, , pixels
Finally:
'Ferme le fichier si ouvert
If bolOuvert Then Close lngFnum
'Supprime les objets
If lngHBmp <> 0 Then DeleteObject lngHBmp
If lngHdc <> 0 Then DeleteDC lngHdc
End Function
 
Sub Rectangle1_Clic()
 
'ImprimEcran "C:\destinataire.jpg"
    ' rognage de l'image
    Dim Img1 As Object, IP As Object
    'Création conteneur pour l'image à manipuler
    Set Img1 = CreateObject("WIA.ImageFile")
    'Création du gestionnaire de filtre
    Set IP = CreateObject("WIA.ImageProcess")
    'Chargement de l'image dans le conteneur
    Img1.LoadFile ("C:\destinataire.jpg")
    'Ajoute le filtre pour Couper/Rogner l'image (Crop)
    IP.Filters.Add (IP.FilterInfos("Crop").FilterID)
    'La coupe sera effectuée à l'intérieur du cadre défini ci dessous:
    '**********
    'definit la position à partir du bord gauche pour la coupe
    IP.Filters(1).Properties("Left") = 410
    'definit la position à partir du bord supérieur pour la coupe
    IP.Filters(1).Properties("Top") = 445
    'definit la position à partir du bord droit pour la coupe
    IP.Filters(1).Properties("Right") = 875
    'definit la position à partir du bord inférieur pour la coupe
    IP.Filters(1).Properties("Bottom") = 430
    'application du filtre
    Set Img1 = IP.Apply(Img1)
    'verifie si existe supprilme et Sauvegarde de la nouvelle image
    Set fso = CreateObject("Scripting.FileSystemObject")
    If (fso.FileExists("C:\rognimag.jpg")) Then
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    objFSO.DeleteFile ("C:\rognimag.jpg")
    End If
    Img1.SaveFile ("C:\rognimag.jpg")
 
 
End Sub

Attention a l'adresse de destination sous VISTA.
Ici, je pointe sur C:\ sous Vista rien ne se passera pour des problemes de droits. Pointez plutot votre dossier Documents



-------------------------------------------------

Si quelqu'un a une meilleur solution que cette petite bidouille, je suis preneur