Mailing More Than One Attachment Using Outlook

This code takes advantage of late binding so you do not have to add a reference to the Outlook library which may vary from machine to machine. If you want to use early binding, add the Outlook library to your references and substitute the Object data type for the one in the comments.

Just remember not everyone will have the same version of Outlook that you do. That's why I use late binding. With late binding, the VBA compiler will select the "Outlook.Application" that is available on the machine. With early binding, the version is hard-coded. If it does not match your version, it will fail.

Public Function Outlook_SendEmail(ByVal strTo As String, _
                           ByVal strSubject As String, _
                           ByVal strMsg As String, _
                           ParamArray AttachmentList() As Variant) As Boolean
'Purpose  : Automatically send email via late-binding Outlook Automation.
'   Call like this:
'    Call Outlook_SendEmail("Bill.Mosca@MyDomain.com","Hey there.", _
     "Here is my message","C:\MyFiles\Test1.txt","C:\MyFiles\Test2.txt")
'DateTime : 11/30/2003 12:12
'Author   : Bill Mosca, modified by ChrisO to use Array for attachments.
    Dim objOLApp As Object    'Outlook.Application
    Dim outItem As Object    'Outlook.MailItem
    Dim outFolder As Object    'MAPIFolder
    Dim DestFolder As Object    'MAPIFolder
    Dim outNameSpace As Object    'NameSpace
    Dim lngAttachment As Long

    On Error GoTo err_Outlook_SendEmail

    Set objOLApp = CreateObject("Outlook.Application")
    Set outNameSpace = objOLApp.GetNamespace("MAPI")
    Set outFolder = outNameSpace.GetDefaultFolder(6)    'olFolderInbox=6
    Set outItem = objOLApp.CreateItem(0)                'olMailItem=0

    outItem.Body = strMsg
    outItem.Subject = strSubject
    outItem.To = strTo

    With outItem.Attachments
        For lngAttachment = LBound(AttachmentList) To UBound(AttachmentList)
            .Add AttachmentList(lngAttachment)
        Next lngAttachment
    End With

    outItem.Send
    Outlook_SendEmail = True

exit_Outlook_SendEmail:
    On Error Resume Next
    Set outItem = Nothing
    Set outFolder = Nothing
    Set outNameSpace = Nothing
    Set objOLApp = Nothing
    Exit Function

err_Outlook_SendEmail:
    Select Case Err.Number
        Case 287
            'User stopped Outlook from sending email.
            MsgBox "Email Cancelled.", vbInformation, "DCDS"
        Case Else
            MsgBox "Error " & Err.Number & " (" & Err.Description _
                   & ") in procedure Outlook_SendEmail of Module mod_Utilities"
    End Select

    Resume exit_Outlook_SendEmail

End Function

back to top

Count the Number of Workdays Between Two Dates

I'm often asked how to determine the number of workdays between 2 dates. Assuming the workweek is Monday through Friday, this code will do it.

It can be edited to accept a different work week. Use a Holidays table to discount those days.

Note: I used ADO in this example only because, at the time it was written, Microsoft said DAO was dead. Silly me, I believed them.

Public Function NetWorkdays(varStartDate As Variant, varEndDate As Variant) _
    As Long
'Purpose  : Calculate the number of workdays (M-F)
'DateTime : 6/17/2000 13:09
'Author   : Bill Mosca
    Dim datCurrDate As Date
    Dim intWkDays As Integer
    Dim strSQL As String
    Dim cnn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim lngRecs As Long

    'Make sure both dates are passed. If not, leave function.
    On Error GoTo err_NetWorkdays

    If IsNull(varStartDate) Or IsNull(varEndDate) Then
        NetWorkdays = 0
        Exit Function
    End If

    If varStartDate = varEndDate Then
        NetWorkdays = 1
        GoTo exit_NetWorkdays
    End If

    datCurrDate = varStartDate
    intWkDays = 0

    Do While datCurrDate <= varEndDate
        If Weekday(datCurrDate) <> vbSunday _
            And Weekday(datCurrDate) <> vbSaturday Then
            intWkDays = intWkDays + 1
        End If

        datCurrDate = DateAdd("d", 1, datCurrDate)
    Loop

'****************************************************************
'    'If you have a table that contains Holidays, use it to
'    'find the number of holidays between the 2 dates.
'    'Otherwise comment out this area.
'    Set cnn = CurrentProject.Connection
'    Set rs = New ADODB.Recordset
'    strSQL = "SELECT COUNT(Holiday) FROM tblHolidays " _
'        & "WHERE Holiday BETWEEN #" & varStartDate _
'        & "# AND #" & varEndDate & "#"
'    rs.Open strSQL, cnn, adOpenStatic
'    lngRecs = rs.Fields(0)
'    intWkDays = intWkDays - lngRecs
'****************************************************************
    NetWorkdays = intWkDays

exit_NetWorkdays:
    On Error Resume Next
    Set rs = Nothing
    Set cnn = Nothing
    Exit Function

err_NetWorkdays:
    Resume exit_NetWorkdays

End Function

back to top

Turn Off AllowDesignView

For some reason not known to me, Access 2000 - 2003 defaults all forms to show the Properties box in form view. While that might help in touching up a form's design, it can be embarrassing it you forget to set the "Allow Design Changes" property to Design View Only. It's time to quit going through each form to manually make that change. This code will iterate through all forms and change the setting for you.

Starting back in Access 2000, the tables had a new property called Subdatasheet. This remarkable feature gave you the abiltiy to drill down to related records when viewing a table in datasheet view. There is a little plus sign (+) to the left of the first field in each record. Clicking on that plus sign would open a "sub" view of child records for that particular record.

Unfortunately, that feature can really slow down the performance of not only the database as a whole, but also the loading of forms. I generally turn it off because the databases I create usually don't allow the users direct access to the tables. Forms and reports are all they see so the users don't have a need for the Subdatasheets. Why sacrifice performance unnecessarily?

If you open a table in design view and right-click on on the table, you will see Properties as a choice. Select it. By setting the Subdatasheet property to [None], you turn off the feature for that table. But this must be done for each table. There is no global setting. By using DAO TableDefs you can loop through all the tables and set the property.

Here is how it is done (Note: If you are using Access 2000, be sure to add the DAO library to your references).

 Public Function TurnOffSubDataSheets()
'Purpose  : Access sets all tables' SubDataSheets to Auto which slows up loading time.
'           This function will set the property to [none].
'DateTime : 1/14/2004 09:20
'Author   : Bill Mosca
    Dim db As DAO.Database
    Dim prop As DAO.Property
    Dim propName As String, propVal As String
    Dim propType As Integer, i As Integer

    On Error Resume Next

    Set db = CurrentDb

    propName = "SubDataSheetName"
    propType = 10
    propVal = "[NONE]"

    For i = 0 To db.TableDefs.Count - 1
        If (db.TableDefs(i).Attributes And dbSystemObject) = 0 Then
            If db.TableDefs(i).Properties(propName).Value <> propVal Then
                db.TableDefs(i).Properties(propName).Value = propVal
            End If

            If Err.Number = 3270 Then
                Err.Clear
                Set prop = db.TableDefs(i).CreateProperty(propName)
                prop.Type = propType
                prop.Value = propVal
                db.TableDefs(i).Properties.Append prop
            Else
                If Err.Number <> 0 Then
                    Resume Next
                End If
            End If
        End If
    Next i

    MsgBox "The " & propName & _
            " value for all non-system tables has been updated to " & propVal & "."

    Set prop = Nothing
    Set db = Nothing

End Function

back to top

Close All Forms/Reports But The Current One
When designing a database I might have several forms and/or reports open at once. Using the Find/Replace feature in the code window can also open more objects if they contain the string you are searching for.

So there I am with 20 to 30 objects open, and I want to close all but the one I selected. Clicking on Window/Cascade will organize the objects so that the Close icons are easily seen, thus letting you click on each one to close the objects, but that takes forever.

I wrote this code to do all that "clicking" for me. There is an option for saving without a prompt that comes in handy when you want to save them all or pick and choose which ones to save.

Public Function CloseFrmsRpts()
'Purpose  : Close all forms and reports opened in design view
'           except the current one.
'DateTime : 11/2/2007 07:46
'Author   : Bill Mosca
'Reference:
    Dim objObject As AccessObject
    Dim intPrompt As Integer
    Dim intUserResp As Integer

    'Set Save flag. Automatically save unless user wants prompt.
    'acSavePrompt=0; acSaveYes=1
    intUserResp = MsgBox("Objects will automatically be saved unless " _
            & "you specify a prompt." _
            & vbNewLine & vbNewLine _
            & "Prompt to save?", vbQuestion + vbYesNo + vbDefaultButton2, "Save?")

    Select Case intUserResp
        Case vbYes
            intPrompt = acSavePrompt
        Case vbNo
            intPrompt = acSaveYes
    End Select

    For Each objObject In CurrentProject.AllForms
        If objObject.IsLoaded = True _
                And Application.CurrentObjectName <> objObject.Name Then
            DoCmd.Close acForm, objObject.Name, intPrompt
        End If
    Next

    For Each objObject In CurrentProject.AllReports
        If objObject.IsLoaded = True _
                And Application.CurrentObjectName <> objObject.Name Then
            DoCmd.Close acReport, objObject.Name, intPrompt
        End If
    Next

End Function

back to top 

Convert Decimals to Fractions
This one is from Clive Williams. I've seen a few examples of how to do this conversion, but they have all been rather kludgy. Clive's elegant function does it perfectly with very few lines of code. Definately one to keep in your code vault.

Public Function DecToFraction(pDecimal As Double, _
                Optional pPowerOfTwoDenominator As Integer = 6) As String
'Purpose  : Convert a positive decimal number to an integer plus a fraction.
'           e.g. 1.375 => 1 3/8, 2.0 => 2
'DateTime : 6/7/2008 10:26
'Author   : Clive Williams
    Dim i As Integer
    Dim f As Long
    Dim n As Integer
    Dim Nmr As Double

    Nmr = 2 ^ pPowerOfTwoDenominator    ' Initial Denominator

    i = Int(pDecimal)    ' Integral Part

    f = Nmr * (pDecimal - i)    ' Fractional Part x Denominator

    While 0 = (f Mod 2) And (f > 1)    ' Halve the Numerator and the Denominator
        f = f / 2
        Nmr = Nmr / 2
    Wend

    If f = 0 Then    ' Ignore the fraction
        DecToFraction = CStr(i)
    Else
        DecToFraction = CStr(i) & " and " & CStr(f) & "/" & CStr(Nmr)
    End If

End Function

back to top