Connecting to IMAP folder in Outlook 98 through Excel VBA 2

[qjd2004]

Hiya,

With VBA, I'm trying to retrieve messages from an IMAP folder in Outlook 98 (the sub runs from Excel 2002 though).
I can get the string name of the IMAP Root folder! Like this

Set objOL = New Outlook.Application
Set olNS = objOL.GetNamespace("MAPI")
Set objFolder = olNS.Folders.Item(1)
y = olNS.Folders.Item(1).Name
MsgBox "Name of item 1 = " & y

This gives me the correct name IMAPSP Folders <Server Name>

However, I need to get to a folder within that root folder called "Inbox". When I do

x = objFolder.Items.count
MsgBox "Items = " & x

I get count = 0 so No Subfolders? How do I make objFolder point to "Inbox" (or is that just the name that appears in Outlook and really it's called something else?)

I've tried using Outlook Spy to get the MAPI info I need to access the folder, but I just get MAPI_E_NOT_AVAILABLE so that's not much use.

Someone please help!

 

[qjd2004]

I got there in the end! Thanks anyway!

Public Sub RipEmail()

Dim conn As ADODB.Connection
Dim rs1 As ADODB.Recordset
Dim objOL As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim ObjSubFolder As Outlook.MAPIFolder
Dim myMailItem As Outlook.MailItem
Dim sOut(2) As String
Dim strSQL As String
Dim F%
Set objOL = New Outlook.Application
Set olNS = objOL.GetNamespace("MAPI")
Set objFolder = olNS.Folders.Item(1)
Set ObjSubFolder = objFolder.Folders.Item(1)

'Dim x
'Dim y
'y = objFolder.Name
'x = ObjSubFolder.Name


'Set the Ado connection and resultset
Set conn = New ADODB.Connection
Set rs1 = New ADODB.Recordset

On Error GoTo ObjectTestError:

	conn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=D:\XL Automation\mailer.mdb" & _
                    ";Persist Security Info=False;"
	conn.Open
    
	rs1.Open ("SELECT * FROM tbl_Mail"), conn, adOpenDynamic, adLockOptimistic

            For F = 1 To ObjSubFolder.Items.count
                Set myMailItem = ObjSubFolder.Items.Item(F)
                    sOut(0) = myMailItem.SenderName
                    sOut(1) = myMailItem.Subject
                    sOut(2) = myMailItem.Body
                    sOut(3) = myMailItem.ReceivedTime
                        rs1.AddNew
                            rs1.Fields("Sender") = sOut(0)
                            rs1.Fields("Subject") = sOut(1)
                            rs1.Fields("Body") = sOut(2)
                        rs1.Update
            Next
            
        rs1.Close
        Set rs1 = Nothing
        Set myMailItem = Nothing
        Set objFolder = Nothing
        Set objOL = Nothing
     Exit Sub

 

[qjd2004]

Latest Code is better, uses Arrays to loop through the emails and add to an access recordset:

Public Sub GetEmailADO()

Dim conn As ADODB.Connection
Dim rs1 As ADODB.Recordset
Dim objOL As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim ObjSubFolder As Outlook.MAPIFolder
Dim myMailItem As Outlook.MailItem
Dim strSQL As String
Dim strReport As String
Dim i%, j%, r%, z%
Dim x As Integer, k As Integer, y As Integer, m As Integer, t As Integer
Dim Count As Integer
Dim MyInboxArray() As Variant
Dim myTypes() As String
Dim sOut(3) As String

Set objOL = New Outlook.Application
Set olNS = objOL.GetNamespace("MAPI")
Set objFolder = olNS.Folders.Item(1)
Set ObjSubFolder = objFolder.Folders.Item(1)
Count = -1
x = ObjSubFolder.Items.Count            'Rows
y = 3                                   'columns
ReDim Preserve MyInboxArray(x, y)

On Error GoTo ObjectTestError
    For i = 0 To x                      'ObjSubFolder.Items.Count
        If i < (x - 1) Then
            Set myMailItem = ObjSubFolder.Items.Item(i + 1)
        Else
            Set myMailItem = ObjSubFolder.Items.Item(i)
        End If
        'Create array of field types
        ReDim Preserve myTypes(4)
        myTypes(0) = myMailItem.SenderName
        myTypes(1) = myMailItem.Subject
        myTypes(2) = myMailItem.Body
        myTypes(3) = myMailItem.ReceivedTime
        'Pass item values into the array
        k = 0
            For j = 0 To y
                MyInboxArray(i, j) = myTypes(k)
                k = k + 1
            Next j
    Next i
BreakOut:
        Set myMailItem = Nothing
        Set objFolder = Nothing
        Set olNS = Nothing
        Set objOL = Nothing
     
'Create the field names for the recordset we're about to update
sOut(0) = "Sender"
sOut(1) = "Subject"
sOut(2) = "Body"
sOut(3) = "ReceivedTime"

     'Set the Ado connection and resultset
     Set conn = New ADODB.Connection
     Set rs1 = New ADODB.Recordset

     conn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=D:\XL Automation\mailer.mdb" & _
                    ";Persist Security Info=False;"
     conn.Open
     'rs1.CursorLocation = adUseServer
     'rs1.Supports adUpdateBatch
     rs1.Open ("SELECT * FROM tbl_Mail"), conn, adOpenDynamic, adLockOptimistic
    
    'For m = LBound(MyInboxArray) To UBound(MyInboxArray)
        For r = 0 To x
            t = 0
            rs1.AddNew
                For z = 0 To y
                    rs1.Fields(sOut(t)).Value = MyInboxArray(r, z)
                    t = t + 1
                Next
                rs1.Update
        Next
    'Next
        'rs1.UpdateBatch
        rs1.Close
        Set rs1 = Nothing
        conn.Close
        Set conn = Nothing
    Exit Sub
ObjectTestError:
    If Err.Number = 429 Then ' outlook not running - create instance of it
      Set objOL = CreateObject("Outlook.Application")
      Resume Next
    Else ' another error - display error message and exit
      MsgBox "Error Code: " & Err.Number & "; Description: " & Err.Description
    End If
End Sub

Hope someone finds that useful

 

[waynerenaud]

Hey gjd, I thought you deserved a star, 1 for giving yourself some great help, and 2 for updating your post so that we could all benefit. Your code will help me with a couple of issues I've had. Thanks