السلام عليكم ورحمة الله وبركاته

أهلاً بكم إخواني وأحبابي في الله ...
أقدم لكم اليوم النشرة الجوية من داخل الأجواء الإكسيلية ، وعلى متابعي الموضوع توخي الحذر لكي لا يصابوا بنزلة برد عند تنفيذ الأكواد

الموضوع منقول بتصرف ، حيث وجدت الكود في أحد الموضوعات فقمت بتنقيح الكود وتصحيح بعض الأخطاء في الكود لكي يعمل بشكل صحيح ، كما أضفت تنسيقات على المخرجات بحيث يمكنك تنفيذ الكود في أي ورقة عمل ...

بعد تنفيذ الكود ستحصل على حالة الطقس لمدة خمسة أيام بالشكل التالي


لتنفيذ الموضوع قم بنسخ الكود التالي وضعه في موديول عادي

'References: Microsoft WinHTTP Services, version 5.1 / Microsoft XML, v6.0

Sub Weather_Forecast()
    Dim ws          As Worksheet
    Dim req         As New XMLHTTP60
    Dim resp        As New DOMDocument60
    Dim wthr        As IXMLDOMNode
    Dim c           As Range
    Dim shp         As Shape
    Dim sCty        As String
    Dim imageURL    As String
    Dim imageFile   As String
    Dim sFolder     As String
    Dim i           As Long
    Dim x           As Long
    Dim y           As Long
    
    sCty = InputBox("Type Your City", "ExcelEgy", "Matrouh")
    If sCty = vbNullString Then Exit Sub
    
    req.Open "GET", "http://api.worldweatheronline.com/premium/v1/weather.ashx?key=11111&q=" & sCty & "&format=xml&num_of_days=5", False
    req.send
    resp.LoadXML req.responseText
    
    Application.ScreenUpdating = False
        Set ws = ActiveSheet
        With ws
            .DisplayRightToLeft = False
            .Range("A1").Resize(5).Value = Application.Transpose(Array("Date", "Day"," ", "High Temp.", "Low Temp."))
            For Each shp In ws.Shapes
                shp.Delete
            Next shp
        End With
    
        For Each wthr In resp.getElementsByTagName("weather")
            i = i + 1
    
            ws.Range("B1:F1").Cells(1, i).Value = wthr.SelectNodes("date")(0).Text
            ws.Range("B2:F2").Formula = "=TEXT(WEEKDAY(B1,1),""dddd"")"
            ws.Range("B4:F4").Cells(1, i).Value = wthr.SelectNodes("maxtempC")(0).Text
            ws.Range("B5:F5").Cells(1, i).Value = wthr.SelectNodes("mintempC")(0).Text
            
            Set c = ws.Range("B3:F3").Cells(1, i)
            Set shp = ws.Shapes.AddShape(msoShapeRectangle, c.Left, c.Top, c.Width, c.Height)
    
            imageURL = wthr.SelectNodes("hourly").Item(4).Text
            x = InStr(1, imageURL, "http")
            y = InStr(1, imageURL, ".png")
            imageURL = Mid(imageURL, x, (y + 4) - x)
            imageFile = Right(imageURL, Len(imageURL) - InStrRev(imageURL, "/"))
    
            sFolder = Environ("USERPROFILE") & "Desktop" & "Weather Icons"
            If Len(Dir(sFolder, vbDirectory)) = 0 Then MkDir sFolder
    
            Save_Image imageURL, imageFile, sFolder
            shp.Fill.UserPicture sFolder & imageFile
        Next wthr
        
        With ws
            With .Range("A1").CurrentRegion
                .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter
            End With
            .Columns(1).ColumnWidth = 13: .Columns("B:F").ColumnWidth = 11.5
            .Rows(3).RowHeight = 60
            .Range("A1, A2, A4, A5").RowHeight = 19
        End With
    Application.ScreenUpdating = True
End Sub

Sub Save_Image(ImgUrl As String, imageFile As String, sFolder As String)
    Dim oHTTP       As Object
    Dim oStream     As Object

    Const adTypeBinary = 1
    Const adSaveCreateOverWrite = 2

    Set oHTTP = CreateObject("msxml2.XMLHTTP")
    oHTTP.Open "GET", ImgUrl, False
    oHTTP.send

    Set oStream = CreateObject("ADODB.Stream")
    oStream.Type = adTypeBinary
    oStream.Open

    oStream.write oHTTP.ResponseBody
    oStream.savetofile sFolder & imageFile, adSaveCreateOverWrite

    Set oStream = Nothing
    Set oHTTP = Nothing
End Sub

يقوم الكود بسؤالك أولاً عن اسم المدينة التي تريد أن تعرف حالة الطقس لها وذلك من خلال صندوق إدخال InputBox ثم يقوم بالذهاب لموقع worldweatheronline ثم يجلب حالة الطقس لمدة 5 أيام بالاعتماد على الـ API ، ويمكن الحصول على كود الـ API بالتسجيل المجاني في الموقع .. ثم أخيراً يظهر الكود النتائج لحالة الطقس في ورقة العمل بشكل يسهل عليك تتبع حالة الطقس

رابط الملف من هنا

في الملف المرفق يوجد السطر التالي

req.Open "GET", "http://api.worldweatheronline.com/premium/v1/weather.ashx?key=11111&q=" & sCty & "&format=xml&num_of_days=5", False

قم باستبدال 1111 بالـ API الخاص بك وللحصول على API اذهب للرابط التالي
https://www.worldweatheronline.com/developer/signup.aspx
ثم سجل عن طريق جوجل أو سجل في الموقع لتحصل على API مجاني صالح لمدة شهرين

أسألكم الدعاء ، وجزاكم الله خيراً

إعداد وتقديم / ياسر خليل أبو البراء