DEVelopers HUT

Function AddOlContact()
On Error GoTo Error_Handler
    Const olContactItem = 2
    Dim olApp As Object
    Dim Ctct As Object
 
    Set olApp = CreateObject("Outlook.Application")
    Set olContact = olApp.CreateItem(olContactItem)
 
    With olContact
        .FirstName = "Daniel"
        .LastName = "Alba"
        .JobTitle = ""
        .CompanyName = "MINI CARDA"
        .BusinessAddressStreet = "22 ClearPoint"
        .BusinessAddressCity = "Pointe-Claire"
        .BusinessAddressState = "Quebec"
        .BusinessAddressCountry = "Canada"
        .BusinessAddressPostalCode = "H9X 3A6"
        .BusinessTelephoneNumber = "(514) 488-0956"
        .BusinessFaxNumber = ""
        .Email1Address = "mini@mini.com"
        .MobileTelephoneNumber = ""
        .Save 'use .Display if you wish the user to see the contact pop-up
    End With
 
Error_Handler_Exit:
    On Error Resume Next
    Set olContact = Nothing
    Set olApp = Nothing
    Exit Function
 
Error_Handler:
    MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
    Err.Number & vbCrLf & "Error Source: AddOlContact" & vbCrLf & "Error Description: " & _
    Err.Description, vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

'---------------------------------------------------------------------------------------
' Procedure : AddOlTask
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Create a task in Outlook using late binding (no need for references)
' 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:
' ~~~~~~~~~~~~~~~~
' sSubject          : Task subject
' sBody             : Task body (the actual content message in the task)
' dtDueDate         : Task due date
' dtReminderDate    : Task reminder date/time
'
' Usage Example:
' ~~~~~~~~~~~~~~~~
' ? AddOlTask("Meeting with Daniel","Meeting w/ Daniel to discuss the database.", _
'             #5/31/2010#, #5/29/2010 9:00 AM#)
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2010-May-20                 Initial Release
'---------------------------------------------------------------------------------------
Function AddOlTask(sSubject As String, sBody As String, _
                    dtDueDate As Date, _
                    dtReminderDate As Date)
On Error GoTo Error_Handler
 
    Const olTaskItem = 3
    Dim OlApp As Object
    Dim OlTask As Object
 
    Set OlApp = CreateObject("Outlook.Application")
    Set OlTask = OlApp.CreateItem(olTaskItem)
 
    With OlTask
        .Subject = sSubject
        .DueDate = dtDueDate
        .Status = 1                 '0=not started, 1=in progress, 2=complete, 3=waiting,
                                    '4=deferred
        .Importance = 1             '0=low, 1=normal, 2=high
        .ReminderSet = True
        .ReminderTime = dtReminderDate
        .Categories = "Business" 'use any of the predefined Categorys or create your own
        .Body = sBody
        .Save   'use .Display if you wish the user to see the task form and make
                'them perform the save
    End With
 
Error_Handler_Exit:
    On Error Resume Next
    Set OlTask = Nothing
    Set OlApp = Nothing
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & "Error Number: " & _
    Err.Number & vbCrLf & "Error Source: AddOlkTask" & vbCrLf & "Error Description: " & _
    Err.Description, vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

'---------------------------------------------------------------------------------------
' Procedure : SendHTMLEmail
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Automate Outlook to send an HTML email with or without attachments
' 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:
' ~~~~~~~~~~~~~~~~
' strTo         To Recipient email address string (semi-colon separated list)
' strSubject    Text string (HTML) to be used as the email subject line
' strBody       Text string to be used as the email body (actual message)
' bEdit         True/False whether or not you wish to preview the email before sending
' strBCC        BCC Recipient email address string (semi-colon separated list)
' AttachmentPath    single value or array of attachment (complete file paths with
'                   filename and extensions)
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2007-Nov-16             Initial Release
'---------------------------------------------------------------------------------------
Function SendHTMLEmail(strTo As String, strSubject As String, strBody As String, bEdit As Boolean, _
                   Optional strBCC As Variant, Optional AttachmentPath As Variant)
'Send Email using late binding to avoid reference issues
   Dim objOutlook As Object
   Dim objOutlookMsg As Object
   Dim objOutlookRecip As Object
   Dim objOutlookAttach As Object
   Dim i As Integer
   Const olMailItem = 0
 
   On Error GoTo ErrorMsgs
 
   Set objOutlook = CreateObject("Outlook.Application")
 
   Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
   With objOutlookMsg
      Set objOutlookRecip = .Recipients.Add(strTo)
      objOutlookRecip.Type = 1
 
      If Not IsMissing(strBCC) Then
        Set objOutlookRecip = .Recipients.Add(strBCC)
        objOutlookRecip.Type = 3
      End If
 
      .Subject = strSubject
      .HTMLBody = strBody
      .Importance = 2  'Importance Level  0=Low,1=Normal,2=High
      
      ' Add attachments to the message.
      If Not IsMissing(AttachmentPath) Then
        If IsArray(AttachmentPath) Then
           For i = LBound(AttachmentPath) To UBound(AttachmentPath) - 1
              If AttachmentPath(i) <> "" And AttachmentPath(i) <> "False" Then
                Set objOutlookAttach = .Attachments.Add(AttachmentPath(i))
              End If
           Next i
        Else
            If AttachmentPath <> "" And AttachmentPath(i) <> "False" Then
                Set objOutlookAttach = .Attachments.Add(AttachmentPath)
            End If
        End If
      End If
 
      For Each objOutlookRecip In .Recipients
         If Not objOutlookRecip.Resolve Then
            objOutlookMsg.Display
         End If
      Next
 
      If bEdit Then 'Choose btw transparent/silent send and preview send
        .Display
      Else
        .Send
      End If
   End With
 
   Set objOutlookMsg = Nothing
   Set objOutlook = Nothing
   Set objOutlookRecip = Nothing
   Set objOutlookAttach = Nothing
 
ErrorMsgs:
   If Err.Number = "287" Then
      MsgBox "You clicked No to the Outlook security warning. " & _
      "Rerun the procedure and click Yes to access e-mail " & _
      "addresses to send your message. For more information, " & _
      "see the document at http://www.microsoft.com/office" & _
      "/previous/outlook/downloads/security.asp."
      Exit Function
   ElseIf Err.Number <> 0 Then
      MsgBox Err.Number & " - " & Err.Description
      Exit Function
   End If
End Function

---------------------------------------------------------------------------------------
' Procedure : SendEmail
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Automate Outlook to send emails with or without attachments
' 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:
' ~~~~~~~~~~~~~~~~
' strTo         To Recipient email address string (semi-colon separated list)
' strSubject    Text string to be used as the email subject line
' strBody       Text string to be used as the email body (actual message)
' bEdit         True/False whether or not you wish to preview the email before sending
' strBCC        BCC Recipient email address string (semi-colon separated list)
' AttachmentPath    single value or array of attachment (complete file paths with
'                   filename and extensions)
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2007-Nov-16             Initial Release
'---------------------------------------------------------------------------------------
Function SendEmail(strTo As String, strSubject As String, strBody As String, bEdit As Boolean, _
                   Optional strBCC As Variant, Optional AttachmentPath As Variant)
'Send Email using late binding to avoid reference issues
   Dim objOutlook As Object
   Dim objOutlookMsg As Object
   Dim objOutlookRecip As Object
   Dim objOutlookAttach As Object
   Dim i As Integer
   Const olMailItem = 0
 
   On Error GoTo ErrorMsgs
 
   Set objOutlook = CreateObject("Outlook.Application")
 
   Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
   With objOutlookMsg
      Set objOutlookRecip = .Recipients.Add(strTo)
      objOutlookRecip.Type = 1
 
      If Not IsMissing(strBCC) Then
        Set objOutlookRecip = .Recipients.Add(strBCC)
        objOutlookRecip.Type = 3
      End If
 
      .Subject = strSubject
      .Body = strBody
      .Importance = 2  'Importance Level  0=Low,1=Normal,2=High
      
      ' Add attachments to the message.
      If Not IsMissing(AttachmentPath) Then
        If IsArray(AttachmentPath) Then
           For i = LBound(AttachmentPath) To UBound(AttachmentPath) - 1
              If AttachmentPath(i) <> "" And AttachmentPath(i) <> "False" Then
                Set objOutlookAttach = .Attachments.Add(AttachmentPath(i))
              End If
           Next i
        Else
            If AttachmentPath <> "" Then
                Set objOutlookAttach = .Attachments.Add(AttachmentPath)
            End If
        End If
      End If
 
      For Each objOutlookRecip In .Recipients
         If Not objOutlookRecip.Resolve Then
            objOutlookMsg.Display
         End If
      Next
 
      If bEdit Then 'Choose btw transparent/silent send and preview send
        .Display
      Else
        .Send
      End If
   End With
 
   Set objOutlookMsg = Nothing
   Set objOutlook = Nothing
   Set objOutlookRecip = Nothing
   Set objOutlookAttach = Nothing
 
ErrorMsgs:
   If Err.Number = "287" Then
      MsgBox "You clicked No to the Outlook security warning. " & _
      "Rerun the procedure and click Yes to access e-mail " & _
      "addresses to send your message. For more information, " & _
      "see the document at http://www.microsoft.com/office" & _
      "/previous/outlook/downloads/security.asp."
      Exit Function
   ElseIf Err.Number <> 0 Then
      MsgBox Err.Number & " - " & Err.Description
      Exit Function
   End If
End Function