[AccessD] Outlook Automation

Hi Rocky,

Heenan Lambert gave me some code once which I was able to use to great
effect.  Below are three procedures which I now use to select any Outlook
folder, and then select an email within that folder.  This is code behind a
form

The primary procedure that will help is called SelectOutlookMAPIFolder.
It's the second one shown here.

Also - look at the error messages - they do help a user to understand
Microsoft's 'An application is trying to send messages on your behalf . . .'
warning.

----------------------------------------------------------------------------

Private Sub butAttachEmail_Click()
If ErrorTrapping = True Then On Error GoTo EH
    
    Dim stgDestination As String
    
    '-- Can't Attach over an existing file
    If Not IsNull(txtPartFileTitle) Then
        FormattedMsgbox GstgNotReady, "The file " _
            & vbCrLf & vbCrLf _
            & txtPartFileTitle _
            & vbCrLf & vbCrLf _
            & " is already attached here, and you cannot attach another file
over it.@ @", vbExclamation + vbOKOnly, "Cannot Attach Over an Existing
File"
        Exit Sub
    End If
    
    Set modMAPIFolder = SelectOutlookMAPIFolder
    If modMAPIFolder Is Nothing Then
        Exit Sub
    End If
    
    Call CreateMessgeList
    
    DoCmd.OpenForm "frmAttachEmail", , , , , acDialog
    
    Set modMAPIFolder = Nothing
    
    Exit Sub
    
EH:
    Application.Echo True
    DoCmd.SetWarnings True
    GlngErrNumber = Err.Number
    GstgErrDescription = Err.Description
    Select Case GlngErrNumber
        Case 287
            FormattedMsgbox GstgReminder, "To directly store an email as a
file, you must allow Access to your email." _
                & vbCrLf & vbCrLf _
                & "First, check the Allow Access checkbox to allow 1 minute
of access to your email list." _
                & vbCrLf & vbCrLf _
                & "Then push the Yes button.@ @", vbExclamation + vbOKOnly,
"You must grant allow Access to your email!"
        Case Else
            Call GlobalErrors("", GlngErrNumber, GstgErrDescription,
Me.Name, "butAttachEmail")
    End Select

End Sub

----------------------------------------------------------------------------

Private Function SelectOutlookMAPIFolder() As Outlook.MAPIFolder
If ErrorTrapping = True Then On Error GoTo EH

    Dim oParentMailItem As Outlook.MailItem
    Dim oParentFolder As Outlook.MAPIFolder
    Dim olApp As Outlook.Application
        
    Set olApp = CreateObject("Outlook.Application")
    
Continue:
    Set oParentFolder = olApp.GetNamespace("MAPI").PickFolder
    
    If oParentFolder Is Nothing Then
        Exit Function
    End If
    
    If oParentFolder.DefaultItemType <> olMailItem Or oParentFolder.Name =
"Deleted Items" Then
        FormattedMsgbox GstgNotReady, "You must select a Mail Folder!@ @",
vbExclamation + vbOKOnly, "Mail Folder Only"
        Set oParentFolder = Nothing
        GoTo Continue
    End If
    
    If oParentFolder.Items.Count = 0 Then
        FormattedMsgbox GstgNotReady, "There are no Items in the folder " _
            & vbCrLf & vbCrLf _
            & oParentFolder.Name & ".@ @", vbExclamation + vbOKOnly, "No
Email Items"
        Set oParentFolder = Nothing
        GoTo Continue
    End If

    Set SelectOutlookMAPIFolder = oParentFolder
    
    Set oParentFolder = Nothing
    
    Exit Function
    
EH:
    Application.Echo True
    Call GlobalErrors("", Err.Number, Err.Description, Me.Name,
"SelectOutlookMAPIFolder")
        
End Function

----------------------------------------------------------------------------

Private Sub CreateMessgeList()
If ErrorTrapping = True Then On Error GoTo EH

    Dim objMailItem As Outlook.MailItem
    Dim stgFileName As String
    Dim lngItemNumber As Long
    Dim stgSubject As String
    Dim stgSetOrder As String
    
    DoCmd.SetWarnings False
    DoCmd.RunSQL "DELETE * FROM tblFEAttachEmails"
    DoCmd.SetWarnings True
    
    With modMAPIFolder
        If .Items.Count > 0 Then
            SysCmd acSysCmdInitMeter, "Creating Email List", .Items.Count
            For lngItemNumber = 1 To .Items.Count
                On Error Resume Next
                Set objMailItem = .Items(lngItemNumber)
                On Error GoTo 0
                With objMailItem
                    stgSubject = Replace(CleanFileName(.Subject), "'", "''")
                    DoCmd.SetWarnings False
                    DoCmd.RunSQL "INSERT INTO tblFEAttachEmails (Subject,
FromName, DateReceived, MessageNumber)" _
                        & " VALUES ('" & stgSubject & "', '" &
Replace(.SenderName, "'", "''") & "', #" & .ReceivedTime & "#, " &
lngItemNumber & ");"
                    DoCmd.SetWarnings True
                End With
                SysCmd acSysCmdUpdateMeter, lngItemNumber
            Next lngItemNumber
            SysCmd acSysCmdClearStatus
        End If
    End With
    
    Set objMailItem = Nothing
    
    Exit Sub
    
EH:
    Application.Echo True
    DoCmd.SetWarnings True
    GlngErrNumber = Err.Number
    GstgErrDescription = Err.Description
    Select Case GlngErrNumber
        Case 287
            FormattedMsgbox GstgReminder, "To directly store an email as a
file, you must allow Access to your email." _
                & vbCrLf & vbCrLf _
                & "First, check the Allow Access checkbox to allow 1 minute
of access to your email list." _
                & vbCrLf & vbCrLf _
                & "Then push the Yes button.@ @", vbExclamation + vbOKOnly,
"You must allow Access to your email!"
        Case Else
            Call GlobalErrors("", GlngErrNumber, GstgErrDescription,
Me.Name, "Create Message List")
    End Select
    
End Sub

----------------------------------------------------------------------------

Best of Luck!
Dan 
 

-----Original Message-----
 Subject: [AccessD] Outlook Automation

Dear List:

I need to look in a specific outlook folder for mail.  I can't find the 
syntax for this.  Can anyone point me in the right direction?

MTIA

Rocky

-- 
Rocky Smolin
Beach Access Software
858-259-4334
www.e-z-mrp.com