# Get data from Access SQL database with ADODB and weather data using web service and Excel VBA

This is a follow-up from this post.

It all works, but I think the code could be made to work faster and to be more stable. I have made improvements and updated the code in this new question.

Basically, when I activate the worksheet the weather information updates and three listboxes in the worksheet updates.

Public Sub Worksheet_Activate()

'Removes shapes already there that will be updated by the getWeather function
DeleteShapes

'Calls a function to get weather data from a web service
Call GetWeather("url", "Area1")
Call GetWeather("url", "Area2")
Call GetWeather("url", "Area3")

'fill lists with information
FillLists

End Sub


Then comes the DeleteShapes sub. This sub deletes a picture inserted by the GetWeather sub the last time it was updated. The reason for this is to not have a million pictures on top of eachother.

Public Sub DeleteShapes()

Dim delShape As Shape
For Each delShape In ARK_front.Shapes
If delShape.Type = msoAutoShape Then delShape.Delete
Next delShape

End Sub


Now the GetWeather sub. This sub gets weather information from worldweatheronline.com.

Public Sub GetWeather(APIurl As String, sted As String)

Dim i As Integer
Dim ws As Worksheet: Set ws = ActiveSheet
Dim Req As New XMLHTTP
Dim Weather As IXMLDOMNode
Dim wShape As Shape
Dim thisCell As Range
Dim Resp As New DOMDocument

i = 0

Case "Area1"
i = 4
Case "Area2"
i = 6
Case "Area3"
i = 8
Case Else
Exit Sub
End Select

Req.Open "GET", "" & APIurl & "", False
Req.Send

For Each Weather In Resp.getElementsByTagName("current_condition")

Set thisCell = ws.Range(Cells(2, i), Cells(2, i))
Set wShape = ws.Shapes.AddShape(msoShapeRectangle, thisCell.Left, thisCell.Top, thisCell.Width, thisCell.Height)

wShape.Fill.UserPicture Weather.ChildNodes(4).Text 'img

Cells(3, i).Value = "" & Weather.ChildNodes(7).Text * 0.28 & " m/s" 'windspeedkmph
Cells(4, i).Value = Weather.ChildNodes(9).Text 'Direction
Cells(5, i).Value = Weather.ChildNodes(1).Text & " C"  'observation time
Next Weather

End Sub


Now the sub to fill three listboxes in a worksheet with information from a Access database using SQL.

Public Sub FillLists()
'I cannot run option explicit. It gives me the error message of "Invalid inside procedure". I cannot for the life of me figure out what or where it comes from.
'Option Explicit

' I have to declare formattedStartDate and formattedEndDate as string and not Date. If I declare them as Date, they follow the "dd.mm.yyy" format, even if I use format("expression", "mm/dd/yyyy"
Dim formattedStartDate As String
Dim formattedEndDate As String
Dim i, j, u As Integer

formattedStartDate = Month(Date) & "/" & Day(Date) - 7 & "/" & Year(Date)
formattedEndDate = Month(Date) & "/" & Day(Date) & "/" & Year(Date)

'I realize that this is a security issue, and that I should not trust my users to not mess it up. But I know that my users dont know how VBA or SQL even in the slightest. So I will let it pass.

'Create a new connection with sqlConnect and a new recordset with rs.

'sqlConnect utilizes the connectionstring.
sqlConnect.connectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\database.accdb;Persist Security Info=False;"

'Open the connection
sqlConnect.Open

'Set rs.Activeconnection to sqlConnect
rs.ActiveConnection = sqlConnect

'Query the Access database
rs.Open "SELECT [RefNr], [Registrert Av],[Nettstasjon], [Meldt Dato], [Sekundærstasjon], [Avgang], [Beskrivelse], [Til Dato] FROM [tblDatabase]" & _
"WHERE [Loggtype] = 'Beskjed' AND [Meldt Dato] >= DateAdd('d',-30,Date())" & _
"ORDER BY [Meldt Dato] DESC;", sqlConnect, adOpenStatic

'Set j value to 0 so that we know where it starts
j = 0

'Populate the first listbox
With ARK_front.lst_beskjeder
.Clear
Do While Not rs.EOF
If Not IsNull(rs!refnr) Then
.List(j, 0) = rs![refnr]
End If

If IsDate(rs![Meldt Dato]) Then
.List(j, 1) = Format(rs![Meldt Dato], "dd/mm/yy")
End If

.List(j, 4) = rs![nettstasjon]

If Not IsNull(rs![Sekundærstasjon]) Then
.List(j, 2) = rs![Sekundærstasjon]
End If

If Not IsNull(rs![Avgang]) Then
.List(j, 3) = rs![Avgang]
End If

If Not IsNull(rs![beskrivelse]) Then
.List(j, 5) = rs![beskrivelse]
End If

j = j + 1
rs.MoveNext
Loop
End With

'Close the recordset and reopen a new one with a different query
rs.Close
rs.Open "SELECT [RefNr], [Registrert Av],[Nettstasjon], [Meldt Dato] , [Bestilling], [Sekundærstasjon], [Avgang], [Hovedkomponent], [HovedÅrsak], [Status Bestilling] FROM [tblDatabase]" & _
"WHERE [Registrert Av] <> '" & yourUserName & "' AND [Meldt Dato] BETWEEN #" & formattedStartDate & "# AND #" & formattedEndDate & "#" & _
"ORDER BY [Meldt Dato] DESC;", sqlConnect, adOpenStatic

'Set u to 0 so that we know that it is zero at this point
u = 0

'Populate the second listbox
With ARK_front.lst_AlleFeil
.Clear
Do While Not rs.EOF
If Not IsNull(rs!refnr) Then
.List(u, 0) = rs![refnr]
End If

If IsDate(rs![Meldt Dato]) Then
.List(u, 1) = Format(rs![Meldt Dato], "dd/mm/yy")
End If

If Not IsNull(rs![nettstasjon]) Then
.List(u, 4) = rs![nettstasjon]
End If

If Not IsNull(rs![Sekundærstasjon]) Then
.List(u, 2) = rs![Sekundærstasjon]
End If

If Not IsNull(rs![Avgang]) Then
.List(u, 3) = rs![Avgang]
End If

If Not IsNull(rs![Hovedkomponent]) Then
.List(u, 5) = rs![Hovedkomponent]
End If

If Not IsNull(rs![HovedÅrsak]) Then
.List(u, 6) = rs![HovedÅrsak]
End If

If Not IsNull(rs![Status Bestilling]) Then
.List(u, 7) = rs![Status Bestilling]
End If

If Not IsNull(rs![bestilling]) Then
.List(u, 8) = rs![bestilling]
End If

u = u + 1
rs.MoveNext
Loop
End With

'Close and reopen a new recordset
rs.Close
rs.Open "SELECT [RefNr], [Registrert Av],[Nettstasjon], [Meldt Dato] , [Bestilling], [Sekundærstasjon], [Avgang], [Hovedkomponent], [HovedÅrsak], [Status Bestilling] FROM [tblDatabase]" & _
"WHERE [Registrert Av] = '" & yourUserName & "' AND [Loggtype] <> 'Beskjed' AND [Meldt Dato] BETWEEN #" & formattedStartDate & "# AND #" & formattedEndDate & "#" & _
"ORDER BY [Meldt Dato] DESC;", sqlConnect, adOpenStatic

'Set i to 0 so that we know that it is zero at this point
i = 0

'Populate the third listbox
With ARK_front.lst_mineFeil
.Clear
Do While Not rs.EOF
If Not IsNull(rs!refnr) Then
.List(i, 0) = rs![refnr]
End If

If IsDate(rs![Meldt Dato]) Then
.List(i, 1) = Format(rs![Meldt Dato], "dd/mm/yy")
End If

.List(i, 4) = rs![nettstasjon]

If Not IsNull(rs![Sekundærstasjon]) Then
.List(i, 2) = rs![Sekundærstasjon]
End If

If Not IsNull(rs![Avgang]) Then
.List(i, 3) = rs![Avgang]
End If

If Not IsNull(rs![Hovedkomponent]) Then
.List(i, 5) = rs![Hovedkomponent]
End If

If Not IsNull(rs![HovedÅrsak]) Then
.List(i, 6) = rs![HovedÅrsak]
End If

If Not IsNull(rs![Status Bestilling]) Then
.List(i, 7) = rs![Status Bestilling]
End If

If Not IsNull(rs![bestilling]) Then
.List(i, 8) = rs![bestilling]
End If

i = i + 1
rs.MoveNext
Loop
End With

'Close the recordset and the connection
rs.Close
sqlConnect.Close

'Set the recordset and connection values to nothing
Set rs = Nothing
Set sqlConnect = Nothing

End Sub


I would like tips on how to make my code more stable and faster. I am sure I am making tons of mistakes. Please point them out to me ;)

• How many current_conditions are you expecting to parse in the GetWeather function? If it's any more than one condition, the only information you'll see is that last one in the list and (probably) a stack of images (shapes) one on top of the other, with only the last one visible. Is this intended? Only displaying the last condition could save time if there's a long list of conditions. Additionally, you're missing worksheet references for all your Cells and Ranges in that sub. – PeterT Apr 17 '17 at 20:20
• It returns an XML file/string with the node <current_condition> that node has a bunch of child nodes f.eks <wind_speed_kmph>, <temperature_celcius>, and <wind_direction_degrees>. It updates a couple of these that I display on a worksheet along with a picture that is either a sun or a rain cloud etc. The sub updates the values to the current values, deletes the picture that is there and adds a new one(so that there are not a bunch of photos on top of eachother). – Thomas Apr 17 '17 at 21:00

I can't address your whole code at this time, however there are a few things I can help with.

First, Option Explicit goes outside of ALL procedures and declarations at the top of each module. In fact, it should be the very first line in the module. As the Best Practices documentation described, this will enforce the explicit declaration of all your variables.

Second, a declaration line such as this

Dim city, omraade As String


does NOT declare both city and omraade as String variables. What this translates to is

Dim city as Variant


Though it might seem to create "unnecessary" additional lines, this is the preferred way to declare variables because it makes it more obvious the specific type each variable is declared. When multiple variables are declared on a single line, it's harder to spot potential mis-types.

Next, in your Sub DeleteShapes, I would recommend a couple changes because this type of action could very easily be reused in many parts of your application (or even reused in a different application). In your case, you're calling this Sub from Worksheet_Activate, so you know exactly which worksheet is active. Your shape deleting function shouldn't have to assume which worksheet is the target, so pass it in as a parameter. Also, just to be clever and future-thinking, I would add an optional parameter in which you could specify which type of shape you want to delete (in case it might be different in the future).

Option Explicit   '---only once at the top of a module

Public Sub DeleteWorkSheetShapes(ws as Worksheet, Optional shapeType as MsoShapeType = msoAutoShape)
Dim delShape as Shape
for each delShape in ws.Shapes
If delShape.Type = shapeType Then
delShape.Delete
End If
Next delShape
End Sub


(Notice also that I prefer to expand my If statements for the same reason as separately declaring variables.)

UPDATE: additional comments for your GetWeather procedure.

1. It is considered good form to declare your variables closest to where they will be used. It makes it easier to remember the type of variable/object you're working with.
2. Use the MSXML2 objects for parsing the XML data. This is the latest version (the reference library is actually "Microsoft XML, v6.0").
3. I see that you likely copied the basic form of your procedure from this site, which is perfectly fine. However the techniques shown there are a little dated. Without having to loop through the list of current_condition nodes -- especially since there's only one -- you can specify exactly what data you want from that section by using the SelectSingleNode method. Notice that you have to fully qualify the XML path to the data value you're looking for. Also notice that in your original code, you've hard-coded the index to the ChildNode list. XML does not guarantee the order of the items in the data structure, so it's always safer to get the values by the node name.
4. I find it more maintainable to fix an "anchor" cell (called thisCell in your code) and reference other cells as offsets. This way it's easier to move the anchor cell around without having to change lots of other parameters.
5. Though my example below avoids the reference problem you have, notice in your original code that you have Cells(3, i).Value in several places. When you don't qualify the worksheet, VBA assumes you mean the ActiveSheet. It may be likely to work in your application, but you'd be surprised how many times your code can suddenly break and you won't know why. Establish a worksheet variable and make sure any cell references always call out where it's coming from, e.g. ws.Cells(3, i).
Sub GetWeather(apiURL As String, sted As String)
'--- request updated weather info from the website
Dim req As XMLHTTP
req.Open "GET", "" & apiURL & "", False
req.send

'--- transfer the website response into an XML object
Dim resp As MSXML2.DOMDocument

'--- sted identifies the columns for the weather results
Dim areaColumn As Long
Select Case sted
Case "Area1"
areaColumn = 4
Case "Area1"
areaColumn = 6
Case "Area1"
areaColumn = 8
Case Else
areaColumn = 4
End Select

Dim ws As Worksheet
Dim thisCell As Range
Set ws = ActiveSheet
Set thisCell = ws.Cells(2, areaColumn)

Dim wShape As Shape