MS Access – VBA – Calculate the Number of Years

The following function accepts two dates as input variables and will return the number of years between those two dates. If you are looking to get a greater level of precision (months, days) then take a look at my post entitled MS Access – Calculate the Age

'---------------------------------------------------------------------------------------
' Procedure : NoYrs
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Calculate the number of Years between two dates
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2010-Sep-09                 Initial Release
'---------------------------------------------------------------------------------------
Function NoYrs(Date1 As Date, Date2 As Date) As Integer
On Error GoTo Error_Handler
    Dim Y       As Integer
    Dim Temp1   As Date
    
    Temp1 = DateSerial(Year(Date2), Month(Date1), Day(Date1))
    Y = Year(Date2) - Year(Date1) + (Temp1 > Date2)
    NoYrs = Y

Error_Handler_Exit:
    On Error Resume Next
    Exit Function

Error_Handler:
    MsgBox "The following error has occurred." & vbCrLf & vbCrLf & _
            "Error Number: " & Err.Number & vbCrLf & _
            "Error Source: NoYrs" & vbCrLf & _
            "Error Description: " & Err.Description, _
            vbCritical, "An Error has Occurred!"
    Resume Error_Handler_Exit
End Function

MS Access – VBA – ADO vs. DAO

A common question asked in numerous forums and discussion groups is:

Which is better: ADO or DAO?
Should I be using ADO or DAO in my code?

Thruthfully, there is no answer that applies for everyone. It all depends on what you are doing!

Some people argue back and forth that ADO or DAO is easier to code, or more powerful… I’m not even going to tackle this subject as a lot of it is subjective and dependent on what you are doing. They each offer pros and cons to the developper. That said;

If you are developing an MS Access database (back-end) then DAO is probably your best bet as it is optimized for Jet/ACE. It should also be noted, from what I have read, that Microsoft recommends DAO for Jet data and as such is typically faster than ADO in this scenario.

On the other hand, if you are developing an Access Data Project (.adp) in conjunction with an SQL Server database (back-end), it is normally recommended that you use ADO.

So based on this it become apparent that, it’s not a matter of whether it’s an ADP or an MDB/ACCDB, but rather where your data is stored and whether or not you will be using the Jet/ACE database engine or not. If you are utilizing the default Jet/ACE database engine then DAO is typically the best route to go. If not, then ADO is best.

VBA – Sending Faxes VBA

Sending Faxes of a Document using VBA (Microsoft Shared Fax Driver)

I had a requirement for a database to be able to send faxes directly from within the database. At the time, I looked high and low and couldn’t find anything on the subject using the Microsoft Shared Fax Driver (Fax printer). It is only recently that I came across a website that covered the subject very well (Murphy’s Law!).

MSDN Article – Visual Basic Fax Administration Scenarios

The following is a slightly modified version of the code found in the MSDN Article. I use a temporary table to populate the recipient of my broadcast (multiple recipient fax).

'---------------------------------------------------------------------------------------
' Procedure  : SendBroadCast
' Author     : CARDA Consultants Inc.
' Website    : http://www.cardaconsultants.com
' Code Source: http://msdn2.microsoft.com/en-us/library/ms693479.aspx
' Purpose    : Send Broadcast fax (send fax to multiple recipients)
' References : requires 'Microsoft Fax Service Extended COM Type Library'
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and 
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' strDoc - path and filname of the document to be faxed
'---------------------------------------------------------------------------------------
'
Function SendBroadCast(strDoc As String)

Dim objFaxDocument As New FAXCOMEXLib.FaxDocument
Dim collFaxRecipients As FaxRecipients
Dim JobId As Variant
Dim strMsg As String

'Error handling
On Error GoTo Error_Handler

'Set the fax body
objFaxDocument.Body = strDoc

'Name the document
objFaxDocument.DocumentName = "Database Fax"

'Get the recipients collection
Set collFaxRecipients = objFaxDocument.Recipients

'Update the table from which the info is pull to generate the fax recipient list
DoCmd.SetWarnings False 'Turn off warning messages so it is transparent to the user
DoCmd.OpenQuery "Qry_Need To Be Faxed", acViewNormal
DoCmd.SetWarnings True 'Turn back on warning messages

'Add the recipients
With collFaxRecipients
    'Using the table created by the above run query loop through the record
    'To populate the fax recipient list
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("Temp01")
    If rst.RecordCount > 0 Then 'ensure there is data
        rst.MoveLast  'goto the last recordset
        Do Until rst.BOF  'beginning of file
           'perform a desired action
           .Add rst![Fax], rst![Company]
           rst.MovePrevious
        Loop
    Else
        MsgBox "There are no faxes to be sent at this time!", vbInformation
    End If

End With

'Display number of recipients
strMsg = "Total Number of Recipients: " & collFaxRecipients.Count & vbCrLf

'Display recipient information
Dim i As Long
For i = 1 To collFaxRecipients.Count
    strMsg = strMsg & "Recipient number " & i & ": " & collFaxRecipients.Item(i).Name & _
             ", " & collFaxRecipients.Item(i).FaxNumber & vbCrLf
Next
MsgBox strMsg, vbInformation, "The following faxes are being processed."

'Load the default sender
objFaxDocument.Sender.LoadDefaultSender

'Group the broadcast receipts
objFaxDocument.GroupBroadcastReceipts = True

'Connect to the fax server, submit the document, and get back the
'job ID array. "" indicates the local server.
JobId = objFaxDocument.Submit("")

'UBound finds the size of the array
'Display jobIDs for each of the fax jobs
'For n = 0 To UBound(JobId)
'    MsgBox "The Job ID is " & JobId(n)
'Next

'Remove the recipients from the collection. If you don't take this step,
'and run this code again without closing the program, the recipients
'collection will retain the recipients and keep adding more recipients.
'The count and item numbering will change as you remove the items, so
'just remove item (1) Count times
Dim lCount As Long
lCount = collFaxRecipients.Count
For i = 1 To lCount
    collFaxRecipients.Remove (1)
Next
Exit Function

Error_Handler:
    'Implement error handling at the end of your subroutine. This
    'implementation is for demonstration purposes
    If Err.Number = -2147024864 Then
        MsgBox "You currently have the document to be faxed open and are therefore" & _
               " stopping the fax from being sent.  Please close the document in " & _
               "question and then try again.", vbInformation, "Your Fax cannot be " & _
               "sent at this time"
    Else
        MsgBox "Error number: " & Err.Number & ", " & Err.Description
    End If
End Function

Word – VBA – Print a Word Document

The following code will print out a word document.

'---------------------------------------------------------------------------------------
' Procedure : PrintDoc
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Print a Word Document
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and 
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' strDoc - The path and filename of the document to be printed
' intCopies - The number of copies to be printed
'
' Usage:
' ~~~~~~~~~~~~~~~~
' PrintDoc("c:\management\evaluation.doc",1)
'---------------------------------------------------------------------------------------
Function PrintDoc(strDoc As String, intCopies As Integer)
   Dim WordObj As Object

   Set WordObj = CreateObject("Word.Application")

   WordObj.Documents.Open strDoc
   WordObj.PrintOut Background:=False, Copies:=intCopies
   WordObj.Documents.Close SaveChanges:=wdDoNotSaveChanges
   WordObj.Quit

   Set WordObj = Nothing
 End Function

VBA – Word – Open Word using Late Binding

The following procedure will launch MS Word. The beauty is it uses late binding so you do not need to use reference libraries and as such avoid/minimize versioning issues. This same procedure can easily be modified to launch just about any MS Office application by simply changing the “Word.Application” portions of the code to correspond with the application you are trying to automate.

A few other strings used for common MS Office application are:

Excel – “Excel.Application”
Access – “Access.Application”
Publisher – “Publisher.Application”
PowerPoint – “PowerPoint.Application”

Sub LaunchWord()
Dim objApp As Object

    'See if Word is already running
    On Error Resume Next
    Set objApp = GetObject(, "Word.Application")
    
    If Err.Number <> 0 Then
        'Launch a new instance of Word
        Err.Clear
        On Error GoTo Error_Handler
        Set objApp = CreateObject("Word.Application")
        objApp.Visible = True 'Make the application visible to the user (if wanted)
    End If

Exit Sub

Error_Handler:
    MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
    Err.Number & vbCrLf & "Error Source: LaunchWord" & vbCrLf & "Error Description: " & _
    Err.Description, vbCritical, "An Error has Occurred!"
    Exit Sub
End Sub

VBA – Excel – Execute/Run an Excel Worksheet Function

Have you ever needed to use an Excel function within one of your databases, or other application. Below is a generic examples of how you can call just about any Excel function using VBA to extend your database’s functionalities even further.

Continue reading →

VBA – Excel – Clear/Delete an Excel Worksheet

Have you ever needed to blank an Excel worksheet from an Access (or other programs as well – Word, PowerPoint, …) database? The following procedure does exactly that!

With this procedure, you can blank an entire WorkSheet or a specified Range on a WorkSheet.

'---------------------------------------------------------------------------------------
' Procedure : ClearXLSWrkSht
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Clear the specified worksheet in a given excel workbook from MS Access
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sXLSFile     Excel workbook filename with full path (ie: "C:\test.xls")
' sXLSWrkSht   Excel worksheet to be cleared (ie: "Sheet1")
'
' Usage Example:
' ~~~~~~~~~~~~~~~~
' ClearXLSWrkSht("C:\test.xls", "Sheet1") 'Clear Sheet1
' ClearXLSWrkSht("C:\test.xls", "Sheet1", "D7:H23") 'Clear range D7:H23 on Sheet1
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2010-Jan-28             Initial Release
' 2         2014-Jun-04             Added Ability to clear a specified Range rather than
'                                   the entire worksheet
'---------------------------------------------------------------------------------------
Sub ClearXLSWrkSht(sXLSFile As String, sXLSWrkSht As String, Optional sRng As String)
    On Error GoTo Error_Handler
    Dim xlApp           As Object
    Dim xlBook          As Object
    Dim xlSheet         As Object

    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True    'Control whether or not Excel should be visible to
    'the user or not.
    Set xlBook = xlApp.Workbooks.Open(sXLSFile)  'Open the workbook
    Set xlSheet = xlBook.Worksheets(sXLSWrkSht)  'Worksheet we are working with

    If sRng = "" Then
'        xlSheet.Cells.Select
        xlSheet.Cells.ClearContents   'Clear the contents
    Else
'        xlSheet.Range(sRng).Select
        xlSheet.Range(sRng).ClearContents   'Clear the contents
    End If

    xlBook.Close True    'Close and save the workbook
    xlApp.Quit        'Close the instance of Excel we create

Error_Handler_Exit:
    On Error Resume Next
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
    Exit Sub

Error_Handler:
    MsgBox "The following error has occurred." & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: ClearXLSWrkSht" & vbCrLf & _
           "Error Description: " & Err.Description, _
           vbCritical, "An Error has Occurred!"
    Resume Error_Handler_Exit
End Sub

VBA – Excel – List the Sheet Names of an Excel Workbook

'---------------------------------------------------------------------------------------
' Procedure : ListXlsSheets
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : List the sheet name of an Excel Workbook
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sFile - The Excel file to list the sheets
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2008-Jul-15                 Initial Release
'---------------------------------------------------------------------------------------
Function ListXlsSheets(sFile As String)
On Error GoTo Error_Handler
    Dim NumSheets   As Integer
    Dim i           As Integer
    Dim xlApp       As Object
    Dim xlWrkBk     As Object
    Dim xlWrkSht    As Object
    
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application") 'Bind to existing instance of Excel
    
    If Err.Number <> 0 Then
        'Could not get instance of Excel, so create a new one
        Err.Clear
        On Error GoTo Error_Handler
        Set xlApp = CreateObject("excel.application")
    Else
        On Error GoTo Error_Handler
    End If

    xlApp.Visible = False 'make excel visible or not to the user
    Set xlWrkBk = xlApp.Workbooks.Open(sFile)
    
    NumSheets = xlWrkBk.Sheets.Count
    For i = 1 To NumSheets
        Debug.Print i & " - " & xlWrkBk.Sheets(i).Name
    Next i

    xlWrkBk.Close False
    xlApp.Close
    
    Set xlWrkSht = Nothing
    Set xlWrkBk = Nothing
    Set xlApp = Nothing
    
Exit Function

Error_Handler:
    If Err.Number <> 438 Then
        MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
        Err.Number & vbCrLf & "Error Source: ListXlsSheets" & vbCrLf & "Error Description: " & _
        Err.Description, vbCritical, "An Error has Occurred!"
        Exit Function
    Else
        Resume Next
    End If

End Function

VBA – Excel – Print an Excel WorkSheet Range

'---------------------------------------------------------------------------------------
' Procedure : PrinWrkShtRng
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Print a specified worksheet range
' Copyright : It is not to be altered or distributed,
'             except as part of an application.
'             You are free to use it in any application,
'             provided the copyright notice is left unchanged.
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' strWrkBk      Workbook file name(full path and filename)
' strWrkSht     Worksheet name which whose range are to be printed
' strRng        Worksheet Range to be printed
'
'
' Revision History:
' Rev       Date(yyyy/mm)           Description
' **************************************************************************************
' 1         2008-Feb                Initial Release
'---------------------------------------------------------------------------------------
Function PrinWrkShtRng(strWrkBk As String, strWrkSht As String, strRng As String)
On Error GoTo PrinWrkShtRng_Error
    Dim xlApp       As Object
    Dim xlWrkBk     As Object
    Dim xlWrkSht    As Object

    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application") 'Bind to existing instance of Excel
    
    If Err.Number <> 0 Then
        'Could not get instance of Excel, so create a new one
        Err.Clear
        On Error GoTo PrinWrkShtRng_Error
        Set xlApp = CreateObject("excel.application")
    Else
        On Error GoTo PrinWrkShtRng_Error
    End If

    xlApp.Visible = True 'make excel visible to the user
    Set xlWrkBk = xlApp.Workbooks.Open(strWrkBk)

    Set xlWrkSht = xlApp.Worksheets(strWrkSht)

    With xlWrkSht.PageSetup
        .PrintArea = strRng
        .Zoom = False
        .FitToPagesTall = 1
        .FitToPagesWide = 1
        .Orientation = xlLandscape
    End With

    xlWrkSht.PrintOut Copies:=1

    xlWrkBk.Close False
    xlApp.Close
    
    Set xlWrkSht = Nothing
    Set xlWrkBk = Nothing
    Set xlApp = Nothing
    
Exit Function

PrinWrkShtRng_Error:
    MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
    Err.Number & vbCrLf & "Error Source: PrinWrkShtRng" & vbCrLf & _
    "Error Description: " & Err.Description, vbCritical, "An Error has Occurred!"
    Exit Function
    
End Function

VBA – Excel – Delete a Worksheet from a Workbook

'---------------------------------------------------------------------------------------
' Procedure : DelWrkSht
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Delete a worksheet from an Excel workbook
' Copyright : It is not to be altered or distributed,
'             except as part of an application.
'             You are free to use it in any application,
'             provided the copyright notice is left unchanged.
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' strWrkBk      Workbook to delete the worksheet in/from (full path and filename)
' strWrkSht     Worksheet to be deleted
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2008-Feb                 Initial Release
'---------------------------------------------------------------------------------------
Function DelWrkSht(strWrkBk As String, strWrkSht As String) As Boolean
    Dim xlApp       As Object
    Dim xlWrkBk     As Object

    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application") 'Bind to existing instance of Excel
    
    If Err.Number <> 0 Then
        'Could not get instance of Excel, so create a new one
        Err.Clear
        On Error GoTo DelWrkSht_Error
        Set xlApp = CreateObject("excel.application")
    Else
        On Error GoTo DelWrkSht_Error
    End If

    Set xlWrkBk = xlApp.Workbooks.Open(strWrkBk)
    
        xlApp.DisplayAlerts = False 'suppress user confirmation prompt
        xlApp.Worksheets(strWrkSht).Delete
        xlApp.DisplayAlerts = True  're-enable user confirmation prompt
        xlApp.Visible = True
    
    Set xlApp = Nothing
    Set xlWrkBk = Nothing

    DelWrkSht = True

Exit Function

DelWrkSht_Error:
    DelWrkSht = False
    If Err.Number = 9 Then
        'Worksheet not found
        MsgBox "Worksheet '" & strWrkSht & "' not found in Workbook '" & strWrkBk & "'", vbCritical
        Exit Function
    ElseIf Err.Number = 1004 Then
        'Workbook not found
        MsgBox "Unable to locate Workbook '" & strWrkBk & "'", vbCritical
        Exit Function
    Else
        'Othere Errors
        MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
        Err.Number & vbCrLf & "Error Source: DelWrkSht" & vbCrLf & _
        "Error Description: " & Err.Description, vbCritical, "An Error has Occurred!"
        Exit Function
    End If
End Function