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

Question

I have a program, that works, I just feel that it is running slower than it should and I feel that it is a bit more unstable than it should be. I am looking for tips on writing "better" code and making my program more stable.

I am looking to better this part of my code for now:

Private Sub Worksheet_Activate()
 Application.ScreenUpdating = False
 'Removes shapes already there that will be updated by the getWeather function
 For Each delShape In Shapes
 If delShape.Type = msoAutoShape Then delShape.Delete
 Next delShape
 'Calls a function to get weather data from a web service
 Call getWeather("", "Area1")
 Call getWeather("", "Area2")
 Call getWeather("", "Area3")
 'Starting to implement the first connection to a SQL Access database.
 Dim cn As Object
 Dim rs As Object
 'Set cn and sqlConnect as ADODB-objects. Set rs as recordset
 Set cn = CreateObject("ADODB.Connection")
 Set sqlConnect = New ADODB.Connection
 Set rs = CreateObject("ADODB.RecordSet")
 'Set sqlConnect as connection string
 sqlConnect.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\databases\database.accdb;Persist Security Info=False;"
 'Open connection string via connection object
 cn.Open sqlConnect
'Set rs.Activeconnection to cn
rs.ActiveConnection = cn
'Get a username from the application to be used further down
Brukernavn = Application.userName
'This part of the code re-arranges the date format from american to european
StartDate = Date
EndDate = Date - 7
midStartDate = Split(StartDate, ".")
midEndDate = Split(EndDate, ".")
StartDate2 = "" & midStartDate(1) & "/" & midStartDate(0) & "/" & midStartDate(2) & ""
EndDate2 = "" & midEndDate(1) & "/" & midEndDate(0) & "/" & midEndDate(2) & ""
'SQL statement to get data from the access database
rs.Open "SELECT [RefNr], [Registrert Av],[Nettstasjon], [Meldt Dato] , [Bestilling], [Sekundærstasjon], [Avgang], [Hovedkomponent], [HovedÅrsak], [Status Bestilling] FROM [tblDatabase]" & _
"WHERE [Registrert Av] = '" & Brukernavn & "' AND [Loggtype] <> 'Beskjed' AND [Meldt Dato] BETWEEN #" & StartDate2 & "# AND # " & EndDate2 & "#" & _
"ORDER BY [Meldt Dato] DESC;", _
 cn, adOpenStatic
'Start to insert data from access database into a list
Dim i As Integer
Dim u As Integer
If Not rs.EOF Then
 rs.MoveFirst
End If
i = 0
With lst_SisteFeil
 .Clear
 Do
 If Not rs.EOF Then
 .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
 Else
 GoTo endOfFile
 End If
 Loop Until rs.EOF
End With
endOfFile:
rs.Close
cn.Close
Set rs = Nothing
Set cn = Nothing
'Starts to connect to SQL access database again to get different set of data. This must be possible to make more efficient?
Dim cn2 As Object
Dim rs2 As Object
'Set cn and sqlConnect as ADODB-objects. Set rs as recordset
Set cn2 = CreateObject("ADODB.Connection")
Set sqlConnect2 = New ADODB.Connection
Set rs2 = CreateObject("ADODB.RecordSet")
'Set sqlConnect as connection string
sqlConnect2.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\databases\database.accdb;Persist Security Info=False;"
'Open connection string via connection object
cn2.Open sqlConnect
'Set rs.Activeconnection to cn
rs2.ActiveConnection = cn2
'Second SQL statement
rs2.Open "SELECT [RefNr], [Registrert Av],[Nettstasjon], [Meldt Dato] , [Bestilling], [Sekundærstasjon], [Avgang], [Hovedkomponent], [HovedÅrsak], [Status Bestilling] FROM [tblDatabase]" & _
"WHERE [Registrert Av] <> '" & Brukernavn & "' AND [Meldt Dato] BETWEEN #" & StartDate2 & "# AND # " & EndDate2 & "#" & _
"ORDER BY [Meldt Dato] DESC;", _
 cn2, adOpenStatic
'Inserting into second list
If Not rs2.EOF Then
 rs2.MoveFirst
End If
u = 0
With lst_AlleFeil
 .Clear
 Do
 If Not rs2.EOF Then
 .AddItem
 If Not IsNull(rs2!refnr) Then
 .List(u, 0) = rs2![refnr]
 End If
 If IsDate(rs2![Meldt Dato]) Then
 .List(u, 1) = Format(rs2![Meldt Dato], "dd/mm/yy")
 End If
 .List(u, 4) = rs2![nettstasjon]
 If Not IsNull(rs2![Sekundærstasjon]) Then
 .List(u, 2) = rs2![Sekundærstasjon]
 End If
 If Not IsNull(rs2![Avgang]) Then
 .List(u, 3) = rs2![Avgang]
 End If
 If Not IsNull(rs2![Hovedkomponent]) Then
 .List(u, 5) = rs2![Hovedkomponent]
 End If
 If Not IsNull(rs2![HovedÅrsak]) Then
 .List(u, 6) = rs2![HovedÅrsak]
 End If
 If Not IsNull(rs2![Status Bestilling]) Then
 .List(u, 7) = rs2![Status Bestilling]
 End If
 If Not IsNull(rs2![bestilling]) Then
 .List(u, 8) = rs2![bestilling]
 End If
 u = u + 1
 rs2.MoveNext
 Else
 GoTo endOfFile2
 End If
 Loop Until rs2.EOF
End With
endOfFile2:
rs2.Close
cn2.Close
Set rs2 = Nothing
Set cn2 = Nothing
'Starting to connect to the database for the third time
Dim cn3 As Object
Dim rs3 As Object
'Set cn and sqlConnect as ADODB-objects. Set rs as recordset
Set cn3 = CreateObject("ADODB.Connection")
Set sqlConnect3 = New ADODB.Connection
Set rs3 = CreateObject("ADODB.RecordSet")
'Set sqlConnect as connection string
sqlConnect3.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=c:\databases\database.accdb;Persist Security Info=False;"
'Open connection string via connection object
cn3.Open sqlConnect
'Set rs.Activeconnection to cn
rs3.ActiveConnection = cn3
'third sql statement
rs3.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;", _
 cn3, adOpenStatic
'Inserting data in to third list
If Not rs3.EOF Then
 rs3.MoveFirst
End If
j = 0
With lst_beskjeder
 .Clear
 Do
 If Not rs3.EOF Then
 .AddItem
 If Not IsNull(rs3!refnr) Then
 .List(j, 0) = rs3![refnr]
 End If
 If IsDate(rs3![Meldt Dato]) Then
 .List(j, 1) = Format(rs3![Meldt Dato], "dd/mm/yy")
 End If
 .List(j, 4) = rs3![nettstasjon]
 If Not IsNull(rs3![Sekundærstasjon]) Then
 .List(j, 2) = rs3![Sekundærstasjon]
 End If
 If Not IsNull(rs3![Avgang]) Then
 .List(j, 3) = rs3![Avgang]
 End If
 If Not IsNull(rs3![beskrivelse]) Then
 .List(j, 5) = rs3![beskrivelse]
 End If
 j = j + 1
 rs3.MoveNext
 Else
 GoTo endOfFile3
 End If
 Loop Until rs3.EOF
End With
endOfFile3:
rs3.Close
cn3.Close
Set rs3 = Nothing
Set cn3 = Nothing
End Sub

Here is the function I have used to get weather data.

Public Sub getWeather(APIurl As String, sted As String)
Dim i As Integer
i = 0
Dim omraade As String
omraade = ""
omraade = sted
If sted = "Area1" Then
 i = 4
ElseIf sted = "Area2" Then
 i = 6
ElseIf sted = "Area3" Then
 i = 8
End If
Dim WS As Worksheet: Set WS = ActiveSheet
Dim delShape As Shape
Dim city As String
Dim Req As New XMLHTTP
Req.Open "GET", "" & APIurl & "", False
Req.Send
Dim Resp As New DOMDocument
Resp.LoadXML Req.responseText
Dim Weather As IXMLDOMNode
Dim wShape As Shape
Dim thisCell As Range
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

Feel free to point out any poor coding and tips on how to improve it. I am currently using the Worksheet Activate sub to activate changes in the tables and get new data, but I suspect that is not the best solution. I am just not sure how else to do it seeing as I want it to be as "automatic" as possible, and use as few buttons to refresh as I can.

• barrowc: DOMDocument and XMLHTTP are always synonyms for the versions which shipped with MSXML2, v3.0 and could instead be written as DOMDocument30 and XMLHTTP30. If you are using MSXML2, v6.0 then use DOMDocument60 and XMLHTTP60 instead - see here for details

Answer 1

Worksheet_Activate is doing waaaay too many things. It's an entry point, so the abstraction level should be fairly high. Something like this:

Private Sub Worksheet_Activate() 
 RemoveExistingWeatherShapes
 UpdateWeatherData
 UpdateFoobarData 'whatever the Access queries do
End Sub

There's a lot to cover, so I'll just grab the low-hanging fruit here:

• Indentation isn't always consistent.
• Procedure names should be PascalCase
• Call keyword is not needed to make a procedure call; it's obsolete/deprecated.

• This chunk is locale-dependent; it involves implicit string conversions and will fail to run on a machine that is configured to use a different date format:

  StartDate = Date
  EndDate = Date - 7
  midStartDate = Split(StartDate, ".")
  midEndDate = Split(EndDate, ".")
  StartDate2 = "" & midStartDate(1) & "/" & midStartDate(0) & "/" & midStartDate(2) & ""
  EndDate2 = "" & midEndDate(1) & "/" & midEndDate(0) & "/" & midEndDate(2) & ""
  

  It's not clear why the end date would be a week before the start date: a comment is required here, to explain that. Otherwise, it looks like a bug (or is it one?).

  It's not clear where or whether the variables are declared at all. If they're declared, their scope needs to be reduced and their declaration belongs inside the procedure they're used in. If they're not declared, declare them. All. And put Option Explicit at the top of every single module, so that VBA refuses to compile code that doesn't declare its variables. Without it, you're asking for trouble, since VBA will happily compile and run code with typos.

  Declared or not, StartDate and EndDate are both assigned a Date value, so at that point they're Date variables (or Variant/Date if undeclared). This means everything else is treating dates as strings, and that's very frail and bug-prone. Use the Year, Month and Day functions to retrieve the year, month and day parts of a Date value, respectively; that Split thing is not going to work on a workstation that uses / to separate date parts.

  Watch the naming, too: midStartDate means nothing. StartDate2 is unclear. Consider startDateParts and formattedStartDate, respectively (although, as noted above, midStartDate and midEndDate should probably be removed anyway).

• Comments should say why, not what. Consider extracting "chunks of code" under a "this chunk does XYZ" comment, into their own procedures.

• You're referencing the ADODB type library, so you don't need late-binding.

   Dim cn As Object
   Set cn = CreateObject("ADODB.Connection")
   Set sqlConnect = New ADODB.Connection
   Dim rs As Object
   Set rs = CreateObject("ADODB.RecordSet")
  

  Instead of declaring your cn As Object, declare cn As ADODB.Connection, and then do the same for rs As Object, which should be rs As ADODB.Recordset. You'll get IntelliSense/auto-complete for all member calls, and you'll reduce runtime overhead. Don't use CreateObject when you can New things up directly.

  It's not clear why you need two ADODB.Connection objects. You use one and assign its connection string, and then never open it; instead you do this:

  cn.Open sqlConnect
  

  That's implicitly doing this:

  cn.Open sqlConnect.ConnectionString
  

  Might as well just do:

  sqlConnect.Open
  

  And work off sqlConnect then: both cn and sqlConnect are the same type, and have the same connection string: one of them is superfluous.

  You have this pattern thrice in your code, using 3 connections to the same database. You could remove the 2nd and 3rd connections, and reuse the connection for the other 2 queries, reducing connection overhead.

• This is redundant:

  If Not rs.EOF Then
   rs.MoveFirst
  End If
  

• This EOF check is redundant...

  Do
   If Not rs.EOF Then
  

  ...but only because you've made it a Do loop, which ensures at least 1 iteration. Flip it around, put the condition at the top:

  Do While Not rs.EOF
   'loop body
  Loop
  

  Doing that removes a whole indentation level, a GoTo jump and a line label.

Your query uses Application.UserName, but Application.UserName can be written to by anyone and can contain anything: as far as your code is concerned, it should be considered user input, and treated as such.

Consider what would happen if a user executed this:

Application.UserName = "Bob'; DROP TABLE tblDatabase --"

And then ran your macro.

rs.Open "SELECT [RefNr], [Registrert Av],[Nettstasjon], [Meldt Dato] , [Bestilling], [Sekundærstasjon], [Avgang], [Hovedkomponent], [HovedÅrsak], [Status Bestilling] FROM [tblDatabase]" & _
"WHERE [Registrert Av] = '" & Brukernavn & "' AND [Loggtype] <> 'Beskjed' AND [Meldt Dato] BETWEEN #" & StartDate2 & "# AND # " & EndDate2 & "#" & _
"ORDER BY [Meldt Dato] DESC;", _
 cn, adOpenStatic

When the above instruction hits the database, it looks something like this:

 SELECT [RefNr], [Registrert Av],[Nettstasjon], [Meldt Dato] , [Bestilling], [Sekundærstasjon], [Avgang], [Hovedkomponent], [HovedÅrsak], [Status Bestilling] 
 FROM [tblDatabase]
 WHERE [Registrert Av] = 'Bob'; DROP TABLE tblDatabase --' anything beyond this is commented-out

That's called SQL Injection, and it's a serious security issue. If you think it's not (because "I trust my users won't even try to do that"), then consider what's going to happen when Brian O'Connor tries to run your macro.

The solution is to use parameterized queries. See this post for more information about how to do this with ADODB.

---

There's a ton more to say about this code, but I'll stop this answer here for now.

• Mathieu Guindon: Comments are not for extended discussion; this conversation has been moved to chat.
• Thomas: Can you expand on the connection to the access database? I have Dim cn as ADODB.Connection and Dim rs as ADODB.Recordset, but I dont understand what I should "replace" Set cn = CreateObject("ADODB.Connection") and Set rs = CreateaObject("ADODB.RecordSet") with.
• Mathieu Guindon: @Thomas Set foo = New ADODB.Connection. And declare as such (not As Object).
• Thomas: Ah, thank you for the help. I have updated my code now, if you feel like looking over it again :)
• Mathieu Guindon: @Thomas that edit invalidated the answers, it had to be rolled back. If you want feedback on the updated code, feel free to ask a new question. See help/someone-answers for all available options.

Answer 2

It's difficult to really evaluate the performance of your code without a connection to your database, but there are some efficiencies you can use which may streamline the processing.

Some general Very Good Practices that are highly reccommended are:

1. Always Use Option Explicit. This is just a good habit and should really be required.
2. Always define and set references to all Workbooks and Sheets. This even includes the code within your Worksheet_Activate function. As a habit, you can follow your own code more easily and it's more easily portable to other functions. Plus, it can be very easy to mistake (assume) which WorkSheet you're referring to when the code is directing you to another.
3. Break up your code into smaller, logical blocks. This will make the main processing code read more compact as well as forcing you to have defined sets of data that now logically (and cleanly) pass from section to section.

So with those basics in mind, here are comments starting with your getWeather method:

You are wanting to restrict the caller to a specific place with the sted parameter. So enforce that restriction with a custom Type:

Enum Sted
 Area1 = 4
 Area2 = 6
 Area3 = 8
End Type

Which changes the Sub declaration to

Public Sub getWeather(APIurl As String, place As Sted)

Then you can delete the If statement that sets up the internal value and always rely on the input parameter to be valid. It looks like the code creating the Shapes in this method is overwriting the information in the same Cells for all Weather. If that's not your intention, then the logic needs re-examining.

In the WorkSheet_Activate function, there are a few items to note:

When moving through a Recordset, it's a good habit to check for the end of the set using If Not(rs.BOF And rs.EOF) Then. Your code potentially gives an error if the Recordset is empty. This If statement will make sure to handle that instance as well. Additionally, to jump out of the loop (as in your Else block), simply write Exit Do. You can eliminate the endOfFile label and GoTo.

While these suggestions are not necessarily speed improvements, they will benefit your overall code clarity.

• Mathieu Guindon: An enum is really just a Long with makeup; nothing is stopping the caller from passing 3 or 42 or -250, so enum parameters should be handled in a Select Case block that includes an Else case that bails out (e.g. Err.Raise 5)... IOW the benefits of an enum mostly rely on the IDE providing intellisense and making it easier for the caller to provide a valid value with a meaningful identifier, but in strict language terms it doesn't enforce a valid value at all.