Showing in access if email in outlook has attachment (1 Viewer)

[megatronixs]

Hi all,

I found a code that will go trough an emailbox and export all emails to a table in access. This part is working OK (except the received date). I also wante to show in the table if the email contains an attachment, but that part is not working at all.
The project actually is meant to store the emails on a shared drive and attachments and have the emails in Access so I can see them all and recall the one needed.

Private Sub Command14_Click()
Dim TempRst As DAO.Recordset
Dim rst As DAO.Recordset
Dim OlApp As Outlook.Application
Dim Inbox As Outlook.MAPIFolder
Dim InboxItems As Outlook.Items
Dim Mailobject As Object
Dim db As DAO.Database
Dim dealer As Integer
'DoCmd.RunSQL "Delete * from tbl_outlooktemp"
Set db = CurrentDb
Set OlApp = CreateObject("Outlook.Application")
Set Inbox = OlApp.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox)
Set TempRst = CurrentDb.OpenRecordset("tbl_OutlookTemp")
'
Set InboxItems = Inbox.Items
'
For Each Mailobject In InboxItems
    If Mailobject.UnRead Then
    With TempRst
        
        .AddNew
        !Subject = Mailobject.Subject
        !SenderName = Mailobject.SenderName
        !To = Mailobject.To
        !Body = Mailobject.Body
       ' !Received = Mailobject.Received
        !SentOn = Mailobject.SentOn
        !Attachments = Mailobject.Attachments
        .Update
        Mailobject.UnRead = True
    End With
End If
Next
Set OlApp = Nothing
Set Inbox = Nothing
Set InboxItems = Nothing
Set Mailobject = Nothing
Set TempRst = Nothing
End Sub

Thank you in advance.

 

[megatronixs]

Hi all,

I also was thinking that it should take all the emails from a selected mailbox or folder instead of the emails that are not read yet.

Greetings.

 

[megatronixs]

Hi all,

No one has an idea how I could show in access if an email has attachment?

Greetings.

 

[Jibbadiah]

Here is something that you might be able to alter for your own purposes...

Private Sub cmdStep11_Click() 'Save attachments from inbox
PROC_DECLARATIONS:
Const sProc_Name As String = "cmdStep11"
Dim olApp As outlook.Application
Dim olNameSpace As outlook.NameSpace
Dim olRecipient As outlook.RECIPIENT
Dim olMAPIFolder As outlook.MAPIFolder
Dim objItem As Object
Dim olAtmt As outlook.Attachment
Dim strMailAccount As String
Dim strIdentifier As String 'for filenames (padded with leading zeros)
Dim lngIdentifier As Long 'for table values to be stored as a number
Dim strFilename As String
Dim strAttachments As String 'Keep track of attachments found
Dim strCampaign As String 'Date Prospect File was originally created (yyyymmdd)
Dim strOrigCreatedDate As String
Dim strSQL As String 'For insert into table tblResultFiles
Dim blnFileExists As Boolean 'Used to check if a file couldn't be downloaded because it was already in working directory
Dim i As Long 'Used to count number of mailbox items
Dim j As Integer 'Used to count number of attachments saved

PROC_START:
On Error GoTo PROC_ERROR

PROC_MAIN:

'------------------------ MAIN CODE ------------------------

TruncateTable "tblResultFiles"

DoCmd.Hourglass True

i = 0
j = 0

Set olApp = outlook.Application
Set olNameSpace = olApp.GetNamespace("MAPI")
Set olRecipient = olNameSpace.CreateRecipient(gstrEmailAccount)
Set olMAPIFolder = olNameSpace.GetSharedDefaultFolder(olRecipient, olFolderInbox)

'Set olMAPIFolder = olNameSpace.GetDefaultFolder(olFolderInbox)

'Ensure that there are items in the Inbox
If olMAPIFolder.Items.Count > 0 Then

For Each objItem In olMAPIFolder.Items

strAttachments = ""
i = i + 1
debug.print sProc_Name, "Inbox Object: " & i & "; Subject: " & objItem.Subject

If objItem.Class = olMail Then 'Only work with Mail Items

For Each olAtmt In objItem.Attachments

If olAtmt.Type = olByValue Then 'Attachments that can be saved
'Look for Excel attachments where subject line starts with the word "Results" (will ignore "Re:") and has an Excel Attachment
If Left(objItem.Subject, 7) = "Results" And Right(olAtmt.FileName, 4) = ".xls" Then

'strIdentifier = Mid(objItem.Subject, 8, 8)
strOrigCreatedDate = CDate(Mid(objItem.Subject, 8, 4) & "/" & Mid(objItem.Subject, 12, 2) & "/" & Mid(objItem.Subject, 14, 2))
strIdentifier = Right(objItem.Subject, Len(objItem.Subject) - 15)
strFilename = gstrWorkingDir & "\Results" & i & ".xls"

'If file already exists don't download again
If Len(Dir(strFilename)) = 0 Then
olAtmt.SaveAsFile strFilename

'Check file size
Get_File_Size (strFilename)

strAttachments = olAtmt.FileName

j = j + 1 'increment number of emails with correct attachment
debug.print sProc_Name, " ==> Email " & j & " Sent: " & objItem.SentOn & " " & strAttachments

'Save File Details to tblResultFiles (filename example "Results99999999CampCode.xls")
strSQL = "Insert into tblResultFiles (Identifier,OrigCreatedDate,SentDate,Filename) values ('" & EncodeString(strIdentifier) & "','" & strOrigCreatedDate & "','" & Format(objItem.SentOn, "yyyy/mm/dd hh:mm:ss") & "','" & strFilename & "');"
DoCmd.Hourglass False
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
'Delete email attachment after downloading and add suffix to email subject line
olAtmt.Delete
objItem.Subject = objItem.Subject & " (Attachment Downloaded)"
objItem.Save
Exit For 'If we found the correct attachment then delete attachment and look at next email. This will ignore additional attachments (i.e. virus checks, etc)
Else
blnFileExists = True
debug.print sProc_Name, "Point 2.1 - ** Warning ** " & objItem.Subject & " could not be downloaded as a file already exists"
End If 'Len(strFilename)
End If 'Subject & Filename
End If 'olByValue
Next olAtmt
End If 'olMail

Next objItem
Else
debug.print sProc_Name, "Point 2.1 - ** Failed ** - There aren't any items in the Inbox" & vbCrLf
End If

If j = 0 Then
MsgBox "Either the inbox doesn't contain results files, or the same result files are already sitting in the Working Directory" & vbCrLf & _
"If inbox has result files delete all temporary files in the working directory (" & gstrWorkingDir & ") and run this step again.", vbOKOnly + vbCritical, "No files downloaded"
debug.print sProc_Name, "Point 2.1 - ** Failed ** User notified that no files were downloaded"
UpdateLabel Me.lblStep11, 0, 255, "Failed" 'Update Label to show step has failed
GoTo PROC_EXIT
Else
If blnFileExists = True Then
MsgBox "Please note: Some files couldn't be downloaded because a file of the same name already exists in the working Directory", vbOKOnly + vbInformation, "Not all files were downloaded"
debug.print sProc_Name, "Point 2.1 - ** Warning ** User notified that not all files could be downloaded"
End If
End If

debug.print sProc_Name, "Point 3 - " & j & " Results Files Saved Successfully"

'------------------------ MAIN CODE ------------------------

MsgBox j & " File(s) have been Downloaded." & vbCrLf & _
"Any attachments have been deleted from the respective emails.", vbOKOnly + vbInformation, "Step 1 Complete"
UpdateLabel Me.lblStep11, 0, 4259584, "Complete" 'Update Label to show step is complete

PROC_EXIT:
On Error Resume Next
gblnCancel = False
DoCmd.Hourglass False
Set olMAPIFolder = Nothing
Set olRecipient = Nothing
Set olNameSpace = Nothing
Set olApp = Nothing
Exit Sub

PROC_ERROR:
msgbox Err.Number & ": " & Err.Description
Resume PROC_EXIT

End Sub

 

[megatronixs]

Hi Jibbadiah,

for which outlook version is this?

Greetings.

 

[Jibbadiah]

Hi megatronixs,

Think that I'd originally used Outlook 2010 and earlier.
In 2013 you might find issues with improper decoding of attachments. No idea how to fix it. Some files seem to work and others don't. I've got it to partially work in 2013 but haven't had a chance to look further.

If you are having problems logging into outlook substitute line

Set olMAPIFolder = olNameSpace.GetSharedDefaultFolder(olRecipient, olFolderInbox)

for the line that is commented out below it.

HTH

James

p.s. You'll also need to ensure you have a reference to Microsoft Outlook object library.

 

[megatronixs]

Hi Jibbadiah,

I have only 2003 at work and it does not run, not even for testing.
I have tried different ways to get a possible different solution, but no results.

At one point i'm thinking that it would be maybe easier to change a little bit the code from the first post and having all the emails moving to a folder as well to access databases with each record in the access database with a reference to the email that is stored in a folder (c: drive). So when I go the access database and choose an email, I can click on a button and it will open the email from the folder (just the folder so I can double click on the email.msg thing)

Any ideas how to get this done? I'm just stuck with office 2003 and can't find other solutions.

Greetings.

 

[Jibbadiah]

Time to get some new software at work.

Have a look at the following sites - http://www.vbaexpress.com/kb/getarticle.php?kb_id=875

http://www.jpsoftwaretech.com/save-outlook-2003-e-mail-attachments-automatically/

The combination should cover off most requirements but you'll need to tailor them for your purposes.

Incidentally I used google - "vba find attachments in outlook 2003"... but you could search with "save" etc... based on your needs.

J.

J.

 

[megatronixs]

Hi,

The first macro looks very nice and works. I just need to find a way how to change the date and time. It now stores the email in a strange way "11-1-02-14-11-1_02-02014-11" but there is no actual date of the email in it. the email was received on the 2014-11-19 at 12:23. So how can I change the time and date part of the code to really store the correct part.
Is it possible to include the code from the first post to add the email to access database in the loop? (and a link to the file in the folder).

Greetings.