Forum

Get an Image From t...
 
Notifications
Clear all

Get an Image From the Web with VBA based on Specific Criteria

5 Posts
2 Users
0 Reactions
240 Views
(@a-maurizio)
Posts: 214
Reputable Member
Topic starter
 

Hello everyone My name is Maurizio And I would like to set up my initial question differently: There is a different way Always using the VBA to retrieve data from a Web page that give the Weather Forecast and its Images directly. (PS) I better explain: I would like to learn how to extract from a web page the data of a forecast of the time Example (Turin) and to be able to insert in the necessary cells of the Excel sheet the data as (Min; Max) Relative Dates dates you have taken into consideration (Today, Tomorrow, Sunday) etc ... "and related Images to it Set everything here. Thank you for all the help you want to give me about Greetings from A.Maurizio

 

(P.S) I insert test files even if I know that will serve little because the images are not compatible

 
Posted : 22/11/2017 12:36 pm
(@catalinb)
Posts: 1937
Member Admin
 

Hi Maurizio,

I can help you with the download image part:

Option Explicit

Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Dim Ret As Long

Function DownloadImagesFromLink(FilePath As String, Cell As Range) As String
Dim FolderName As String, ImageName As String, Img As Shape
FolderName = ThisWorkbook.Path & "Images"
If Len(Dir(FolderName, vbDirectory)) = 0 Then MkDir FolderName
ImageName = Right(FilePath, Len(FilePath) - InStrRev(FilePath, "/") + 1)
Ret = URLDownloadToFile(0, FilePath, FolderName & ImageName, 0, 0)

For Each Img In Cell.Parent.Shapes
    If Img.Name = Cell.Address Then Img.Delete
Next Img

If Ret = 0 Then Cell.Parent.Shapes.AddPicture(FolderName & ImageName, msoFalse, msoTrue, Cell.Left, Cell.Top, -1, -1).Name = Cell.Address
DownloadImagesFromLink = ""
End Function

You can even use this function in your worksheet cells, it only needs a link to work and the destination cell, it will download the images in the same folder where the workbook with this code is located, in a subfolder named Images.

Using your sample workbook, if you want to place the image next to the link from A1, put this formula in B1:

=DownloadImagesFromLink(A1,B1)

The image will show up in this cell with the formula.

For the rest of your requirements, it looks like someone should write the entire application based on your requirements, hope someone will have time to do this. A forum is not the best place to request a full application, the work should be mostly yours, we can help by pointing you in the right direction.

I suggest you use the https://openweathermap.org/forecast5 API, it's free and the response can be easily downloaded:

Here is a sample:

api.openweathermap.org/data/2.5/forecast?q=Torino,It&mode=xml&APPID={APIKEY}

Replace the {APIKEY} with your key (you have to signup and they will send you your key).

This sample request is easy to do with VBA, you can save the response file as xml and import it in excel.

Here is a sample code:

Sub GetForecast()

Dim oXmlHttp As MSXML2.XMLHTTP60, APPID As String, City As String, Country As String
Set oXmlHttp = New MSXML2.XMLHTTP60
APPID = ThisWorkbook.Worksheets("Forecast Data").Range("APPID")
City = ThisWorkbook.Worksheets("Forecast Data").Range("City")
Country = ThisWorkbook.Worksheets("Forecast Data").Range("Country")
oXmlHttp.Open "GET", "http://api.openweathermap.org/data/2.5/forecast?q=" & City & "," & Country & "&mode=xml&APPID=" & APPID, False
oXmlHttp.setRequestHeader "Content-Type", "application/xml"
oXmlHttp.setRequestHeader "Connection", "Keep-Alive"
oXmlHttp.setRequestHeader "Accept-Language", "en"

On Error Resume Next
oXmlHttp.send
On Error GoTo 0

If oXmlHttp.Status = 200 Then
  If oXmlHttp.responseXML.parseError.ErrorCode = 0 Then _
                    oXmlHttp.responseXML.Save ThisWorkbook.Path & "/forecast.xml"
 
  'clear old data
  If Not ThisWorkbook.Worksheets("Forecast Data").ListObjects("DataTbl").DataBodyRange Is Nothing Then ThisWorkbook.Worksheets("Forecast Data").ListObjects("DataTbl").DataBodyRange.Delete
  'import the forecast xml:
  ThisWorkbook.XmlMaps("weatherdata_Map").Import ThisWorkbook.Path & "/forecast.xml", False
Else
   MsgBox oXmlHttp.Status & vbNewLine & oXmlHttp.responseText
End If

Set oXmlHttp = Nothing

End Sub

Note that the code cannot be used as is, it involves a structure set like in the attached file, with 3 defined names in those yellow cells from Forecast Data sheet (API key, City, Country). There is also an xml map set in that table. The code needs a reference to Microsoft XML tools and Microsoft Internet Controls.

To test the code, you will have to get your key and paste it in the indicated cell. (it takes about 10 minutes to activate the key, after you sign up for a free key)

 

Regards,

Catalin

 
Posted : 13/12/2017 10:07 am
(@a-maurizio)
Posts: 214
Reputable Member
Topic starter
 

Hello Catalin Bombea I'm sorry for the Ritarmo in returning to your Seat, but I've been busy with my work. So: first thing first Thank you so much for your Proverbial Suggestions. But going here and between the internet pages, I had already guessed by myself that it would not be a walk. But in my Piccolo I certainly managed to do a good job. As: Using my tenacity and tenacity and a little help from you, I still managed to do a good job. In Facts without offending anyone, as I myself have everything and much to learn from you. I would like to offer you my finished work in the form of evaluation and further advice on your part. I want to offer as a starting point For all those people like me who I am would be interested in doing something like this; That's all. Thanks again for all Sincere greetings and Good work to all by A.Maurizio

 
Posted : 14/12/2017 9:29 am
(@catalinb)
Posts: 1937
Member Admin
 

Great, glad to hear you managed to make it work

Catalin

 
Posted : 14/12/2017 9:41 am
(@a-maurizio)
Posts: 214
Reputable Member
Topic starter
 

Real NICE  !!!!!!

Thank you for your compliments; I know they're sincere.

Hello and the next da A.Maurizio

 
Posted : 15/12/2017 4:53 pm
Share: