Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- Sub extractFolders(strMailboxName, intFullName, objNameSpace)
- 'On Error Resume Next
- Dim objFolder
- Dim objMsg
- Dim strAttachments
- Dim Atmt
- Dim strSenderEmailAddress
- Dim strRecipientEmails
- Dim RecptEmail
- Dim objEmails
- Dim intItemCount
- For Each objFolder In objNameSpace.Folders
- DoEvents
- If objFolder.Name = strMailboxName Or (InStr(intFullName & "\" & objFolder.Name, "\" & strMailboxName & "\") > 0 And _
- objFolder.Name <> "RSS Feeds" And _
- objFolder.Name <> "Junk E-mail" And _
- objFolder.Name <> "News Feed" And _
- objFolder.Name <> "Sync Issues" And _
- objFolder.Name <> "Tasks" And _
- objFolder.Name <> "Suggested Contacts" And _
- objFolder.Name <> "Sent Items" And _
- objFolder.Name <> "Quick Step Settings" And _
- objFolder.Name <> "Outbox" And _
- objFolder.Name <> "Junk E-Mail" And _
- objFolder.Name <> "Journal" And _
- objFolder.Name <> "Drafts" And _
- objFolder.Name <> "Deleted Items" And _
- objFolder.Name <> "Conversation Action Settings" And _
- objFolder.Name <> "Contacts" And _
- objFolder.Name <> "Calendar" And _
- objFolder.Name <> "Insulator" And _
- objFolder.Name <> "Notes") Then
- Set objEmails = objFolder.Items
- objEmails.Sort "[ReceivedTime]", True
- Set objEmails = objEmails.Restrict("[ReceivedTime] > '" & DateAdd("d", -1, DateAdd("m", -6, Date)) & "'")
- intItemCount = objEmails.count
- Do While intItemCount > 0
- DoEvents
- If TypeName(objEmails(intItemCount)) = "MailItem" Then
- Set objMsg = objEmails(intItemCount)
- With objMsg
- strAttachments = ""
- For Each Atmt In .Attachments
- If Atmt <> "Picture (Device Independent Bitmap)" Then
- If Left(Atmt.FileName, 5) <> "image" And Right(Atmt.FileName, 3) <> "png" Then
- If strAttachments <> "" Then strAttachments = strAttachments & "; "
- strAttachments = strAttachments & Atmt.FileName
- End If
- End If
- Next
- strSenderEmailAddress = .SenderEmailAddress
- If InStr(strSenderEmailAddress, "/") > 0 Then
- 'strSenderEmailAddress = .Sender.GetExchangeUser.PrimarySmtpAddress
- End If
- strRecipientEmails = ""
- For Each RecptEmail In .Recipients
- If strRecipientEmails <> "" Then strRecipientEmails = strRecipientEmails & "; "
- 'If InStr(RecptEmail.Address, "/") > 0 Then
- ' Err.Clear
- ' strRecipientEmails = strRecipientEmails & RecptEmail.AddressEntry.GetExchangeUser.PrimarySmtpAddress
- ' If Err.Number <> 0 Then
- ' strRecipientEmails = strRecipientEmails & "Unresolved Recipient Address"
- ' Err.Clear
- ' End If
- 'Else
- strRecipientEmails = strRecipientEmails & RecptEmail '.AddressEntry.Address
- 'End If
- Next
- saveEmailData .EntryID, .Subject, .SenderName, strSenderEmailAddress, .To, strRecipientEmails, strAttachments, .CC, .flagStatus, .TaskCompletedDate, .Categories, .ReceivedTime, intFullName & "\" & objFolder.Name, strMailboxName, .Body
- End With
- End If
- intItemCount = intItemCount - 1
- Loop
- If objFolder.Folders.count > 0 Then
- extractFolders strMailboxName, intFullName & "\" & objFolder.Name, objFolder
- End If
- End If
- Next
- End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement