Import Multi Line Email From Outlook 1

[BenSC]

Hi All,
What I am trying to do is import an email containing name and address details from Outlook into Access. The problem is that if the email text has a carriage return in it then access only copies up to that point and doesn't copy the rest of the message. Therefore, I can copy an address formatted as follows:
line 1, line 2, line 3, line 4

but only the first line of this email would be copied.

line 1
line 2
etc

The code I'm using is:

Function ImportEmail()

' Set up DAO objects (uses existing "tblInbox" table)
Dim rst As Recordset
Dim db As Database

Set db = CurrentDb()
Set rst = db.OpenRecordset("tblInbox&quot

' Set up Outlook objects.
Dim Outlook As New Outlook.Application
Dim OutlookNS As Outlook.NameSpace
Dim cf As Outlook.MapiFolder
Dim c As Outlook.MailItem
Dim objItems As Outlook.Items
Dim Prop As Outlook.UserProperty
Dim iNumContacts As Integer
Dim i As Integer

Set OutlookNS = Outlook.GetNamespace("MAPI&quot
Set cf = OutlookNS.GetDefaultFolder(olFolderInbox)
Set objItems = cf.Items
iNumContacts = objItems.Count
If iNumContacts <> 0 Then
For i = 1 To iNumContacts
If TypeName(objItems(i)) = &quot;MailItem&quot; Then
Set c = objItems(i)
rst.AddNew
rst!To = c.To
rst!From = c.SenderName
rst!Subject = c.Subject
rst!Message = c.Body
rst!Received = c.ReceivedTime
rst.Update
End If
Next i
rst.Close
MsgBox &quot;All Email Has Been Imported&quot;
Else
MsgBox &quot;There Is No Email To Be Imported&quot;
End If

End Function

Any Help Would Be Much Appreciated

 

[danvlas]

What type/size is your Message field in the table? Set it to Memo.
It should work, I've been using it for ages...

And (I may be wrong however), the Inbox folder only stores MailItems, so the If branch:

If TypeName(objItems(i)) = &quot;MailItem&quot; Then

can be removed, as it is always True.

HTH



Daniel Vlas
Systems Consultant

http://www.geocities.com/danvlas/AutoMail.html

 

[BenSC]

Thanks Daniel,
I've changed my message field from text to memo now, as it cures my other problem of the 255 character limit on text fields, but the problem remains.

Can you see anything wrong with the code? I can't, but my knowledge of this area is somewhat limited.

Thanks
Ben C

 

[BenSC]

Hi All,
After much head scratching I've come up with a solution. Rather than trying to get my table field to accept line breaks I've now recoded so that line breaks are replaced by comma's, which are no problem.

Function ImportEmail()
'Import Email From The Inbox>Ebay SubFolder Into tblInbox

Dim rst As Recordset
Dim db As Database
Dim strSearchString As String
Dim strSearchChar As String
Dim strChrPos As String
Dim strBaseMessage As String

'Set up Outlook Objects
Dim Outlook As New Outlook.Application
Dim OutlookNS As Outlook.NameSpace
Dim cf As Outlook.MAPIFolder
Dim MyFolder As Outlook.MAPIFolder
Dim MailItem As Outlook.MailItem
Dim objItems As Outlook.Items
Dim iNumContacts As Integer
Dim i As Integer

Set db = CurrentDb()
Set rst = db.OpenRecordset(&quot;tblInbox&quot

Set OutlookNS = Outlook.GetNamespace(&quot;MAPI&quot
Set cf = OutlookNS.GetDefaultFolder(olFolderInbox)
Set MyFolder = cf.Folders(&quot;Ebay&quot

Set objItems = MyFolder.Items
iNumContacts = objItems.Count
If iNumContacts <> 0 Then
For i = 1 To iNumContacts
If TypeName(objItems(i)) = &quot;MailItem&quot; Then
Set MailItem = objItems(i)
rst.AddNew
rst!To = MailItem.To
rst!From = MailItem.SenderName
rst!Subject = MailItem.Subject

strBaseMessage = MailItem.Body

'Empty The strChrPos String
strChrPos = &quot;&quot;

'While There Are Line Breaks In The String Remove Them & Then Exit The Loop
Do While strChrPos <> &quot;0&quot;
strSearchString = strBaseMessage
strSearchChar = Chr(13)
strChrPos = InStr(1, strSearchString, strSearchChar, vbTextCompare)
If strChrPos = &quot;0&quot; Then Exit Do
Mid(strBaseMessage, strChrPos, 2) = &quot;, &quot;
Loop

rst!Message = strBaseMessage
rst!Received = MailItem.ReceivedTime
rst.Update
End If
Next i
rst.Close
MsgBox &quot;All Email Has Been Imported&quot;
Else
MsgBox &quot;There Is No Email To Be Imported&quot;
End If

End Function

BenC

 

[scottian]

BenSC,

Im having trouble getting the second function to work. I get :-
runtime error 3265
item not found in this collection

the debugger points to the line :-
rst!Message = strBaseMessage

any ideas?

"My God! It's full of stars...

 

[scclem]

Ben,

This section of your code:

strBaseMessage = MailItem.Body

'Empty The strChrPos String
strChrPos = ""

'While There Are Line Breaks In The String Remove Them & Then Exit The Loop
Do While strChrPos <> "0"
strSearchString = strBaseMessage
strSearchChar = Chr(13)
strChrPos = InStr(1, strSearchString, strSearchChar, vbTextCompare)
If strChrPos = "0" Then Exit Do
Mid(strBaseMessage, strChrPos, 2) = ", "
Loop

rst!Message = strBaseMessage

Can all be accomplished using:

rst!Message = Replace(MailItem.Body, chr(13), ',', , vbTextCompare)

Scott

 

[BenSC]

scottian,
I'm not 100% sure what your problem is, but it may be to do with the references you have enabled. I had the following libraries referenced in this order:

Visual Basic for Applications
Microsoft Access 9.0 Object Library
OLE Automation
Microsoft Outlook 10.0 Object Library
Microsoft ActiveX Data Objects 2.1 Library
Microsoft DAO 3.6 object library
Microsoft Visual Vasic for Applications Extensibility 5.3

Hope this helps

Regards

BenSC