#1
|
|||
|
|||
take emails from outlook mailbox and folders to Access
Hi all,
I have some code to take the emails form outlook to access database. I was wondering how I could change the folder and subfolder where the emails should come from. Now it will take only the unread emails from the personal inbox. how can I change it to "Backup" folder that is from the: - New Line Products. I'm also trying to show if an email has attachments or not. Any help would be really great. Code:
Option Compare Database Private Sub Command14_Click() Dim TempRst As DAO.Recordset Dim rst As DAO.Recordset Dim OlApp As Outlook.Application Dim Inbox As Outlook.MAPIFolder Dim InboxItems As Outlook.Items Dim Mailobject As Object Dim db As DAO.Database Dim dealer As Integer 'DoCmd.RunSQL "Delete * from tbl_outlooktemp" Set db = CurrentDb Set OlApp = CreateObject("Outlook.Application") Set Inbox = OlApp.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox) Set TempRst = CurrentDb.OpenRecordset("tbl_OutlookTemp") ' Set InboxItems = Inbox.Items ' For Each Mailobject In InboxItems If Mailobject.UnRead Then With TempRst .AddNew !Subject = Mailobject.Subject !SenderName = Mailobject.SenderName !To = Mailobject.To !Body = Mailobject.Body !ReceivedOn = Mailobject.ReceivedOn !SentOn = Mailobject.SentOn '!Attachments = Mailobject.Attachments 'the part that does not work !SenderEmailAddress = Mailobject.SenderEmailAddress .Update Mailobject.UnRead = False End With End If Next Set OlApp = Nothing Set Inbox = Nothing Set InboxItems = Nothing Set Mailobject = Nothing Set TempRst = Nothing End Sub |
#2
|
||||
|
||||
The line that determines the folder to process is
Code:
Set Inbox = OlApp.GetNamespace("Mapi").GetDefaultFolder(6) 'Inbox Code:
Set Inbox = OlApp.GetNamespace("Mapi").GetDefaultFolder(6).Folders("Backup") You could count the attachments and then based on the count (less any graphics) determine what you add to your data table. e.g. Code:
Dim bAttach as Boolean '................ If Mailobject.Attachments.Count > 0 then bAttach = True Else bAttach = False End If '.................. !Attachments = bAttach
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#3
|
|||
|
|||
Hi Gmayor,
Is the below code counting from the top of the email box? (so 6 would be the inbox)? Code:
Set Inbox = OlApp.GetNamespace("Mapi").GetDefaultFolder(6) 'Inbox Greetings. |
#4
|
|||
|
|||
Hi,
I tried to find the next email box (group mailbox) that is: Mailbox - ~ Final Analysis, Compare Team But I can get that one using the numbers. Any ideas? Greetings. |
#5
|
||||
|
||||
Quote:
6 is the numeric equivalent of the default inbox. You can access any of the folders from VBA e.g. to get the Inbox folder for a separate Account called 'Account Name' Code:
Dim oFolder As Folder Dim oFldr As Folder Dim olNS As NameSpace Set olNS = Application.GetNamespace("Mapi") For Each oFolder In olNS.folders 'MsgBox oFolder.Name If oFolder.Name = "AccountName" Then Set oFldr = oFolder.folders("Inbox") End If Next oFolder
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#6
|
|||
|
|||
Hi Gmayor,
I found this code that works to save all the selected emails in a folder. It works great, but would be nice it was possible to adjust the above code from previouw messages to not only save the email content to a table but also the emails into a folder so I could click on a button and open the linked email. (the below code only refers to the selected emails). Any ideas how to combine both codes? Code:
Public Sub Command24_Click() Dim olItem As Outlook.MailItem Dim fName As String Dim fPath As String fPath = "C:\Messages\" For Each olItem In ActiveExplorer.Selection fName = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _ Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & _ olItem.SenderName & " - " & olItem.Subject & ".msg" fName = Replace(fName, Chr(58) & Chr(41), "") fName = Replace(fName, Chr(58) & Chr(40), "") fName = Replace(fName, Chr(34), "-") fName = Replace(fName, Chr(42), "-") fName = Replace(fName, Chr(47), "-") fName = Replace(fName, Chr(58), "-") fName = Replace(fName, Chr(60), "-") fName = Replace(fName, Chr(62), "-") fName = Replace(fName, Chr(63), "-") fName = Replace(fName, Chr(124), "-") olItem.SaveAs fPath & fName Next olItem Set olItem = Nothing End Sub |
#7
|
|||
|
|||
Hi,
I found some nice code to select an email box and move all the emails (including folders and keeping the structure), but it only creates the structure and nothing else. Well, it stucks in Code:
mItem.SaveAs StrFile, 3 Code:
Option Explicit Sub SaveAllEmails_ProcessAllSubFolders() Dim i As Long Dim j As Long Dim n As Long Dim StrSubject As String Dim StrName As String Dim StrFile As String Dim StrReceived As String Dim StrSavePath As String Dim StrFolder As String Dim StrFolderPath As String Dim StrFolderName As String Dim StrSaveFolder As String Dim StrSenderName As String Dim StrTo As String Dim Prompt As String Dim Title As String Dim iNameSpace As NameSpace Dim myOlApp As Outlook.Application Dim SubFolder As MAPIFolder Dim mItem As MailItem Dim FSO As Object Dim ChosenFolder As Object Dim Folders As New Collection Dim EntryID As New Collection Dim StoreID As New Collection Set FSO = CreateObject("Scripting.FileSystemObject") Set myOlApp = Outlook.Application Set iNameSpace = myOlApp.GetNamespace("MAPI") Set ChosenFolder = iNameSpace.PickFolder If ChosenFolder Is Nothing Then GoTo ExitSub: End If Prompt = "Please enter the path to save all the emails to" Title = "Folder Specification" StrSavePath = BrowseForFolder If StrSavePath = "" Then GoTo ExitSub: End If If Not Right(StrSavePath, 1) = "\" Then StrSavePath = StrSavePath & "\" End If Call GetFolder(Folders, EntryID, StoreID, ChosenFolder) For i = 1 To Folders.Count StrFolder = StripIllegalChar(Folders(i)) n = InStr(3, StrFolder, "\") + 1 StrFolder = Mid(StrFolder, n, 256) StrFolderPath = StrSavePath & StrFolder & "\" StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\" If Not FSO.FolderExists(StrFolderPath) Then FSO.CreateFolder (StrFolderPath) End If Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i)) For j = 1 To SubFolder.Items.Count Set mItem = SubFolder.Items(j) StrReceived = ArrangedDate(mItem.ReceivedTime) StrSubject = mItem.Subject StrName = StripIllegalChar(StrSubject) StrFolderName = SubFolder.Name StrFolderName = StripIllegalChar(StrFolderName) StrSenderName = mItem.SenderName StrSenderName = StripIllegalChar(StrSenderName) StrTo = mItem.To StrTo = StripIllegalChar(StrTo) If LCase(StrFolderName) = "inbox" Then StrFile = StrSaveFolder & "e-from_" & StrSenderName & "_" & StrReceived & "_re_" & StrName & ".msg" ElseIf LCase(StrFolderName) = "sent items" Then StrFile = StrSaveFolder & "e-to_" & StrTo & "_" & StrReceived & "_re_" & StrName & ".msg" End If StrFile = Left(StrFile, 256) mItem.SaveAs StrFile, 3 Next j Next i ExitSub: End Sub Function StripIllegalChar(StrInput) Dim RegX As Object Set RegX = CreateObject("vbscript.regexp") RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]" RegX.IgnoreCase = True RegX.Global = True StripIllegalChar = RegX.Replace(StrInput, "") ExitFunction: Set RegX = Nothing End Function Function ArrangedDate(StrDateInput) Dim StrFullDate As String Dim StrFullTime As String Dim StrAMPM As String Dim StrTime As String Dim StrYear As String Dim StrMonthDay As String Dim StrMonth As String Dim StrDay As String Dim StrDate As String Dim StrDateTime As String Dim RegX As Object Set RegX = CreateObject("vbscript.regexp") If Not Left(StrDateInput, 2) = "10" And _ Not Left(StrDateInput, 2) = "11" And _ Not Left(StrDateInput, 2) = "12" Then StrDateInput = "0" & StrDateInput End If StrFullDate = Left(StrDateInput, 10) If Right(StrFullDate, 1) = " " Then StrFullDate = Left(StrDateInput, 9) End If StrFullTime = Replace(StrDateInput, StrFullDate & " ", "") If Len(StrFullTime) = 10 Then StrFullTime = "0" & StrFullTime End If StrAMPM = Right(StrFullTime, 2) StrTime = Left(StrFullTime, 6) & StrAMPM StrYear = Right(StrFullDate, 4) StrMonthDay = Replace(StrFullDate, "/" & StrYear, "") StrMonth = Left(StrMonthDay, 2) StrDay = Right(StrMonthDay, Len(StrMonthDay) - 3) If Len(StrDay) = 1 Then StrDay = "0" & StrDay End If StrDate = StrYear & StrMonth & StrDay StrDateTime = StrDate & "_" & StrTime RegX.Pattern = "[\:\/\ ]" RegX.IgnoreCase = True RegX.Global = True ArrangedDate = RegX.Replace(StrDateTime, "") ExitFunction: Set RegX = Nothing End Function Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As MAPIFolder) Dim SubFolder As MAPIFolder Folders.Add Fld.FolderPath EntryID.Add Fld.EntryID StoreID.Add Fld.StoreID For Each SubFolder In Fld.Folders GetFolder Folders, EntryID, StoreID, SubFolder Next SubFolder ExitSub: Set SubFolder = Nothing End Sub Function BrowseForFolder(Optional OpenAt As String) As String Dim ShellApp As Object Set ShellApp = CreateObject("Shell.Application"). _ BrowseForFolder(0, "Please choose a folder", 0, OpenAt) BrowseForFolder = ShellApp.self.Path Select Case Mid(BrowseForFolder, 2, 1) Case Is = ":" If Left(BrowseForFolder, 1) = ":" Then BrowseForFolder = "" End If Case Is = "\" If Not Left(BrowseForFolder, 1) = "\" Then BrowseForFolder = "" End If Case Else BrowseForFolder = "" End Select ExitFunction: Set ShellApp = Nothing End Function |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
how to synchronize emails in certain folders when upgrade Outlook 2010 to Outlook 201 | davip | Outlook | 0 | 07-30-2013 09:07 PM |
Moving emails in shared mailbox to personal mailbox | hlock | Outlook | 0 | 12-12-2012 02:32 PM |
Outlook 2010 & Mailbox Access | Stkitts11 | Outlook | 0 | 04-10-2012 06:48 AM |
Merging outlook folders and emails | rudihorvath | Outlook | 1 | 03-16-2012 07:03 AM |
Outlook 07 Not Fetching Emails in Random folders | miccguido | Outlook | 1 | 02-14-2012 01:51 PM |