![]() |
If this is your first visit, be sure to check out the FAQ by clicking the link above. You may have to register before you can post: click the register link above to proceed. To start viewing messages, select the forum that you want to visit from the selection below. |
|
|
Thread Tools | Search this Thread | Display Modes |
#1
|
|||
|
|||
![]()
I have some code I am using to store email information into a SQL
Server table. Everything is working fine except I now need to add the ability for the macro to loop through any subfolders and append those emails also. Sub ExportMailByFolder() 'Export specified fields from each mail 'item in selected folder. Dim ns As Outlook.NameSpace Dim objFolder As Outlook.MAPIFolder Set ns = GetNamespace("MAPI") Set objFolder = ns.PickFolder Dim adoConn As ADODB.Connection Dim adoRS As ADODB.Recordset Dim intCounter As Integer Dim intCounter2 As Integer Set adoConn = CreateObject("ADODB.Connection") Set adoRS = CreateObject("ADODB.Recordset") 'DSN and target file must exist. 'adoConn.Open "DSN=OutlookData;" adoConn.Open "DSN=Neptune3;" adoRS.Open "SELECT * FROM email", adoConn, _ adOpenDynamic, adLockOptimistic 'Cycle through selected folder. For intCounter = objFolder.Items.Count To 1 Step -1 With objFolder.Items(intCounter) 'Copy property value to corresponding fields 'in target file. If .Class = olMail Then adoRS.AddNew adoRS("Subject") = .Subject adoRS("Body") = .Body adoRS("FromName") = .SenderName adoRS("ToName") = .To adoRS("FromAddress") = .SenderEmailAddress adoRS("FromType") = .SenderEmailType adoRS("CCName") = .CC adoRS("BCCName") = .BCC adoRS("Importance") = .Importance adoRS("Sensitivity") = .Sensitivity If .Attachments.Count = 1 Then Set myAttachments = .Attachments Dim myAttStr As String For intCounter2 = myAttachments.Count To 1 Step -1 If Replace(Replace(myAttachments.Item(intCounter2).Di splayName, ":", ""), "/", "") "" Then myAttachments.Item(intCounter2).SaveAsFile "j:\client\cvs \emailattachments\" & Replace(Replace(myAttachments.Item(intCounter2).Di splayName, ":", ""), "/", "") myAttStr = myAttStr & " " & Replace(Replace(myAttachments.Item(intCounter2).Di splayName, ":", ""), "/", "") End If Next End If adoRS("AttachmentList") = myAttStr myAttStr = "" adoRS.Update End If End With Next adoRS.Close Set adoRS = Nothing Set adoConn = Nothing Set ns = Nothing Set objFolder = Nothing End Sub Any help is appreciated, CJ |
Thread Tools | Search this Thread |
Display Modes | |
|
|
![]() |
||||
Thread | Thread Starter | Forum | Replies | Last Post |
Looping thru Inbox | RS | Outlook and VBA | 1 | March 12th 08 05:41 AM |
Looping Through and Exporting Outlook 2003 Messages | Gwhit | Outlook and VBA | 1 | October 13th 06 07:02 AM |
Problem Looping Through Contacts | Andibevan | Outlook and VBA | 4 | September 13th 06 10:14 AM |
Problems looping through Recipients in a draft message | saeongjeema via OfficeKB.com | Outlook and VBA | 1 | February 27th 06 06:12 AM |
Calendar looping through the current month? | Sydney | Outlook and VBA | 2 | February 8th 06 01:21 PM |