A Microsoft Outlook email forum. Outlook Banter

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.

Go Back   Home » Outlook Banter forum » Microsoft Outlook Email Newsgroups » Outlook and VBA
Site Map Home Register Authors List Search Today's Posts Mark Forums Read Web Partners

Looping Subfolders in this code



 
 
Thread Tools Search this Thread Display Modes
Prev Previous Post   Next Post Next
  #1  
Old April 1st 08, 11:25 PM posted to microsoft.public.outlook.program_vba
Curious Joe
external usenet poster
 
Posts: 2
Default Looping Subfolders in this code

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
Search this Thread:

Advanced Search
Display Modes

Posting Rules
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

vB code is On
Smilies are On
[IMG] code is On
HTML code is Off
Forum Jump

Similar Threads
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


All times are GMT +1. The time now is 05:03 AM.


Powered by vBulletin® Version 3.6.4
Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.Search Engine Friendly URLs by vBSEO 2.4.0
Copyright ©2004-2025 Outlook Banter.
The comments are property of their posters.