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 ;)

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