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

Question

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 city, omraade As String
 Dim Req As New XMLHTTP
 Dim Weather As IXMLDOMNode
 Dim wShape As Shape
 Dim thisCell As Range
 Dim Resp As New DOMDocument
 i = 0
 omraade = ""
 omraade = sted
 Select Case omraade
 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
 Resp.LoadXML Req.responseText
 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 yourUserName As String
 Dim i, j, u As Integer
 Dim rs As ADODB.Recordset
 Dim sql As ADODB.Connection
 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.
 yourUserName = Application.userName
 'Create a new connection with sqlConnect and a new recordset with rs.
 Set sqlConnect = New ADODB.Connection
 Set rs = New ADODB.Recordset
 '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
 .AddItem
 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
 .AddItem
 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
 .AddItem
 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 ;)

• PeterT: 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.
• Thomas: 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).

Answer 1

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
Dim omraade as String

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
 resp.Load req.responseText
 '--- 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
 Set wShape = ws.Shapes.AddShape(msoShapeRectangle, _
 thisCell.Left, thisCell.Top, _
 thisCell.Width, thisCell.Height)
 wShape.Fill.UserPicture resp.SelectSingleNode("//data/current_condition/weatherIconUrl").Text
 thisCell.Offset(1, 0).Value = resp.SelectSingleNode("//data/current_condition/windspeedKmph").Text & " m/s"
 thisCell.Offset(2, 0).Value = resp.SelectSingleNode("//data/current_condition/winddirDegree").Text
 thisCell.Offset(3, 0).Value = resp.SelectSingleNode("//data/current_condition/observation_time").Text
End Sub

Some good references:

• A Beginner's Guide to the XML DOM
• WORKING WITH XML FILES IN VBA (VBA XML)
• From StackOverflow