MS Access Function : Automate Normalisation or De-concatenate a field (MS Outlook export example)

I was contemplating a better way of storing our old emails and unhappy with some of the systems in place I started considering whether I could dump them into a database.

Thing is when you export from Outlook some of the standard fields in particular To and From are concatenated. Wouldn’t it be nice to separate those fields into their own table of names and addresses and reference them back to a main table of messages.

This is what I came up with.

For demonstrations purposes I will use two tables

t001parent
pkid - autonumber primary key
ccaddresses - memo or long text

and the child table

t002newchildren
pkid - autonumber primary key
ccaddress - string(150 should do it)
pkidt001 - number

and here is the blank second table

Next we create a user defined function

Public Function CreateChildTable()

    Dim db          As DAO.Database
    Dim rs          As DAO.Recordset
    Dim rsTarget    As DAO.Recordset

    Dim strSQL      As String
    Dim strField1   As String
    Dim strField2   As String
    Dim varData     As Variant
    Dim i           As Integer
    Dim intPKID     As Integer

    Set db = CurrentDb

    'Select all the ccaddresses from the parent table
    strSQL = "SELECT pkid,ccaddresses FROM t001parent"

    Set rsTarget = db.OpenRecordset("t002newchildren", dbOpenDynaset, dbAppendOnly)

    Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
    With rs
        While Not .EOF
            intPKID = !pkid
            varData = Split(!ccaddresses, ";") ' Get all semi colon delimited fields
               
            'add email addresses if there is only one email address there
            With rsTarget
            .AddNew
            !ccaddresss = Trim(varData(0)) ' remove spaces before writing new fields
            !pkidt001 = intPKID
            .Update
            End With
            

            'loop through addtional email addresses and add them as children to table
            For i = 1 To UBound(varData)
                With rsTarget
                    .AddNew
                    !ccaddresss = Trim(varData(i)) ' remove spaces before writing new fields
                    !pkidt001 = intPKID
                    .Update
                End With
            Next
            .MoveNext
        Wend

        .Close
        rsTarget.Close

    End With

    Set rsTarget = Nothing
    Set rs = Nothing
    db.Close
    Set db = Nothing

End Function

After running this we should

We’ve just nicely split the parent table ccaddesses field into constituent emails and normalised it as a child of the parent table.

MS Access Function : Function to create SQL union queries

Another small function that can speed up the text required to be written for large union queries.

Typically this can be used with
MS Access Function : Scan through a directory and write list of files to a table.

There are a number of data providers that provide data files broken down into different geographical areas. In previous posts I have outlined how we can get these all into Postgis. But once they are in postgis (or any other database) you may wish to get these separate tables into one single global table. Clearly a union query will do this, however it can be time consuming to write the union query out as it simply has so many tables in it.

I used the code in the link to scan a directory and get all the filenames (in this case shape files of the UK road network) into a table that I called UKRoadLinks which had two fields PKID (primary long integer autonumber) and Filen text field where Filen were the filenames.

I then wrote the following function to write a text file that on completion will contain an sql union of all the tables listed in your recordset – I then copied and pasted this into Postgis database within which I had already imported all the sub tables to union the tables into a single copy. Alter the recordset source if for instance if you wish to use only a subset. The nice thing about this is if you have hundreds of tables to amalgamate there should be less likelyhood of you accidentally missing or misspelling table names.

Public Function createunionsqllinks()

Dim rst As DAO.Recordset
Set rst = CurrentDb.OpenRecordset("UKRoadLinks")

Dim fs, TextFile
Set fs = CreateObject("Scripting.FileSystemObject")
Set TextFile = fs.CreateTextFile("c:\data\sqlmerge.txt", True)
TextFile.WriteLine ("CREATE TABLE sqltomergetables AS ")
Do Until rst.EOF = True
TextFile.WriteLine (Chr$(40) & "select * from " & rst!Filen & Chr$(41) & " UNION ")
rst.MoveNext
Loop
rst.Close
TextFile.WriteLine (";")
TextFile.Close

MsgBox "Created"

End Function

MS Access Function : Print to excel spreadsheet field definitions of all tables in a database

This places all tables and fields into an excel file on a single worksheet as a single table.

Public Function TableDef()
Dim def As TableDef
Dim wb As Object
Dim xL As Object
Dim lngRow As Long
Dim f As Field
Set xL = CreateObject("Excel.Application")
xL.Visible = True
Set wb = xL.workbooks.Add
lngRow = 2
For Each def In CurrentDb.TableDefs
For Each f In def.Fields
With wb.sheets("Sheet1")
.Range("A" & lngRow).Value = def.Name
.Range("B" & lngRow).Value = f.Name
.Range("C" & lngRow).Value = f.Type
.Range("D" & lngRow).Value = f.Size
.Range("E" & lngRow).Value = f.Required
lngRow = lngRow + 1
End With
Next
Next
End Function

MS Access Function : Loop through tables and export to csv

A function that will loop through an access database and export all tables to csv and xls.

Useful for subsequent import through QGIS into Postgres.

Public Function ExportAll()
Dim obj As AccessObject, dbs As Object
Dim strFolder As String
strFolder = "c:\"
Set dbs = Application.CurrentData
For Each obj In dbs.AllTables
If Left(obj.Name, 4) <> "MSys" Then
DoCmd.TransferText acExportDelim, , obj.Name, strFolder & obj.Name & ".csv", True
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, obj.Name, strFolder & obj.Name & ".xls", True
End If
Next obj
End Function

MS Access Function CreateSimpleStrings()

A simple function that will loop through and create strings that add a number to a simple string. This string will then be used to create update queries. The same could be done in Excel or any other spreadsheet option but this stores the queries nicely and neatly into a table.

In this instance you want to have created a table called
T002ResidentialSearch

Which has the following fields
ResidentialString
Houses

Public Function CreateSimpleStrings()

Dim i As Integer
Dim rs As DAO.Recordset
Dim db As DAO.Database
Set db = CurrentDb

Set rs = db.OpenRecordset("T002ResidentialSearch")

For i = 2 To 100

With rs
rs.AddNew
rs!ResidentialString = "Erection of " &amp; i &amp; " houses"
rs!Houses = i
rs.Update
End With
Next i

rs.Close

MsgBox "Complete"

End Function

MS Access Function – import all CSV files from a directory with the same structure into a single table

This is a really nice function that can be used to place all data from multiple CSVs (with the same structure) into a single table.

Here I use the Ordnance Survey’s excellent Code Point data set that gives postcodes in the UK along with eastings and northings as an example – This lists each postcode in the UK along with further administrative categories. Apologies to anyone from outside of the UK that may not be able to access these files I hope the demonstration is still useful. For those wishing to try please follow the links.

After download you will see the problem each postcode is in a separate CSV.

Ordnance Survey Open Data Code Point UK Postcodes

After a short administration excercise to request a data download involving filling out your name you should be sent an email link to initiate a data download. The download consists of a zip file of two directories one named DOC one named DATA the DATA directory contains a subdirectory called CSV which at May 2018 for my download consisted of 120 csv files.

Opening a single file ( in this case Edinburgh EH ) we see

I’ve already figured this out here , but there are 10 fields here (some are blank in my example)

Here I create a table called T01CodePointCombined with 10 fields marked
F1 through to F10
Note if you don’t create the table this function is so powerful it will do it for you

I then create a module and ensure that all the CSV files I wish to import are in a single directory here “C:\Users\Mark\Documents\CodePoint\Data\CSV\”

Public Function ImportAllFiles()

        Dim strPathFile As String, strFile As String, strPath As String
        Dim strTable As String
        Dim blnHasFieldNames As Boolean

        ' Change this next line to True if the first row in csv file
        ' has field names
        blnHasFieldNames = False

        ' Replace C:\Users\Mark\Documents\CodePoint\Data\CSV\ with the real path to the folder that
        ' Now place the location of where the csvs are within the brackets below
        strPath = "C:\Users\Mark\Documents\CodePoint\Data\CSV\"

        ' Replace tablename with the real name of the table into which
        ' the data are to be imported
        strTable = "T01CodePointCombined"

        strFile = Dir(strPath & "*.csv")
        Do While Len(strFile) > 0
              strPathFile = strPath & strFile

              DoCmd.TransferText _
                TransferType:=acImportDelim, _
                TableName:=strTable, _
                filename:=strPathFile, _
                HasFieldNames:=blnHasFieldNames

        ' Uncomment out the next code step if you want to delete the
        ' csv file after it's been imported
        '       Kill strPathFile

              strFile = Dir()
        Loop

        MsgBox "Finished"

End Function

Points to note make sure all csv are closed when you run it. That’s about it takes less than 5 minutes to move all the records from those 120 files into a single table within an MS Access Database.
After import if it’s gone correctly you should have in the region of 1.7 million records in T01CodePointCombined.

MS Access Function – Scan through a directory and write list of files to a table

Pretty much as the title

Ensure you have a table called tblFiles with one field called Filename

Here I am finding all files in folderspec = “C:\Users\Mark\Documents\CodePoint\Data\CSV”

Alter as appropriate

Public Function ShowFolderList()
Dim fs, f, f1, fc, s
Dim rs As DAO.Recordset
Dim folderspec

Set rs = CurrentDb.OpenRecordset("tblFiles")

folderspec = "C:\Users\Mark\Documents\CodePoint\Data\CSV"

Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
Set fc = f.Files

For Each f1 In fc
    rs.AddNew
    rs.Fields("FileName") = f1.Name
    rs.Update
Next

Set rs = Nothing

MsgBox "Finished"

End Function

MS Access – Code Snippets for Navigating using Internet Explorer

Waiting for a web page to load

While ie.Busy
DoEvents
Wend

Selecting differing radio buttons

Dim ieRadio As Object
Set ieRadio = ie.Document.all
ieRadio.Item("datetype")(1).Checked = True

A function that can be used to delay action before an action in code (Not web specific). Here I set to 1 second

Public Function Await1()
Dim time1 As Variant
Dim time2 As Variant

time1 = Now
time2 = Now + TimeValue("0:00:01")
    Do Until time1 >= time2
        DoEvents
        time1 = Now()
    Loop

End Function

Split a string of text into a 1 dimensional array with splitting occurring at returns.

Dim strArray() as String
Dim strtoParse as String
Dim intCount as Long

'here I taken an imaginary recordset and set the string to parse from the text value in the recordset
strtoParse = rs!Text
strArray = Split(strtoParse, vbNewLine)

'a simple loop that will count the number of values in the array (1 dimensional)
For intcount = LBound(strArray) To UBound(strArray)
      MsgBox Trim(strArray(intCount))
   Next

Find a string in an array note the complete string needs to be found not a part within one of the array parts.

Private Function WhereInArray(vArrayName As Variant, vStringtoFind As String) As Variant
Dim i As Long
For i = LBound(vArrayName) To UBound(vArrayName)
    If vArrayName(i) = vStringtoFind Then
        WhereInArray = i
        Exit Function
    End If
Next i
'if you get here, vStringtoFind was not in the array. Set to null
WhereInArray = Null
End Function

Show whats in which Array cell – where n is a number equal to the value of a cell
So eg strArray(60) would show the value in 60th cell note arrays start from 0

MsgBox strArray(n)

Copy the HTML of a web page to a variable

my_StrVariable = ie.Document.body.innerHTML

Filter out much of the HTML formatting and only put inner text into a variable

my_StrVariable = ie.Document.body.innerText

Replace with spaces with less spaces till 2 and 3 spaces are replaced by 1 space

Function ThreeTwo(ByVal parmString As String) As String
    Dim strTemp As String
    strTemp = parmString

    Do Until InStr(strTemp, "   ") = 0
        strTemp = Replace(strTemp, "   ", " ")
    Loop

    Do Until InStr(strTemp, "  ") = 0
        strTemp = Replace(strTemp, "  ", " ")
    Loop
    ThreeTwo = strTemp
End Function

Click on a button if all you know is its class name

Dim e
Set e = ie.Document.getElementsByClassName("button primary")(0)
e.Click

Identify sites and how often they are visited
labpix.online/rounduptheusualsuspects.org
Look at any site
http://labpix.online

Take a look at the robots.txt of a site
https://www.theregister.co.uk/robots.txt

https://www.ebay.co.uk/robots.txt

MS Access Function Collection that can be used to Generate Housing Forecast Figures

Apologies if you are coming here for the first time. This post is a somewhat dense domain specific holding post for some work I did at the weekend to pull together some thoughts.

I was thinking that if I had a list of all sites in the UK I should be able to generate a phasing for each of them based on maybe the area of the site. This would automatically create a general housing land audit for any site that I should put in. I thought I’d try and see if I could write a set of functions that might generate phasing by site. Given that you can get an estimate of the housing boundaries from open street map and that you can get their area it would be possible to get an estimated number of houses per site which could then be used to phase. Going further if you were ever to know planning permission dates you could more accurately use this as a date from which to start phasing.

Ensure you have three tables
T01Sites (PKID, TotalNoHouses, DecisionDate)
T02HousePhasing (PKID, SiteFKID, Year, Completions)
T03 (PKID, TotalNoHouses, DecisionDate, YearofDecision, YearofStart, YearSpread)

T02 is the phasing child table of T01 and T03 is a holding table for a make table that will hold a randomised spread over which you wish to phase the total no of houses. It also randomly predicts when the housing will start on site.

And three queries

Q01 – Make Table Query

SELECT T01Sites.PKID, T01Sites.SiteName, T01Sites.TotalNoHouses, T01Sites.DecisionDate, Year([DecisionDate]) AS YearofDecision, CalculateintYearStartFULLPP([YearofDecision]) AS YearofStart, intYearSpread([TotalNoHouses]) AS YearSpread INTO T03
FROM T01Sites;

Q02 – Select Query

SELECT T03.PKID, T03.SiteName, T03.TotalNoHouses, T03.DecisionDate, T03.YearofStart, T03.YearSpread, Int(T03!TotalNoHouses/T03!YearSpread) AS PerYearSpread, [TotalNoHouses] Mod [YearSpread] AS Remainder
FROM T03
WHERE ((([TotalNoHouses] Mod [YearSpread])=0));

Q03 – Select Query

SELECT T03.PKID, T03.SiteName, T03.TotalNoHouses, T03.DecisionDate, T03.YearofStart, T03.YearSpread, Int(T03!TotalNoHouses/T03!YearSpread) AS PerYearSpread, [TotalNoHouses] Mod [YearSpread] AS Remainder
FROM T03
WHERE ((([TotalNoHouses] Mod [YearSpread])>0));

VBA Function list
The first function randomises the spread in years over which construction might happen on an individual housing site based on the total number of houses on the site.

Public Function intYearSpread(TotalNoHouses As Integer) As Integer

If TotalNoHouses < 2 Then

intYearSpread = 1

ElseIf TotalNoHouses = 2 Then

intYearSpread = Int((TotalNoHouses) * Rnd) + 1

ElseIf TotalNoHouses > 2 And TotalNoHouses < 9 Then

intYearSpread = Int((TotalNoHouses - 2 + 1) * Rnd + 1)

ElseIf TotalNoHouses >= 9 And TotalNoHouses <= 40 Then

intYearSpread = Int((4) * Rnd + 1)

ElseIf TotalNoHouses >= 41 And TotalNoHouses <= 80 Then

intYearSpread = Int((8 - 4 + 1) * Rnd + 4)

ElseIf TotalNoHouses >= 81 And TotalNoHouses <= 200 Then

intYearSpread = Int((8 - 4 + 1) * Rnd + 4)

ElseIf TotalNoHouses >= 201 And TotalNoHouses <= 400 Then

intYearSpread = Int((10 - 6 + 1) * Rnd + 6)

ElseIf TotalNoHouses >= 401 And TotalNoHouses <= 800 Then

intYearSpread = Int((12 - 8 + 1) * Rnd + 8)

Else

intYearSpread = Int((20 - 10 + 1) * Rnd + 10)

End If

'MsgBox intYearSpread

End Function

The first of the next three functions is used in the query to identify a year from which phasing on site will start. I wrote two further functions with the thought that in the future I could create a switch that would allow alternative site starts depending on whether a site has planning permission and depending on the type of planning permission. For example full planning permission would mean starting within three years of the granting of planning permission whereas outline would push it to between 3 and 6 years. A site with an LDP allocation would start further into the future.

Public Function CalculateintYearStartFULLPP(intDecisionDateYear As Integer) As Integer

CalculateintYearStartFULLPP = intDecisionDateYear + (Int((3 - 1 + 1) * Rnd + 1))

End Function

'Not used at present
Public Function CalculateintYearStartPPPP(intDecisionDateYear As Integer) As Integer

CalculateintYearStartPPPP = intDecisionDateYear + (Int((6 - 3 + 1) * Rnd + 3))

End Function

'Not used at present
Public Function CalculateintYearStartLDP(intDecisionDateYear As Integer) As Integer

CalculateintYearStartLDP = intDecisionDateYear + (Int((20 - 8 + 1) * Rnd + 8))

MsgBox CalculateintYearStartLDP

End Function

Function to create phasing IF housing IS perfectly divisible by Year Spread
GRH is an acronym for Generate Randomised Housing

Public Function GRHZero() As Variant

Dim db As DAO.Database
Dim rsSource As DAO.Recordset
Dim rsPhasing As DAO.Recordset
Dim intrsSourcePKID As Integer
Dim intrsSourceYearofStart As Integer
Dim intYearSpread As Integer
Dim intPerYearSpread As Integer
Dim i As Integer

Set db = CurrentDb()
Set rsSource = db.OpenRecordset("Q02")
Set rsPhasing = db.OpenRecordset("T02HousePhasing")

If Not (rsSource.EOF And rsSource.BOF) Then
'There are no records if End of File and Beginning of File are both true

rsSource.MoveFirst

Do Until rsSource.EOF = True

intrsSourcePKID = rsSource!PKID
intrsSourceYearofStart = rsSource!YearofStart
intYearSpread = rsSource!YearSpread
intPerYearSpread = rsSource!PerYearSpread

For i = 1 To intYearSpread

With rsPhasing
rsPhasing.AddNew
rsPhasing!SiteFKID = intrsSourcePKID
rsPhasing!Year = intrsSourceYearofStart
rsPhasing!Completions = intPerYearSpread
rsPhasing.Update
intrsSourceYearofStart = intrsSourceYearofStart + 1
End With

Next i

rsSource.MoveNext

Loop
Else
MsgBox "No Records"
Exit Function
End If

rsPhasing.Close
rsSource.Close

Set rsPhasing = Nothing
Set rsSource = Nothing

Set db = Nothing

End Function

Function to create phasing IF housing IS NOT perfectly divisible by Year Spread and a remainder is put on end

Public Function GRHRemainder() As Variant

Dim db As DAO.Database
Dim rsSource As DAO.Recordset
Dim rsPhasing As DAO.Recordset
Dim intrsSourcePKID As Integer
Dim intrsSourceYearofStart As Integer
Dim intYearSpread As Integer
Dim intPerYearSpread As Integer
Dim intRemainder As Integer
Dim i As Integer

Set db = CurrentDb()
Set rsSource = db.OpenRecordset("Q03")
Set rsPhasing = db.OpenRecordset("T02HousePhasing")

If Not (rsSource.EOF And rsSource.BOF) Then
'There are no records if End of File and Beginning of File are both true

rsSource.MoveFirst

Do Until rsSource.EOF = True

intrsSourcePKID = rsSource!PKID
intrsSourceYearofStart = rsSource!YearofStart
intYearSpread = rsSource!YearSpread
intPerYearSpread = rsSource!PerYearSpread
intRemainder = rsSource!Remainder

For i = 1 To intYearSpread

With rsPhasing
rsPhasing.AddNew
rsPhasing!SiteFKID = intrsSourcePKID
rsPhasing!Year = intrsSourceYearofStart
rsPhasing!Completions = intPerYearSpread
rsPhasing.Update
intrsSourceYearofStart = intrsSourceYearofStart + 1
End With

Next i

With rsPhasing
rsPhasing.AddNew
rsPhasing!SiteFKID = intrsSourcePKID
rsPhasing!Year = intrsSourceYearofStart
rsPhasing!Completions = intRemainder
rsPhasing.Update
intrsSourceYearofStart = intrsSourceYearofStart + 1
End With

rsSource.MoveNext

Loop
Else
MsgBox "No Records"
Exit Function
End If

rsPhasing.Close
rsSource.Close

Set rsPhasing = Nothing
Set rsSource = Nothing

Set db = Nothing

End Function

And the Script to run both the above functions

Public Function GeneratePhasingRecords()

Call GRHZero
Call GRHRemainder

MsgBox "Finished"

End Function

Navigate to Website directly from MS Access using Internet Explorer

One of the major suppliers of planning software to the United Kingdom is a company called Idox Group plc. They produce probably the most popular back office software that runs all aspects of administering planning permission. As such their public access web pages usually have the same fundamental structure. What if rather than holding information about a planning application you would like to create a command button that would take the user directly to the planning application details.

Unfortunately the url bears no relation to the planning application reference so it is necessary to go to a search page enter the planning application number and then trigger search which if you have a completely accurate planning reference will take you to the individual record. Here’s a function for City of Edinburgh Council complete with relevant application number. Previously I had achieved this using AHK but here is an elegant solution using VBA code. As ever there are multiple ways to achieve the same thing.

Public Function GotoWebPage()

Dim ie As Object
Dim strapplication As String

strapplication = "18/00488/TCO"
Set ie = CreateObject("Internetexplorer.application")

ie.Visible = True

ie.navigate "https://citydev-portal.edinburgh.gov.uk/idoxpa-web/search.do?action=simple&searchType=Application"

While ie.busy
DoEvents
Wend

ie.Document.getElementbyID("simpleSearchString").Value = strapplication

ie.Document.Forms(0).submit

End Function

And here’s one for City of London Council

Public Function GotoWebPageCityLondon()

Dim ie As Object
Dim strapplication As String

strapplication = "18/00152/FULEIA"
Set ie = CreateObject("Internetexplorer.application")

ie.Visible = True

ie.navigate "http://www.planning2.cityoflondon.gov.uk/online-applications/search.do?action=simple&searchType=Application"

While ie.busy
DoEvents
Wend

ie.Document.getElementbyID("simpleSearchString").Value = strapplication

ie.Document.Forms(0).submit

End Function

Further useful reading
How to Navigate IE using VBA

MS Access 2010 – Simple Function to loop through a list and Print to file an individual PDF

Had to move to MS Access 2010 to do this as no facility for direct to PDF print in MS Access 2003

Where the fields in the QUERY-ListofIDtoPrint includes ID / Field02 / Field03 / Field04

Public Function LoopandPrint()

Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim MyFileName As String
Dim mypath As String

mypath = "C:\Data\EXPORTdirectory\"

Set db = CurrentDb()
Set rs = db.OpenRecordset("QUERY-listofIDtoPrint")

Do While Not rs.EOF

MyFileName = rs!ID & "-" & rs!Field02 & "-" & rs!Field03 & "-" & rs!Filed04 & ".pdf"

'MsgBox MyFileName

DoCmd.OpenReport "R001TargetReport", acViewPreview, , "[PlanAppID]=" & rs!ID
DoCmd.OutputTo acOutputReport, "", acFormatPDF, mypath & MyFileName
DoCmd.Close acReport, "R001TargetReport"

rs.MoveNext
Loop

Set rs = Nothing
Set db = Nothing

End Function

MS Access – VBA Functions – Create Category Tag Junction Table by comparing a text field against a table of categories

Going forward there are more and more systems that have somewhat un-formated text or memo fields. It can be useful to tag fields. Here’s a collection of 2 functions with a script to pull them together designed to create a junction table.

What’s nice about it is that it could be used in lots of situations as a nightly process to tag manually input notes to help assist users navigate screeds of text.

This code is generalized and would need to be adapted for your specific table and field names

In mine you will need 4 tables
T001TableContainingFieldtobeCatetgorized – as per title it has a field called PKID and a field Called Text which is the memo field against which the SQL compares categories
T002Category – table that contains the categories that are compared against the text field
T003JunctionTable – the junction table that will contain the links between our notes table and the category table.
T004SQL – table to contain update queries – the field storing the strings is SQLstring – RunQueriesFromTable uses the SQLstring query and places the result in T003JunctionTable

The function RunQueriesFromTable is a previous function I wrote

Function CategorizeField()

'Make sure the name of the recordset is unambiguous
'Good practice to reference the actual library

Dim db As DAO.Database
Dim rs1 As DAO.Recordset
Dim rs2 As DAO.Recordset
Dim rs3 As DAO.Recordset
Dim SQLUpJunc As String
strQuote = Chr$(34)

Set db = CurrentDb
Set rs1 = db.OpenRecordset("SELECT * FROM T001TableContainingFieldtobeCategorized")
Set rs2 = db.OpenRecordset("T004SQL")
Set rs3 = db.OpenRecordset("T002Category")


'the data source can be a Table Name a query name or an sql string
'it would be possible to change the SQL to set to another set of records
'Check to see if there are any records in the set

If Not (rs3.EOF And rs3.BOF) Then
'there are no records if End of File and beginning of file are both true

rs3.MoveFirst

Do Until rs3.EOF = True

SQLUpJunc = "INSERT INTO T003JunctionTable ( FKIDT001, FKIDT002 ) SELECT T001TableContainingFieldtobeCategorized.PKID, " & rs3!PKID & " AS FKIDT002 FROM T001TableContainingFieldtobeCategorized WHERE (((T001TableContainingFieldtobeCategorized.Text) Like " & strQuote & "*" & rs3!Category & "*" & strQuote & "));"

With rs2
.AddNew
rs2!SQLstring = SQLUpJunc
rs2.Update
End With

rs3.MoveNext
Loop
Else
'MsgBox "No Records available for updating exit sub"
Exit Function
End If
'MsgBox "Looped through the records and updated table of SQL"

rs2.Close
Set rs1 = Nothing
Set rs2 = Nothing
Set rs3 = Nothing
Set db = Nothing


'remember to break an infinite loop press ctrl + break

End Function
Public Function RunQueriesFromTable(SQLSource As String)

DoCmd.SetWarnings False

Dim StartTime As Date
Dim EndTime As Date
Dim rstZ As DAO.Recordset
Dim strSQL As String

StartTime = Now()

Set rstZ = CurrentDb.OpenRecordset(SQLSource)

Do Until rstZ.EOF

strSQL = rstZ!SQLstring
DoCmd.RunSQL strSQL
rstZ.MoveNext

Loop

DoCmd.SetWarnings True

EndTime = Now()

'MsgBox "Finished ALL SQL queries! Process started at " & StartTime & " and finished at " & EndTime

End Function
Public Function CreateJunctionTable()

Call CategorizeField
Call RunQueriesFromTable("T004SQL")

MsgBox "Finished"



End Function

MS Access – SQL to Select Distinct list of Child Records based on a Maximum or Minimum Child Field Value

So we have a table of Stadiums and a table of attendances. We would like to create a query that shows an individual child record for each stadium of the highest attendances. Quite often you seek the latest or earliest child record by grouping on the primary key of the child record but what happens if you needing to identify a child not on the latest or earliest but on a value that does not correlate with the order in which the records have been created. In such a case the primary key can no longer act as a proxy for minimum or maximum value of the required field.

To demonstrate the problem and to illustrate it I create two tables

T01Stadium with the fields
PKID
Location

and

T02AttendanceGame with the fields
PKID
FKID
Attendance
GameDate
Date
Weather

and these are the example values I entered.

and here’s the code that shows the maximum attendance in the child records

SELECT *
FROM T02AttendanceGame AS G1 INNER JOIN [SELECT FKID, MAX(Attendance) AS HAttend FROM T02AttendanceGame GROUP BY FKID]. AS G2 ON (G1.Attendance=G2.HAttend) AND (G1.FKID=G2.FKID)
ORDER BY G1.FKID;

and here’s similar code that shows the latest games played at the two stadia

SELECT *
FROM T02AttendanceGame AS G1 INNER JOIN [SELECT FKID, MAX(GameDate) AS LatestDate FROM T02AttendanceGame GROUP BY FKID]. AS G2 ON (G1.GameDate=G2.LatestDate) AND (G1.FKID=G2.FKID)
ORDER BY G1.FKID;

This is yet another very valuable structure with which to reduce the complexity of data for users who are quickly seeking to find key values in a child table when that data is coming in out of synch with the order of data entry. Individuals wishing to use this code will need to enter the MS Access SQL editor and will need to be careful as the graphics designer cannot represent this syntax. I have tested this code with MS Access 2003 as the front end and SQL Azure as the backend and I can confirm that it does work. I have not extensively tested it.

VBA : Scripting in MS ACCESS to run multiple Queries consecutively

It can be necessary for many reasons to want to run queries consecutively without supervision. This was particularly necessary for me when I was doing a system transfer project. The production Oracle server was being used on a daily basis and we needed to transfer all the information across to a new system which initially was being run in parallel. Over several months myself and a colleague built up 500 queries that pulled out all of this information and placed it in a staging access database that was then loaded into a new Oracle backend. The queries didn’t just export the data they did a significant amount of transformation as the source and target databases had different structures. By being able to script the queries we had created we could take the information out of the source database at short notice. Generally in 2 hours. As we progressed further through the project we would get into the habit of running script of queries periodically as we saw fit.

Generally we did this by creating user defined functions that scripted the queries we wished to run.
This is an example of the format that we used for these functions.
DoCmd.SetWarnings False is important as without it you have to stay at your computer to hit annoying OK buttons

Public Function RunQueries()

DoCmd.SetWarnings False
DoCmd.OpenQuery ("Query01")
DoCmd.OpenQuery ("Query02")
DoCmd.SetWarnings True
MsgBox "Finished"

End Function

VBA Code : Run a Function and Link Functions together ( or Scripting in MS Access)

MS Access can be used as an extremely powerful scripting environment that can tie together manipulation of data using VBA functions and SQL.

Before you can really use this power however you need to know three things
1.Where to put functions
2.How to run them
3.How to string multiple functions together (or script them)

Here is a simple user defined function that we will use for demonstration purposes.

Public Function DisplayCompleteTime()
Dim X As Date
X = Now()
MsgBox "Finished Function at " & X
End Function

1.Where to put Functions?
There is more than one place to place functions. They can be placed in forms, in modules or in class modules. Here I describe how to place them in a module in a MS Access 2003 database called ScriptDatabase the menu path of how you get to the module section varies from Access version to access version but they are very very similar.

Open the Database window

Click on Module and then Click on New a new modal pop up screen should appear

Take your Function and place it in the module
I like to type Option Explicit at the start of every function.

Using the menus save the module – I saved my module prior to taking the snapshot of the screen – if you haven’t done this it will automatically ask you to save the module on exit.

2. Running a Function
OK so you have a function in a module which is saved but you want to run it.
Go back into the module with your function and navigate the menus View / Immediate Window.

How the immediate window displays is a bit unpredictable sometimes it comes up as a modal sometimes it is placed within the module screen and squeezes other sections out either way is should be a blank area with flashing cursor at the beginning.

Now to run your function or functions within the Immediate Window type a question mark followed by the function you wish to run in our case DisplayCompletionTime then simply press return

?DisplayCompleteTime

on return you should get something like this

Congratulations you can now run any function from the immediate window#

3. How to run multiple Functions consecutively

Do same as step 1 but this time type in the following

Public Function MultipleLinkedFunctions()

Call DisplayCompleteTime
Call DisplayCompleteTime
Call DisplayCompleteTime

End Function

as per 2 open the immediate window and then type in ?MultipleLinkedFunctions and press return.

Hitting return will display the complete time this is run three times because you are using a function that asks the function to display three times.

Congratulations you have just run a script in MS Access.

VBA Function to Create Table of Import strings using OGR2OGR targeting a SQL Server

Do you have many shape files you wish to import into a local SQL Server Database so that you can display them in QGIS or serve them on Geoserver?
Here’s a short function I wrote that will take a table called T0001OpenStreetMapLayers with fields PKID/Name/Directory/Type/Flag – and produce OGR strings that can then be used to load them into a local SQL Server / SQL Express or SQL Azure

For this to be useful you will need
A version of QGIS
A local SQL Server copy (in this case SQL Server Express)
A database within your copy called OpenStreetMap
All shape files in the same directory
You will also need to figure out how to get all those shape files into the table T0001OpenStreetMapLayers table
A starting database with 2 tables
T0001OpenStreetMapLayers with populated fields PKID/Name/Directory/Type/Flag
T0002OGRStrings blank table with fields PKID/CommandLine – This is where all the Command Line Strings will be stored

Public Function CreateTableOGR2OGRString()

Dim rs1 As DAO.Recordset
Dim rs2 As DAO.Recordset
Dim db As DAO.Database
Dim O2O As String
Dim LCounter As Integer
Dim strQuote As String
Set db = CurrentDb
strQuote = Chr$(34)


LCounter = 1
While LCounter < 3000
LCounter = LCounter < 3000

Set rs1 = CurrentDb.OpenRecordset("SELECT T0001OpenStreetMapLayers.PKID, T0001OpenStreetMapLayers.Name, T0001OpenStreetMapLayers.Directory, T0001OpenStreetMapLayers.Type, T0001OpenStreetMapLayers.Flag FROM T0001OpenStreetMapLayers WHERE (((T0001OpenStreetMapLayers.Type)=1) AND ((T0001OpenStreetMapLayers.Flag)=0 Or (T0001OpenStreetMapLayers.Flag) Is Null));")
O2O = "ogr2ogr -append -f MSSQLSpatial " & strQuote & "MSSQL:server=DESKTOP-JECT7QO\SQLEXPRESS;database=OpenStreetMap;trusted_connection=yes" & strQuote & " " & strQuote & rs1!Directory & rs1!Name & ".shp" & strQuote & ""


rs1.Edit
rs1!Flag = 1
rs1.Update
rs1.MoveNext
rs1.Close

Set rs2 = CurrentDb.OpenRecordset("T0002OGRStrings")
With rs2
.AddNew
rs2!CommandLine = O2O
rs2.Update
rs2.Close
End With
Wend
End Function

For SQL Azure target databases replace the yellow connection string with something resembling;

MSSQL:Server=tcp:azureinstance1.database.windows.net;Database=TouristDB1;
Uid=tom@azureinstance1.database.windows.net;Pwd=Edinburgh;

There are multiple methods of finding the name of your SQL Instance – Ignoring the fact that you won’t be able to connect to it if you don’t know it – Within SSMS you can right click on the instance and look to properties but the name itself is usually in the instance path of SSMS as well.

MS SQL Azure to MS Access – Using VBA to Dump Azure Tables into MS Access Tables

The first thing you need to get sorted when moving to SQL Azure is having the ability to get your information out and safe if needs be. When experimenting with MS Azure and for applications that don’t have sensitive information it is nice to have that information available in an easily accessible format. Here are a series of functions that will copy Azure Tables linked to database into local MS Access tables with the prefix ZCOPY.

The starting point in this should be an MS Access database that should be linked to your SQL Azure Database. Only those tables that are linked will be copied. Remember the 2GB limit on Access.

I think I have got all the functions here that are required to make it work and include the complete module at the bottom but first I will breakdown the modules and list describe what each of the functions do.

First create a table to store the list of tables in the Azure Database

Public Function CreateTableT0001AzureTablesGlobal()
 
     Dim dbs As Database
     Set dbs = CurrentDb
 
        dbs.Execute "CREATE TABLE T0001AzureTablesGlobal " _
        & "(PKID AUTOINCREMENT, " _
        & "AzureTableName CHAR CONSTRAINT PKID " _
        & "PRIMARY KEY);"
   
End Function

Now Create a Function that will hold the SQL that takes the tables and makes them locally.

Public Function CreateTableT0002SQL()
 
     Dim dbs As Database
     Set dbs = CurrentDb
 
        dbs.Execute "CREATE TABLE T0002SQL " _
        & "(PKID AUTOINCREMENT, " _
        & "SQL MEMO CONSTRAINT PKID " _
        & "PRIMARY KEY);"
 
   
End Function

A function that allows for stepping through the table

Public Function AddByteColumn(TblName As String, FieldName As String)
'Just use byte data type as only going to use this for a flag

DoCmd.RunSQL "AlTER TABLE [" & TblName & "] ADD COLUMN " & FieldName & " BYTE;"

End Function

Step through the Linked Azure Tables and poupulate table T001 with their names

Public Function CreateandPopulateListofDBOTableNames()

'These will typically be the names of the SQL Server tables this should work both with SQL Server and SQL Azure

Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim rstList As DAO.Recordset

'Call CreateTableT0001AzureTablesGlobal

Set rstList = CurrentDb.OpenRecordset("T0001AzureTablesGlobal")
Set db = CurrentDb

For Each tdf In db.TableDefs
    ' ignore system and temporary tables and tables starting with T - personal choice option
    If Not (tdf.Name Like "MSys*" Or tdf.Name Like "~*" Or tdf.Name Like "T*") Then
       With rstList
       .AddNew
       rstList!AzureTableName = tdf.Name
       rstList.Update
      End With
    End If
    
Next

Set tdf = Nothing
Set db = Nothing

End Function

The next function is required to strip out additional spaces in names

Public Function FindXReplaceY(FixTable As String, FixColumn As String, X As String, Y As String) As Variant

Dim strSQL As String

strSQL = "UPDATE [" & FixTable & "] SET [" & FixTable & "].[" & FixColumn & "] = REPLACE([" & FixColumn & "]," & Chr$(34) & X & Chr$(34) & "," & Chr$(34) & Y & """);"

DoCmd.RunSQL strSQL

End Function

We can now write the VBA that will write the make table SQL that once run will put one make table query into the maketableSQL table for each Azure table.

Public Function CreateMakeTableSQL()

On Error GoTo Err_CreateMakeTableSQL
Dim rstSQL As DAO.Recordset
Dim rstSQLx As DAO.Recordset
Dim dbc As DAO.Database
Dim SQLStringAdd As String
Dim LCounter As Long

Set dbc = CurrentDb

LCounter = 1
While LCounter < 9000
LCounter = LCounter + 1
Set rstSQL = CurrentDb.OpenRecordset("SELECT T0001AzureTablesGlobal.PKID, T0001AzureTablesGlobal.AzureTableName, T0001AzureTablesGlobal.XFLag1 FROM T0001AzureTablesGlobal WHERE (((T0001AzureTablesGlobal.XFLag1) Is Null));")

SQLStringAdd = "SELECT * INTO COPY" & rstSQL!AzureTableName & " FROM " & rstSQL!AzureTableName & ";"

Set rstSQLx = CurrentDb.OpenRecordset("T0002SQL")
With rstSQLx
.AddNew
rstSQLx!SQL = SQLStringAdd
rstSQLx.Update
rstSQLx.Close
End With

With rstSQL
rstSQL.Edit
rstSQL!XFLag1 = 1
rstSQL.Update
rstSQL.MoveNext
rstSQL.Close
End With

Wend

Exit_CreateMakeTableSQL:
    Exit Function

Err_CreateMakeTableSQL:
Select Case Err.Number
 Case 3021
   Resume Exit_CreateMakeTableSQL
  Case Else
  Resume Exit_CreateMakeTableSQL
  End Select
 
End Function

And finally Run all the queries

Public Function RunQueriesFromTable2(SQLSource As String)

DoCmd.SetWarnings False

Dim StartTime As Date
Dim EndTime As Date
Dim rstZ As DAO.Recordset
Dim strSQL2 As String

StartTime = Now()

Set rstZ = CurrentDb.OpenRecordset(SQLSource)

Do Until rstZ.EOF

strSQL2 = rstZ!SQL
DoCmd.RunSQL strSQL2
rstZ.MoveNext

Loop

DoCmd.SetWarnings True

EndTime = Now()

MsgBox "Finished ALL SQL queries! Process started at " & StartTime & " and finished at " & EndTime

End Function

And a script to pull all of this together

Public Function GetAzureScript()

DoCmd.SetWarnings False
Call CreateTableT0001AzureTablesGlobal
Call CreateandPopulateListofDBOTableNames
Call FindXReplaceY("T0001AzureTablesGlobal", "AzureTablename", " ", "")
Call FindXReplaceY("T0001AzureTablesGlobal", "AzureTablename", Chr(10), "")
Call AddByteColumn("T0001AzureTablesGlobal", "XFLag1")
Call CreateTableT0002SQL
Call CreateMakeTableSQL
Call FindXReplaceY("T0002SQL", "SQL", " ", "")
Call FindXReplaceY("T0002SQL", "SQL", Chr(10), "")
Call FindXReplaceY("T0002SQL", "SQL", "SELECT*INTOCOPY", "SELECT * INTO ZCOPY")
Call FindXReplaceY("T0002SQL", "SQL", "FROM", " FROM ")
Call RunQueriesFromTable("T0002SQL")
DoCmd.SetWarnings True

End Function

The complete module

Option Compare Database
Option Explicit

Public Function GetAzureScript()

DoCmd.SetWarnings False
Call CreateTableT0001AzureTablesGlobal
Call CreateandPopulateListofDBOTableNames
Call FindXReplaceY("T0001AzureTablesGlobal", "AzureTablename", " ", "")
Call FindXReplaceY("T0001AzureTablesGlobal", "AzureTablename", Chr(10), "")
Call AddByteColumn("T0001AzureTablesGlobal", "XFLag1")
Call CreateTableT0002SQL
Call CreateMakeTableSQL
Call FindXReplaceY("T0002SQL", "SQL", " ", "")
Call FindXReplaceY("T0002SQL", "SQL", Chr(10), "")
Call FindXReplaceY("T0002SQL", "SQL", "SELECT*INTOCOPY", "SELECT * INTO ZCOPY")
Call FindXReplaceY("T0002SQL", "SQL", "FROM", " FROM ")
Call RunQueriesFromTable2("T0002SQL")
DoCmd.SetWarnings True

End Function

Public Function CreateandPopulateListofDBOTableNames()

'These will typically be the names of the SQL Server tables this should work both with SQL Server and SQL Azure

Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim rstList As DAO.Recordset

'Call CreateTableT0001AzureTablesGlobal

Set rstList = CurrentDb.OpenRecordset("T0001AzureTablesGlobal")
Set db = CurrentDb

For Each tdf In db.TableDefs
    ' ignore system and temporary tables and tables starting with T - personal choice option
    If Not (tdf.Name Like "MSys*" Or tdf.Name Like "~*" Or tdf.Name Like "T*") Then
       With rstList
       .AddNew
       rstList!AzureTableName = tdf.Name
       rstList.Update
      End With
    End If
    
Next

Set tdf = Nothing
Set db = Nothing

End Function

Public Function FindXReplaceY(FixTable As String, FixColumn As String, X As String, Y As String) As Variant

Dim strSQL As String

strSQL = "UPDATE [" & FixTable & "] SET [" & FixTable & "].[" & FixColumn & "] = REPLACE([" & FixColumn & "]," & Chr$(34) & X & Chr$(34) & "," & Chr$(34) & Y & """);"

DoCmd.RunSQL strSQL

End Function

Public Function CreateTableT0001AzureTablesGlobal()
 
     Dim dbs As Database
     Set dbs = CurrentDb
 
        dbs.Execute "CREATE TABLE T0001AzureTablesGlobal " _
        & "(PKID AUTOINCREMENT, " _
        & "AzureTableName CHAR CONSTRAINT PKID " _
        & "PRIMARY KEY);"
 
   
End Function

Public Function CreateTableT0002SQL()
 
     Dim dbs As Database
     Set dbs = CurrentDb
 
        dbs.Execute "CREATE TABLE T0002SQL " _
        & "(PKID AUTOINCREMENT, " _
        & "SQL MEMO CONSTRAINT PKID " _
        & "PRIMARY KEY);"
 
   
End Function

Public Function AddByteColumn(TblName As String, FieldName As String)
'Just use byte data type as only going to use this for a flag

DoCmd.RunSQL "AlTER TABLE [" & TblName & "] ADD COLUMN " & FieldName & " BYTE;"

End Function

Public Function CreateMakeTableSQL()

On Error GoTo Err_CreateMakeTableSQL
Dim rstSQL As DAO.Recordset
Dim rstSQLx As DAO.Recordset
Dim dbc As DAO.Database
Dim SQLStringAdd As String
Dim LCounter As Long

Set dbc = CurrentDb

LCounter = 1
While LCounter < 9000
LCounter = LCounter + 1
Set rstSQL = CurrentDb.OpenRecordset("SELECT T0001AzureTablesGlobal.PKID, T0001AzureTablesGlobal.AzureTableName, T0001AzureTablesGlobal.XFLag1 FROM T0001AzureTablesGlobal WHERE (((T0001AzureTablesGlobal.XFLag1) Is Null));")
SQLStringAdd = "SELECT * INTO COPY" & rstSQL!AzureTableName & " FROM " & rstSQL!AzureTableName & ";"

Set rstSQLx = CurrentDb.OpenRecordset("T0002SQL")
With rstSQLx
.AddNew
rstSQLx!SQL = SQLStringAdd
rstSQLx.Update
rstSQLx.Close
End With

With rstSQL
rstSQL.Edit
rstSQL!XFLag1 = 1
rstSQL.Update
rstSQL.MoveNext
rstSQL.Close
End With

Wend

Exit_CreateMakeTableSQL:
    Exit Function

Err_CreateMakeTableSQL:
Select Case Err.Number
 Case 3021
   Resume Exit_CreateMakeTableSQL
  Case Else
  Resume Exit_CreateMakeTableSQL
  End Select
 
End Function

Public Function RunQueriesFromTable2(SQLSource As String)

DoCmd.SetWarnings False

Dim StartTime As Date
Dim EndTime As Date
Dim rstZ As DAO.Recordset
Dim strSQL2 As String

StartTime = Now()

Set rstZ = CurrentDb.OpenRecordset(SQLSource)

Do Until rstZ.EOF

strSQL2 = rstZ!SQL
DoCmd.RunSQL strSQL2
rstZ.MoveNext

Loop

DoCmd.SetWarnings True

EndTime = Now()

MsgBox "Finished ALL SQL queries! Process started at " & StartTime & " and finished at " & EndTime

End Function

MS Access VBA Function (Part 5) – Run SQL Queries from a table

Clearly there is a problem with generating 66,000 queries and ramming each of them into the Query Database Window. Yes you got it, an MS Access database can only hold circa 32,000 objects (32,768 to be exact). I had been writing the query definitions to the system query definition table and this was making an elegant but pointless alphabetically ordered telephone directory out of the query database window before bombing out at the database limit. Defining programmatically more and more queries to be written to the query definition window was a revolution that ended as quickly as it had begun. A maximum limit I had previously never hit in all of the databases I had ever created, I hit in 1 hour. But how to run query lists longer than 32,000? Do I really need to break everything into separate databases with each complying with the 32,000 object limit? I felt there must be a better solution.

Then it hit me – I shouldn’t write the queries to the database window. Keep the queries in a table and call the queries from a function. That way the queries aren’t considered as objects in your natural sense to MSAccess but are run as queries when triggered from VBA. That way the limit on objects in a single database is the limit of data I can hold in a table. By linking to other tables that limit may even approach 2GB. That’s enough queries to keep me going for quite some time.

This is what I came up with

Be warned running thousands of queries takes time you might need to run this overnight or over several days hence why I have included a start datetime and end datetime to be shown in the message box on completion it is interesting to see how long 100s or 1000s of queries take to run. My queries can now potentially perform trillions of calculations all unattended by me.

Now I just want to run lots and lots of queries!!!

Public Function RunQueriesFromTable(SQLSource As String)

DoCmd.SetWarnings False

Dim StartTime As Date
Dim EndTime As Date
Dim rstZ As DAO.Recordset
Dim strSQL As String

StartTime = Now()

Set rstZ = CurrentDb.OpenRecordset(SQLSource)

Do Until rstZ.EOF

strSQL = rstZ!SQL
DoCmd.RunSQL strSQL
rstZ.MoveNext

Loop

DoCmd.SetWarnings True

EndTime = Now()

MsgBox "Finished ALL SQL update queries! Process started at " & StartTime & " and finished at " & EndTime

End Function