MS Access VBA Function (Part 3) Address Matching – Find X Replace Y

A useful function for replacing characters or strings in a single field. This can be used in advance of address matching to increase the chances of getting matches in fields that have been collected through a UI with little or no validation.

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

And this is an example script that calls the above function to replace some special characters

Public Function RunFindXReplaceY()

DoCmd.SetWarnings False

    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "'", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "@", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "~", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "#", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "!", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "£", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "$", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "^", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "&", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "*", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "(", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", ")", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "-", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "+", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "=", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "?", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "|", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "\", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "/", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "{", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "}", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "[", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "]", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "`", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "¬", " ")

DoCmd.SetWarnings True

End Function

MS Access VBA Functions (Part 2) Address Matching – UK Postcode String Finder

UK Postcode extractor

Function GetPostCode(Optional AddressText As Variant) As String
Dim AddrTextLength As Integer, TempText As String, TempPicture As String
Dim PostCodePics(10) As String, PictureItemNum As Integer
Dim n As Integer, x As Integer

GetPostCode = "" ' default response if no postcode detected
If IsNull(AddressText) Then
Exit Function
End If

PostCodePics(1) = "XXNSNXX" ' alternative formats of postcodes
PostCodePics(2) = "XXNNSNXX" ' where X = alpha, S = space
PostCodePics(3) = "XNNSNXX" ' and N = numeric
PostCodePics(4) = "XNSNXX"
PostCodePics(5) = "XXNNXX"
PostCodePics(6) = "XXNNNXX"
PostCodePics(7) = "XNNNXX"
PostCodePics(8) = "XNNXX"
PostCodePics(9) = "XXNXNXX"
PostCodePics(10) = "XXNXSNXX"

AddrTextLength = Len(AddressText)

If AddrTextLength < 5 Then
Exit Function
End If
If AddrTextLength <= 9 Then
TempText = Trim(AddressText)
Else
TempText = Trim(Right(AddressText, 9))
End If

PictureItemNum = 0
TempPicture = "" ' build a picture of the format of current text
For n = 1 To Len(TempText) ' detect the type of each character
x = InStr(1, "1234567890 ", Mid(TempText, n, 1))
If x > 0 And x < 11 Then TempPicture = TempPicture & "N"
If x = 11 Then TempPicture = TempPicture & "S"
If x = 0 Then TempPicture = TempPicture & "X"
Next

For n = 1 To 10 ' compare the format of the current text
x = Len(PostCodePics(n)) ' against each of the post code pictures
If Len(TempPicture) >= x Then
If Right(TempPicture, x) = PostCodePics(n) Then
PictureItemNum = n
GetPostCode = UCase(Right(TempText, x))
Exit For
End If
End If
Next

If PictureItemNum > 4 And PictureItemNum < 10 Then ' insert space in the middle if not present
GetPostCode = Left(GetPostCode, Len(GetPostCode) - 3) & " " & Right(GetPostCode, 3)
End If

End Function

MS Access VBA Functions (Part 1) Address Matching – Add and Drop Fields

Here are a series of Functions that can be used to help in matching addresses between a dataset that is good (eg Assessors Street File) and a dataset that could be improved – eg a Customer Relationship Management System.

ADD and DROP Fields

Function AddCharColumn(TblName As String, FieldName As String)

DoCmd.RunSQL "AlTER TABLE [" & TblName & "] ADD COLUMN " & FieldName & " CHAR(100);"

End Function

Function AddIntegerColumn(TblName As String, FieldName As String)

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

End Function

Function AddDoubleColumn(TblName As String, FieldName As String)

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

End Function

Function DropColumn(TblName As String, FieldName As String) As Variant

DoCmd.RunSQL "ALTER TABLE [" & TblName & "] DROP COLUMN " & FieldName & ";"

End Function

MS Access VBA Function – create UID starting at prescribed number

Useful function if you are taking two tables with overlapping identity key to be placed in a table that will have a further child record and you wish to separate the new keys.

Public Function WriteUID(LCounter As Long) As Long
 
Dim rstC As DAO.Recordset
Dim LCountStart As Double
 
LCountStart = LCounter
 
Set rstC = CurrentDb.OpenRecordset("TABLEREQUIRINGUNIQUEID")
 
Do Until rstC.EOF = True
 
rstC.Edit
rstC!UID = LCounter
rstC.Update
 
LCounter = LCounter + 1
 
rstC.MoveNext
 
Loop

MsgBox "Finished UNIQUEID write"
 
End Function

MS Access VBA Function – Loop through Query Objects and write SQL to Table

Continuing the theme of tools that assist the use of MS Access as a platform for transferring data between systems. Here is a small function that will allow you to write the pure SQL syntax of all queries in a database to a table. I personally used this in a system transfer project. The business had given us something called a field mapping plan that identified the table and fields in one system and where they were to be migrated in the other system. Having written the queries I then wanted to go back through and reconcile the original mapping to the SQL to ensure that absolutely every field had been taken across. Writing the SQL into a table allows for table and field combinations to be methodically searched. Quite useful.

Create a table called T001SQLCollection with at least 2 fields – QueryName and SQL. This is where the recordset writes the SQL to.

This is very much a reverse of the previous post function.

Public Function ListQueries()
 
Dim rstList As DAO.Recordset
 
    Dim i As Integer
        For i = 0 To CurrentDb.QueryDefs.Count - 1
        Set rstList = CurrentDb.OpenRecordset("T001SQLCollection")
        With rstList
            .AddNew
            rstList!QueryName = CurrentDb.QueryDefs(i).Name
            rstList!SQL = CurrentDb.QueryDefs(i).SQL
            rstList.Update
        End With
    Next i
   
    rstList.Close   
 
MsgBox "Finished"
 
End Function

MS Access VBA Function – Automated Multiple Query Object Creation from previously created table of SQL

This completes the task of taking automatically generated SQL previously placed in a table and writes the SQL therein to Query Objects naming them automatically. This has several advantages to cut and paste –

1) Its Lightning Quick
2) Completely consistent naming
3) Cut and Paste can be awkward with the windows
4) Its just fun

To created the NestedIIfs table see this post

MS Access VBA Function – Creating NestedIIFs

This is the post on writing Query Objects directly

MS Access – Automated Single Query Object Creation

It requires that you have a table called T005NestedIIFs
with the populated fields
SQLField
TargTable
TargField

Public Function WriteNIFQueryObjects(LCounter As Long) As String

Dim rstX As DAO.Recordset
Dim QName As String
Dim qdf As Variant
Dim strSQL As String
Dim LCountStart As Long

LCountStart = LCounter

Set rstX = CurrentDb.OpenRecordset("T005NestedIIFs")

Do Until rstX.EOF = True
qdf = rstX!SQLField
QName = "Q" & LCounter & rstX!TargTable & "-" & rstX!Targfield & "-Update"
LCounter = LCounter + 1
Set qdf = CurrentDb.CreateQueryDef(QName, rstX!SQLField)

rstX.MoveNext

Loop

MsgBox "Query objects written to Database numbers starting" & LCountStart

End Function

MS Access VBA Function – Create MS Access Query Object – more automation :)

In line with my general theme of automation here’s the framework of a tiny but potentially very useful function to create queries in the current database, linking this in with the loop queries and say something like the nested IF generation function could allow you to take your table of nested queries and write them to the database.

Public Function CreateQuery()

Dim strSQL As String
Dim qdf As Variant

strSQL = "SELECT * FROM T01Contacts"

Set qdf = CurrentDb.CreateQueryDef("GeneratedQuery", strSQL)
MsgBox "GeneratedQuery Created!"

End Function

I like!

Compact Database automatically using this MS Access Function and VB Script

If like me you sometimes need to run multiple SQL statements in MS Access on a regular basis maybe at a particular time some of which are deletes, you will need to find a way to automate regular compacts. Here’s some code scavenged from the interweb that will allow you to do this.

Firstly create the following function in your target MS Access database.

Public Function CompactDatabase()
      Dim vStatusBar As Variant
      DoCmd.SetWarnings False
            
          If FileLen(CurrentDb.Name) > 2000000 Then
              Application.SetOption ("Auto Compact"), 1
              Application.SetOption "Show Status Bar", True
              vStatusBar = SysCmd(acSysCmdSetStatus, "The application will be compacted on close during compaction please do not interrupt")
          Else
              Application.SetOption ("Auto Compact"), 0
          End If
                
End Function

Next open up notepad paste in the following code save it as a txt file and then in explorer edit the suffix to vbs. Then simply double click on the file within explorer to run it. You should see the access database you have identified in the VB script open and then immediately close at which point it carries out the compact. The eagle eyed will have spotted that the above function doesn’t actually perform a compact. All it does is set the compact on close option to True within Access settings. The VB Script then instructs the database to close and Access compacts the database on exit.

set oAccess = createobject("Access.Application")

oAccess.OpenCurrentDatabase "C:Path\TargetDatabaseyouwantCompacted.mdb"
oAccess.visible = true
wscript.sleep 1000
oAccess.Run "CompactDatabase"
oAccess.closecurrentdatabase

set oAccess = nothing

A VB script such as this could be used to remotely run any MS Access function or functions – simply substitute the “CompactDatabase” parameter (or add further run commands) with the name(s) of the function(s) in the database you wish to trigger and then run the VB Script. Be warned the speed at which functions and commands within functions run may vary when called from a vbscript so you may have to use some experimentation to input things like pauses and waits if you start to get very imaginative with the functions run.

MS Access VBA Function – Generate Multiple Nested IIF SQL statements into table with parameter to set Number of Nestings

So in my previous post I had looked at generating single SQL Nested IF statements using MS Access but had highlighted that Access will error out indicating the SQL is too complex should there be more than 13 nested IIFs in a single SQL.

What happens if you have 20 values that you require to be changed.
Answer = you pick 13 and produce one sql statement with 13 nested if statements and another with 7 nested IIF statements.

But damn it,doesn’t that introduces yet another manual step to what was supposed to be automation. Yes it does this is why I wrote this function which allows you to define the number of nestings and will go off and write the appropriate number. And yes I hear you DBAs saying a better way would be to link in the conversion table at the beginning – absolutely but there may be occasions where you can’t link to the required database.

The following iterates through a conversion table and writes the resulting SQL into a table named T005NestedIIFs – it should be noted that the Wend statement is artificially optomised here and if you have an extremely large code conversion table you may need to work on this code to make it dynamically alter the number of WEND statements depending on the BatchFileNo you wish to create and its relation to the number of records in the conversion table. The below code goes to the last record as part of the recordset count and when at 0 will jump to exit so for smaller code conversions its semi-dynamic but for larger files the limit of values converted with be the BatchFileSize * 200 which may or may not be big enough for purpose.

To have this working you will need two tables and knowledge of a third.
T001ConversionCodeTable
This should have 5 fields
OldValue
NewValue
xFlag1
xFlag2
xFlag3

The flag fields only require a single integer value. They are used to record how far through the conversion table you have reached so that when you break from your SQL query you resume at the finish of your former position.

The queries are placed in table
T005NestedIIFs
In which I have created 3 fields
One marked SQLfield
Targtable
Targfield

Public Function CreateTableofSQL(TargetTable As Variant, TargetFieldforUpdate As Variant, BatchSizeNo As Long)
On Error GoTo Err_Writetofile

Dim rst As DAO.Recordset
Dim rst2 As DAO.Recordset
Dim rst3 As DAO.Recordset
Dim rst4 As DAO.Recordset
Dim RecordCount1 As Long
Dim RecordCount2 As Long
Dim LCounter As Integer
Dim SQLString1 As String

LCounter = 1


While LCounter < 200

LCounter = LCounter + 1

SQLString1 = ""

'Three recordsets were testing differing flag fields because order of the integrity of the recordsets were being affected by each other
Set rst2 = CurrentDb.OpenRecordset("SELECT TOP " & BatchSizeNo & " T001CodeConversionTable.PKID, T001CodeConversionTable.OldValue, T001CodeConversionTable.NewValue, T001CodeConversionTable.xFlag2 FROM T001CodeConversionTable WHERE (((T001CodeConversionTable.xFlag2)<>1));")
Set rst3 = CurrentDb.OpenRecordset("SELECT TOP " & BatchSizeNo & " T001CodeConversionTable.PKID, T001CodeConversionTable.OldValue, T001CodeConversionTable.NewValue, T001CodeConversionTable.xFlag3 FROM T001CodeConversionTable WHERE (((T001CodeConversionTable.xFlag3)<>1));")
Set rst = CurrentDb.OpenRecordset("SELECT TOP " & BatchSizeNo & " T001CodeConversionTable.PKID, T001CodeConversionTable.OldValue, T001CodeConversionTable.NewValue, T001CodeConversionTable.xFlag1 FROM T001CodeConversionTable WHERE (((T001CodeConversionTable.xFlag1)<>1));")

'MoveLast required to ensure correct record count at first pass reset to first after this
rst.MoveLast
RecordCount1 = rst.RecordCount
rst.MoveFirst
rst3.MoveLast
RecordCount2 = rst3.RecordCount
rst3.MoveFirst

SQLString1 = SQLString1 & "UPDATE " & TargetTable & " SET " & TargetTable & "." & TargetFieldforUpdate & "="
Do Until rst.EOF = True
rst.Edit
rst!xFlag1 = 1
rst.Update
RecordCount1 = RecordCount1 - 1
SQLString1 = SQLString1 & "IIF((" & TargetTable & "!" & TargetFieldforUpdate & "='" & rst!OldValue & "'),'" & rst!NewValue & "'"
If RecordCount1 = 0 Then
SQLString1 = SQLString1 & " "
Else
SQLString1 = SQLString1 & ","
End If
rst.MoveNext
Loop

rst.Close

Do Until rst2.EOF = True
SQLString1 = SQLString1 & ")"
rst2.Edit
rst2!xFlag2 = 1
rst2.Update
rst2.MoveNext
Loop
SQLString1 = SQLString1 & " WHERE (("

rst2.Close

Do Until rst3.EOF = True
RecordCount2 = RecordCount2 - 1
SQLString1 = SQLString1 & "(" & TargetTable & "!" & TargetFieldforUpdate & ")='" & rst3!OldValue & "'"
rst3.Edit
rst3!xFlag3 = 1
rst3.Update
If RecordCount2 = 0 Then
SQLString1 = SQLString1 & " "
Else
SQLString1 = SQLString1 & " OR "
End If

rst3.MoveNext
Loop

rst3.Close

SQLString1 = SQLString1 & "));"


Set rst4 = CurrentDb.OpenRecordset("T005NestedIIFs")
With rst4
.AddNew
rst4!SQLfield = SQLString1
rst4!Targfield = TargetFieldforUpdate
rst4!Targtable = TargetTable
rst4.Update
rst4.Close
End With

Wend

Exit_WritetoFileError:
 Exit Function

Err_Writetofile:
    If Err.Number = 3021 Then
    MsgBox "All records in Translation table written out no more to translate"
    Else
    MsgBox Err.Description
    End If
 Resume Exit_WritetoFileError

End Function

Generate Nested IIF SQL using VBA code

I came across a situation at work where we were needing to alter a large number of values in particular fields from one value to another. Here is a function I put together to assist in this. After some thought it was obvious that this would be better accomplished joining the conversion table in the query editor and moving on from there, particularly because MS Access has a limit on the number nested IIFs allowed in a single statement. Nonetheless I publish it here as it may prove useful.

Here I create a table T001CodeConversionTable that holds the translation from one set of codes to another. This field also has to have several fields in it named
OldValue
NewValue

The variables TargetTable and TargetFieldforUpdate exist in the table that will have the resultant SQL performed on it.

Public Function CreateNestedIF(TargetTable As Variant, TargetFieldforUpdate As Variant)

Dim rst As DAO.Recordset
Dim rst2 As DAO.Recordset
Dim rst3 As DAO.Recordset
Dim RecordCount1 As Long
Dim RecordCount2 As Long

Set rst = CurrentDb.OpenRecordset("T001CodeConversionTable")
Set rst2 = CurrentDb.OpenRecordset("T001CodeConversionTable")
Set rst3 = CurrentDb.OpenRecordset("T001CodeConversionTable")

RecordCount1 = rst.RecordCount
RecordCount2 = rst3.RecordCount

Dim fs, TextFile
Set fs = CreateObject("Scripting.FileSystemObject")
Set TextFile = fs.CreateTextFile("C:\Users\Mark\Documents\NestedIFs.txt", True)
TextFile.WriteLine ("UPDATE " & TargetTable & " SET " & TargetTable & "." & TargetFieldforUpdate & "=")
Do Until rst.EOF = True
RecordCount1 = RecordCount1 - 1
TextFile.WriteLine ("IIF((" & TargetTable & "!" & TargetFieldforUpdate & "='" & rst!OldValue & "'),'" & rst!NewValue & "'")
If RecordCount1 = 0 Then
TextFile.WriteLine ("")
Else
TextFile.WriteLine (",")
End If
rst.MoveNext
Loop

rst.Close

Do Until rst2.EOF = True
TextFile.WriteLine (")")
rst2.MoveNext
Loop
TextFile.WriteLine ("WHERE ((")

rst2.Close

Do Until rst3.EOF = True
RecordCount2 = RecordCount2 - 1
TextFile.WriteLine ("(" & TargetTable & "!" & TargetFieldforUpdate & ")='" & rst3!OldValue & "'")
If RecordCount2 = 0 Then
TextFile.WriteLine ("")
Else
TextFile.WriteLine ("OR")
End If
rst3.MoveNext
Loop

rst3.Close

TextFile.WriteLine ("));")

TextFile.Close

MsgBox "Created NestedIFs File in C drive"

End Function

Manipulating MS Word Documents from MS Access 2003

The following code generates separate word documents for each parent record in a table called T001ParentRecords and places the children records relating to the parent record in a word document. It then goes on to format that word document before saving and closing and then moving to the next document and starting the process again.

As such it takes the code relating to looping through recordsets and also the code relating to generating word documents and combines the two. This could be very good for automatically generating whole host of different things.

It uses the WEND statement rather than the Do Until Loop as I was told it was better practice.

Function AutoGenerateParentChildWordDocuments()

'Make sure the name of the recordset is unambigous
'Good practice to reference the actual library
'Please ensure that you go to Tools - Refererences and select Microsoft Word 11 0 Object Library

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

Dim rschild As DAO.Recordset

Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document

Set db = CurrentDb
'Place your SQL for parent records to be created
Set rs = db.OpenRecordset("SELECT * FROM T001ParentRecords")

If Not (rs.EOF And rs.BOF) Then
    'There are no records if EOF and BOF are both true you are at the end and at the beginning
    
    rs.MoveLast
    rs.MoveFirst
    While (Not rs.EOF)
        Set wrdApp = CreateObject("Word.Application")
        
        'Create the new document
        Set wrdDoc = wrdApp.Documents.Add
        'The following line can be altered to open the document on the screen
        wrdApp.Visible = False
        'Next setup the margins of the document
        wrdDoc.PageSetup.LeftMargin = CentimetersToPoints(1.27)
        wrdDoc.PageSetup.RightMargin = CentimetersToPoints(1.27)
        wrdDoc.PageSetup.TopMargin = CentimetersToPoints(1.27)
        wrdDoc.PageSetup.BottomMargin = CentimetersToPoints(1.27)
                
        With wrdDoc
        
            .Styles(wdStyleHeading1).Font.Name = "Algerian"
            .Styles(wdStyleHeading1).Font.Size = 14
            .Styles(wdStyleHeading1).Font.Bold = True
            .Styles(wdStyleHeading1).Font.Color = wdColorBlack
            
            .Styles(wdStyleHeading3).Font.Name = "Courier"
            .Styles(wdStyleHeading3).Font.Size = 12
            .Styles(wdStyleHeading3).Font.Bold = False
            .Styles(wdStyleHeading3).Font.Color = wdColorBlack
            .Styles(wdStyleHeading3).NoSpaceBetweenParagraphsOfSameStyle = True
            .Styles(wdStyleHeading3).ParagraphFormat.Alignment = wdAlignParagraphJustify
                        
            .Styles(wdStyleHeading2).Font.Name = "Arial"
            .Styles(wdStyleHeading2).Font.Size = 12
            .Styles(wdStyleHeading2).Font.Bold = True
            .Styles(wdStyleHeading2).Font.Color = wdColorRed
            .Styles(wdStyleHeading2).NoSpaceBetweenParagraphsOfSameStyle = True
            .Styles(wdStyleHeading2).ParagraphFormat.Alignment = wdAlignParagraphJustify
                        
            .Styles(wdStyleNormal).Font.Name = "Arial"
            .Styles(wdStyleNormal).Font.Size = 10
            .Styles(wdStyleNormal).Font.Color = wdColorBlue
        
            'Better to set style before insert
            .Paragraphs(.Paragraphs.Count).Style = .Styles(wdStyleHeading1)
            .Content.InsertAfter ("Sitename:" & rs!Sitename)
            .Content.InsertParagraphAfter
                  
            .Paragraphs(.Paragraphs.Count).Style = .Styles(wdStyleHeading3)
            .Content.InsertAfter ("Town:" & rs!Town)
            .Content.InsertParagraphAfter
            
            .Paragraphs(.Paragraphs.Count).Style = .Styles(wdStyleHeading3)
            .Content.InsertAfter ("Postcode:" & rs!Postcode)
            .Content.InsertParagraphAfter
            
            Set rschild = db.OpenRecordset("SELECT * FROM T002ChildRecords WHERE FKID = " & rs!PKID)
    
            If Not (rschild.EOF And rschild.BOF) Then
                'There are no records if EOF and BOF are both true you are at the end and at the beginning
    
                rschild.MoveLast
                rschild.MoveFirst
    
                While (Not rschild.EOF)
                
                    'Again better to set style before insert
                    .Paragraphs(.Paragraphs.Count).Style = .Styles(wdStyleHeading1)
                    .Content.InsertAfter ("Consulting Body:" & rschild!Body)
                    
                    .Content.InsertParagraphAfter
                    .Paragraphs(.Paragraphs.Count).Style = .Styles(wdStyleHeading2)
                    .Content.InsertAfter ("Consultation response : " & rschild!Comment)
                    .Content.InsertParagraphAfter
                                                                                
                    .Content.InsertParagraphAfter
                    .Paragraphs(.Paragraphs.Count).Style = .Styles(wdStyleNormal)
                    .Content.InsertAfter ("Consultation Date: " & rschild!DateUpdated)
                    .Content.InsertParagraphAfter
                    .Content.InsertParagraphAfter
                    .Content.InsertParagraphAfter
                            
                    rschild.MoveNext
                Wend
            Else
            End If
    
            rschild.Close
            
            .SaveAs ("c:\temp\Auto-Generated-WordDoc-" & rs!Town & rs!PKID & ".doc")
            .Close ' close the document
            
        End With ' With wrdDoc
        Set wrdDoc = Nothing
        
        wrdApp.Quit ' close the Word application
        Set wrdApp = Nothing
        
        rs.Edit
        rs.Update
        rs.MoveNext
        
    Wend
    
    rs.Close
Else
    MsgBox "No Records Available for updating exit sub"
    Exit Function
End If

MsgBox "Looped through the records and updated the value number field"

Set rschild = Nothing
Set rs = Nothing
Set db = Nothing

End Function

Download an example database HERE

Boilerplate code demonstrating simple Recordset manipulation

What’s the difference between Sub Routines and Functions

I was curious Sub Routines and Functions appear to perform almost the same thing what is the difference and what are their relative advantages?

Functions return a value that is stored whereas subs don’t. The main difference is not only the return value, it seems that subs are faster than functions (at least in .net) because the MSIL code of subs is much shorter when no value is returned. so overall subs are faster when no value is returned.

MSIL stands for Microsoft Intermediate Language – which is the a programming language that has been standardized later as the Common Intermediate Language

Functions vs Sub Routines

Typical DAO.Recordset VBA for looping through and altering

Function TypicalDAOrecordset()

'Make sure the name of the recordset is unambiguous
'Good practice to reference the actual library
        
    Dim rs As DAO.Recordset
    Dim db As DAO.Database
    Set db = CurrentDb
    Set rs = db.OpenRecordset("SELECT * FROM T001Main where T001Main.ValueNumber = 0")
    
        '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 (rs.EOF And rs.BOF) Then
        'there are no records if End of File and beginning of file are both true
        
            rs.MoveFirst
            
            Do Until rs.EOF = True
            rs.Edit
            rs!ValueNumber = 300
            rs.Update
            rs.MoveNext
            Loop
            Else
            MsgBox "No Records available for updating exit sub"
            Exit Function
            End If
            MsgBox "Looped through the records and updated ValueNumber field"
            
            rs.Close
            Set rs = Nothing
            Set db = Nothing
            
            'libraries for DAO can be found on AllenBrowne site
            'remember to break an infinite loop press ctrl + break

End Function

MS Access VBA Function – Count Numbers of Records in Tables and list.

Not quite finished yet but place here for later correction.

Public Function CountAllTablesRows()
 
Dim rs As New ADODB.Recordset
Dim rsRC As New ADODB.Recordset
Dim strTbName As String
Dim lngRowCount As Long
Dim tbl As TableDef
CurrentProject.Connection.Execute "Delete from TABLE_INFO"
rs.Open "TABLE_INFO", CurrentProject.Connection, adOpenDynamic, adLockOptimistic
For Each tbl In CurrentDb.TableDefs
  Select Case Left(tbl.Name, 4)
    Case "mSys"
    Case Else
      rs.AddNew
      rsRC.Open "Select count(*) as The_Count from [" & tbl.Name & "]", CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
      rs.Fields("TBL_NAME") = tbl.Name
      rs.Fields("TBL_ROWCOUNT") = rsRC.Fields("The_Count")
      rs.Update
      rsRC.Close
      Set rsRC = Nothing
      'Debug.Print tbl.Name
  End Select
Next
rs.Close
Set rs = Nothing


MsgBox "Counted Numbers in Table"
 
End Function

Using VBA to write Word Document

Writing to Microsoft Word

Firstly a warning – this creates doc documents that can be opened in Word 2010 but are strictly speaking 03 iterations hence the doc suffix

First need to load in the library for Microsoft Word (this is 2003 version)

ObjectLibrary

Then you are free to open and manipulate the items in Microsoft word..

Private Sub Command_Click()
On Error GoTo Err_Command_Click
 
    Dim wrdApp As Word.Application
    Dim wrdDoc As Word.Document
   
    Set wrdApp = CreateObject("Word.Application")
    Set wrdDoc = wrdApp.Documents.Add ' create a new document
    wrdApp.Visible = True 
‘this line can be altered to not open the document on the screen
   
    With wrdDoc
       
        With .Styles(wdStyleHeading1).Font
            .Name = "Arial"
            .Size = 16
            .Bold = True
            .Color = wdColorBlack
        End With
        With .Styles(wdStyleHeading2).Font
            .Name = "Arial"
            .Size = 12
            .Bold = True
            .Color = wdColorBlack
        End With
        With .Styles(wdStyleNormal).Font
            .Name = "Arial"
            .Size = 10
            .Color = wdColorBlack
        End With
       
        .Content.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
        .Content.ParagraphFormat.LineSpacing = 10
 
        .Range(0).Style = .Styles(wdStyleHeading1)
        .Content.InsertAfter "ThIS SHOULD BE HEADING1"
        .Content.InsertParagraphAfter
       
        .Range(.Characters.Count - 1).Style = .Styles(wdStyleHeading2)
        .Content.InsertAfter "THIS SHOULD BE HEADING2"
        .Content.InsertParagraphAfter
 
        .Range(.Characters.Count - 1).Style = .Styles(wdStyleNormal)
        .Content.InsertAfter "THIS SHOULD BE NORMAL"
        .Content.InsertParagraphAfter
               
        .SaveAs ("C:\CreatedWordDoc.doc")
        .Close ' close the document
    End With    ' With wrdDoc
   
    wrdApp.Quit ' close the Word application
    Set wrdDoc = Nothing
    Set wrdApp = Nothing
 
Exit_Command_Click:
    Exit Sub
 
Err_Command_Click:
    MsgBox Err.Description
    Resume Exit_Command5_Click

An article on libraries specifically related to MS Access is available here
allenbrowne.com

Using VBA and Databases to create HTML

Here’s some code I used to generate HTML for a web configuration file. It takes a database (the current open one) then looks to a query called QueryTargetInformation and places the fields – PlaceName / EastingMn / NorthingMn / EastingMx / NorthingMx in a HTML Structure and creates a file called CodeGeneratedHTML.txt place it on the C drive.

I put around 1,000 repeated links in HTML configuration file using this.

This was for a web mapping application – the eastings and northings were obtained from Ordnance Survey Open Source shape files from Ordnance Survey and then QGIS to get the eastings and northings of a variety of locations. These were transferred into the relevant columns of a database and this code triggered from the onclick event of a form command.

Private Sub Command_Click()
On Error GoTo Err_Command_Click
 
Dim rst As DAO.Recordset
Set rst = CurrentDb.OpenRecordset("QueryTargetInformation")
Dim fs, TextFile
Set fs = CreateObject("Scripting.FileSystemObject")
Set TextFile = fs.CreateTextFile("c:\CodeGeneratedHTML.txt", True)
Do Until rst.EOF = True
TextFile.WriteLine ("<bookmark name=" & Chr$(34) & rst!PlaceName & Chr$(34) & ">")
TextFile.WriteLine ("   <min>")
TextFile.WriteLine ("       <x>" & rst!EastingMn & "</x>")
TextFile.WriteLine ("       <y>" & rst!NorthingMn & "</y>")
TextFile.WriteLine ("   </min>")
TextFile.WriteLine ("   <max>")
TextFile.WriteLine ("       <x>" & rst!EastingMx & "</x>")
TextFile.WriteLine ("       <y>" & rst!NorthingMx & "</y>")
TextFile.WriteLine ("   </max>")
TextFile.WriteLine ("</bookmark>")
rst.MoveNext
Loop
TextFile.Close
 
MsgBox "Created CodeGeneratedHTML File in C drive"
 
Exit_Command_Click:
    Exit Sub
 
Err_Command_Click:
    MsgBox Err.Description
    Resume Exit_Command_Click
 
End Sub

Early and Late Binding

f12

Good article on Early and Late Binding

MSDN Early and Late binding

Coding can appear very complicated sometimes but to simplify the difference in terms of implementation this line is very clear;

The only difference between early binding and late binding (in terms of the code you write) is in the variable declaration.

Or it could be an excuse to post a really nice picture of some bindings.