Read/Open Outlook Email incorrectly in new instance (1 Viewer)

[Lateral]

Solved: Read/Open Outlook Email incorrectly in new instance

Hi guys

I am trying to have the ability to open/read an email from Access 2007 and have the following VBA code working.

Private Sub Command395_Click()

' This code finds the 3rd email in the Inbox and displays it in a new Outlook session


Dim myNamespace As Object
Dim myFolder As Object
Dim myItem As Object

'Set myNamespace = Outlook.Application.GetNamespace("MAPI")
Set myNamespace = Outlook.GetNamespace("MAPI")

Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox)

myFolder.Display

Set myItem = myFolder.Items(3)

myItem.Display

End Sub

The problem I have is that it is opening a new instance of Outlook even though Outlook is already open....

Can somebody tell me how to open the current instance and not open a new instance of Outlook?

Thanks guys,

Cheers
Greg

 

[ashleedawg]

This should help:

Sub OpenOutlook()
    Dim myNamespace As Object

    On Error Resume Next
    Set myNamespace = GetObject(, "Outlook.Application")
    On Error GoTo 0

    If myNamespace Is Nothing Then
        Set myNamespace = CreateObject("Outlook.Application")
        MsgBox "Outlook wasn't open but is now."
    Else
        MsgBox "Outlook was already open."
    End If
End Sub

 

[Lateral]

Thanks for this code but I don't know how to implement it within my existing code....

I have subsequently found the solution...it was to simply comment out/remove the following bit of code:

'myFolder.Display


problem solved

Thanks
Cheers
Greg

 

[Lateral]

Hi Guys

I have figured out how to do what I want and I need to solve one issue that has me pulling my hair out before I post the entire solution here.

Here is the code that I have found and massaged to provide me with the functionality that I want:

Sub ImportInboxFromOutlook()

' This code is based in Microsoft Access.

' Set up DAO objects (uses existing "tblEmail" table)
Dim ol As New Outlook.Application
Dim olns As Outlook.Namespace
Dim cf As Outlook.MAPIFolder
Dim c As Outlook.MailItem
Dim objItems As Outlook.Items
Dim rstmessages, rstfiles As DAO.Recordset
Dim MyPath As String
Dim nummessages As Integer


'open a couple of recordsets to handles emails and attachments
Set rstmessages = CurrentDb.OpenRecordset("tblEmail")
Set rstfiles = CurrentDb.OpenRecordset("tblFileAttachments")
'grab the file path to the folder in which we will place attachments
MyPath = DLookup("[Folderpath]", "tlkplookup")
'check existence create if not
If Not FolderExists(MyPath) Then
If MsgBox("Do you want me to create the folder " & MyPath, vbYesNo + vbQuestion, "Create folder") = vbYes Then
MkDir MyPath
Else
GoTo here:
End If
End If


'Delete the records from the tables

'CurrentDb.Execute "DELETE * FROM tblEmail", dbFailOnError
'CurrentDb.Execute "DELETE * FROM tblFileAttachments", dbFailOnError



' Set up Outlook objects.
Set olns = ol.GetNamespace("MAPI")

' Set the Inbox
'Set cf = olns.GetDefaultFolder(olFolderInbox)

'Set the Sent Folder
Set cf = olns.GetDefaultFolder(olFolderSentMail)


Set objItems = cf.Items

nummessages = objItems.Count

If nummessages <> 0 Then

For i = 1 To nummessages
Forms!frmEmail.lblwarn.Caption = "Processing item " & i & " of " & nummessages
Forms!frmEmail.Repaint

If TypeName(objItems(i)) = "MailItem" Then
Set c = objItems(i)
rstmessages.AddNew
rstmessages!EntryID = c.EntryID
rstmessages!Subject = c.Subject
rstmessages!Sender = c.SenderName
rstmessages!SenderEmail = c.SenderEmailAddress
rstmessages!To = c.To
rstmessages!Recipients = c.Recipients.Item(1).Address
rstmessages!SentDate = c.SentOn
rstmessages!ReceivedTime = c.ReceivedTime
rstmessages!Body = c.Body
rstmessages!Folder = "Sent"
rstmessages!MessageSize = c.Size
rstmessages!DateRecordAdded = Now()
rstmessages!Importance = c.Importance
rstmessages!Attachments = c.Attachments.Count
rstmessages.Update

' now look at attachments per email message as it loop into the tblemailattachment table
' If c.Attachments.Count > 0 Then
' For X = 1 To c.Attachments.Count
' MyFileName = c.Attachments.Item(X).FileName
' rstfiles.AddNew
' rstfiles!EntryID = c.EntryID
' rstfiles!FileName = Trim(MyPath & MyFileName)
' rstfiles.Update
' 'create the file only if it is not already there
' On Error Resume Next
' If Not FileExists(MyPath & MyFileName) Then
' c.Attachments.Item(X).SaveAsFile (MyPath & MyFileName)
' End If
' Next
' End If
End If
Next i
here:
'finished close the recordsets and cleanup
rstmessages.Close
rstfiles.Close
MyPath = ""
Set ol = Nothing
Set olns = Nothing
Set cf = Nothing
Set c = Nothing

Else
End If

End Sub


I run the above and it adds records to the "tblEmail" table from the Outlook Sent items folder....this all works really well.

What I want to be able to do is to run an initial "import" as the Sent folder will have more than 20,000 records and then simply add new email records to the "tblEmail" table each day.

I am struggling to figure out how to change the existing VBA code to do this.

The only field in"tblEmail" table that is indexed and has "no duplicates" is the [EntryID] field.

From my testing, I think it is failing on the first email record in the Sent folder when I run it a second time when there are new Sent emails available....

Thanks for any help you can provide.

Cheers
Greg

 

[ashleedawg]

rstmessages.AddNew
rstmessages.AddNew

Hi Greg,

You have 2 AddNew statements in a row, that could be part of the issue.

 

[Lateral]

Hi mate,

I noticed that after the post and removed the second one, ran a test but with same results....any other ideas?

I also edited the original post to remove it.