Category: VBA Code MS Access

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

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

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!

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

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

Allen Browne Functions Index

Technet list of 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

Function TypicalWhileLoop()
'This performs the same as next loop but uses the while loop

 Dim LCounter As Integer
    LCounter = 1
    
    While LCounter < 10


    MsgBox (LCounter)


    LCounter = LCounter + 1


    Wend

End Function

Function TypicalForNextExample()
'This performs the same as the while loop but uses for next

    Dim i As Integer
    
    For i = 1 To 9
    MsgBox (i)
    Next i


End Function

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

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

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)

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

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