The following code is to count the number of emails in a particular SharedMailbox or its subfolder.
I am having trouble selecting a subfolder in SharedMailbox.
I have read a number of resources on GetSharedDefaultFolder including this one.
However, struggling to put it together correctly.
Would be really great if you could help with this.
I am experiencing the following error while running the code.
Run-time error '-2147221233 (80040010f)' Automation error
Sub CountInboxSubjects()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFldr As Outlook.MAPIFolder
Dim MyFolder1 As Outlook.MAPIFolder
Dim MyFolder2 As Outlook.MAPIFolder
Dim MyFolder3 As Outlook.MAPIFolder
Dim olMailItem As Outlook.MailItem
Dim propertyAccessor As Outlook.propertyAccessor
Dim olItem As Object
Dim dic As Dictionary
Dim i As Long
Dim Subject As String
Dim val1 As Variant
Dim val2 As Variant
val1 = ThisWorkbook.Worksheets("Data").Range("I2")
val2 = ThisWorkbook.Worksheets("Data").Range("I3")
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
'Set olFldr = olNs.GetDefaultFolder(olFolderInbox)
Set olShareName = olNs.CreateRecipient("Shared_MailBox")
Set olFldr = olNs.GetSharedDefaultFolder(olShareName, olFolderInbox)
MsgBox (olFldr)
Set MyFolder1 = olFldr.Folders("Sub_Folder")
MsgBox (MyFolder1)
Set MyFolder2 = MyFolder1.Folders("Sub_Sub_Folder")
MsgBox (MyFolder2)
Set MyFolder3 = MyFolder1.Folders("Sub_Sub_Folder2")
MsgBox (MyFolder3)
If ThisWorkbook.Worksheets("EPI_Data").Range("I5") = "Inbox" Then
MyFolder = olFldr
ElseIf ThisWorkbook.Worksheets("EPI_Data").Range("I5") = "Sub_Folder" Then
MyFolder = MyFolder1
ElseIf ThisWorkbook.Worksheets("EPI_Data").Range("I5") = "Sub_Sub_Folder" Then
MyFolder = MyFolder2
ElseIf ThisWorkbook.Worksheets("EPI_Data").Range("I5") = "Sub_Sub_Folder" Then
MyFolder = MyFolder3
End If
Set olItem = MyFolder.Items
'Set myRestrictItems = olItem.Restrict("[ReceivedTime]>'" & Format$("01/01/2019 00:00AM", "General Date") & "' And [ReceivedTime]<'" & Format$("01/02/2019 00:00AM", "General Date") & "'")
Set myRestrictItems = olItem.Restrict("[ReceivedTime]>'" & Format$(val1, "General Date") & "' And [ReceivedTime]<'" & Format$(val2, "General Date") & "'")
For Each olItem In myRestrictItems
If olItem.Class = olMail Then
Set propertyAccessor = olItem.propertyAccessor
Subject = propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E1D001E")
If dic.Exists(Subject) Then dic(Subject) = dic(Subject) + 1 Else dic(Subject) = 1
End If
Next olItem
With ActiveSheet
.Columns("A:B").Clear
.Range("A1:B1").Value = Array("Count", "Subject")
For i = 0 To dic.Count - 1
.Cells(i + 2, "A") = dic.Items()(i)
.Cells(i + 2, "B") = dic.Keys()(i)
Next
End With
End Sub
After trouble-shooting, I am aware the following step has issues.
Set MyFolder1 = olFldr.Folders("Sub_Folder")
MsgBox (MyFolder1)
I expect the msgbox will return the subfolder name but it's reporting error.
Run-time error '-2147221233 (80040010f)' Automation error
I couldn't find out why. can anyone please help..
Try working with Recipient email address, if recipient name then Attempt to resolve Recipient against the Address Book...
Option Explicit
Public Sub Example()
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
Dim olNs As Outlook.Namespace
Set olNs = olApp.GetNamespace("MAPI")
Dim Recip As Outlook.Recipient
Dim Inbox As Outlook.MAPIFolder
Set Recip = olNs.CreateRecipient("0m3r#Email.com")
Recip.Resolve
If Recip.Resolved Then
Set Inbox = olNs.GetSharedDefaultFolder _
(Recip, olFolderInbox)
End If
Inbox.Display
End Sub
Of course, you must resolve a recipient's name or address against the address book before accessing shared folders.
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set olShareName = olNs.CreateRecipient("Shared_MailBox")
olShareName.Resolve
If Recip.Resolved Then
Set olFldr = olNs.GetSharedDefaultFolder(olShareName, olFolderInbox)
...
End If
But the cause of the issue with accessing a subfolder is different...
First of all, try to uncheck Download shared folders checkbox checked on the Advanced tab of your Exchange account properties dialog. See the Detecting if ‘Download Shared Folders’ is Checked in Outlook article for more information.
Second, please take a look at the By default, shared mail folders are downloaded in Cached mode in Outlook 2010 and Outlook 2013 article. What value do you have set for the CacheOthersMail key on the PC?
See Accessing subfolders within shared mailbox for more information.
Related
I'm running a macro on excel to populate a shared outlook calendar. The thing is, I have no problem to add appointments to the calendar, but when dates change I want to suppress old ones, to replace them by new events.
I have a code that is supposed to filter the items I want to suppress, but for some reason the TypeName of my Outlook events remains on "Nothing", and I can't figure out why.
Here is the test event in my calendar that needs to be suppressed.
Here is the code:
Sub SuppressOutlookEvents()
Dim olApp As Outlook.Application
Dim objAppointment As Outlook.AppointmentItem
Dim objAppointments As Outlook.MAPIFolder
Dim objNameSpace As Outlook.Namespace
Dim objProperty As Outlook.UserProperty
Dim OutlookStartTime, OutlookEndTime As Date
Dim sFilter As Variant
Worksheets("to_be_removed").Activate
OutlookStartTime = DateValue("10-15-2019")
Set olApp = CreateObject("Outlook.Application")
Set objNameSpace = olApp.GetNamespace("MAPI")
Set objAppointments = objNameSpace.GetDefaultFolder(olFolderCalendar)
sFilter = "[Start] = OutlookStartTime And [Subject] = 'Test'"
Set objAppointment = objAppointments.Items.Find(sFilter)
```
MsgBox (TypeName(objAppointment)) 'Here it displays "Nothing"
If Not TypeName(objAppointment) = "Nothing" Then
objAppointment.Delete
End If
```
Set objAppointment = Nothing
Set objAppointments = Nothing
End Sub
I don't know if the filter doesn't recognize the event or if it's for another reason...
EDIT: thanks to the answers, I finally have a working code:
Sub suppress_outlook_event(Optional row As Integer = 2)
Dim olApp As Outlook.Application
Dim objAppointments As Outlook.MAPIFolder
Dim objNameSpace As Outlook.Namespace
Dim objProperty As Outlook.UserProperty
Dim OutlookStartTime, OutlookEndTime As Date
Dim sFilter As Variant
OutlookStartTime = Format("09/19/19" & " " & "8:00 AM", "mm/dd/yyyy hh:mm AMPM")
Set olApp = CreateObject("Outlook.Application")
Set objNameSpace = olApp.GetNamespace("MAPI")
Set objAppointments = objNameSpace.GetDefaultFolder(olFolderCalendar)
o_title = "Example"
sFilter = "[Subject] = " & Chr(34) & o_title & Chr(34)
objAppointments.Items.IncludeRecurrences = True
objAppointments.Items.Sort "[Start]"
Set objAppointment = objAppointments.Items.Restrict(sFilter)
objAppointment.IncludeRecurrences = True
If Not objAppointment.Count = 0 Then
obj_count = objAppointment.Count
For i = 1 To obj_count
objAppointment(obj_count + 1 - i).Delete
Next i
End If
Set objAppointment = Nothing
Set objAppointments = Nothing
End Sub
This question should like be closed as duplicate, however I've made the required updates to your code.
Key points when using Find or Restrict with Appointments.
Make sure IncludeRecurrences Property is set to True
Ensure date/time is formatted as shown below and is parsed as a string as opposed to supplied as an actual date/datetime value.
I'm a bit skeptical on how it will handle multiple appointments with the same subject and start date (if time is not supplied or conflicting appointments exist). Past experience indicates it will just return the first one. So it may be better to use the Restrict method and iterate through the returned item collection otherwise you'll run the risk of missing an appointment.
Items.Restrict appointments in Outlook Calendar (VBA)
Sub SuppressOutlookEvents()
Dim olApp As Outlook.Application
Dim objAppointment As Outlook.AppointmentItem
Dim objAppointments As Outlook.MAPIFolder
Dim objNameSpace As Outlook.NameSpace
Dim objProperty As Outlook.UserProperty
Dim OutlookStartTime, OutlookEndTime As Date
Dim sFilter As Variant
Worksheets("to_be_removed").Activate
OutlookStartTime = Format("9-24-2019 12:30PM", "mm/dd/yyyy hh:mm AMPM")
Set olApp = CreateObject("Outlook.Application")
Set objNameSpace = olApp.GetNamespace("MAPI")
Set objAppointments = objNameSpace.GetDefaultFolder(olFolderCalendar)
sFilter = "[Start] = '" & OutlookStartTime & "' And [Subject] = 'test'"
objAppointments.Items.IncludeRecurrences = True
objAppointments.Items.Sort "[Start]"
Set objAppointment = objAppointments.Items.Find(sFilter)
MsgBox (TypeName(objAppointment)) 'Here it displays "Nothing"
If Not TypeName(objAppointment) = "Nothing" Then
objAppointment.Delete
End If
Set objAppointment = Nothing
Set objAppointments = Nothing
End Sub
The given code works successfully. It searches for an email subject in outlook Sent Items folder. The search happens based on a specific date within specific time period. For example, the code below looks for the email title "Test Email Sent on Friday" that was sent on July 20, 2018 between 12:00 AM and 11:59 PM.
In addition to my existing search criteria, how can I filter out emails that were sent out to specific users. I want to check [To] field. If [To] had recipients x#email.com, y#email.com, or z#email.com, then do not return the search results. The search should return "Yes. Email found" if [To] section doesn't have either of these emails: x#email.com, y#email.com, or z#email.com.
Public Function is_email_sent()
Dim olApp As Object
Dim olNs As Object
Dim olFldr As Object
Dim olItms As Object
Dim objItem As Object
On Error Resume Next
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.Folders("myemail#example.com").Folders("Sent Items")
Set olItms = olFldr.Items
Set objItem = olItms.Restrict("[Subject] = ""Test Email Sent on Friday"" And [SentOn] >= ""7/20/2018 12:00 AM"" AND [SentOn] <= ""7/20/2018 11:59 PM""")
If objItem.Count = 0 Then
MsgBox "No. Email not found"
Else
MsgBox "Yes. Email found"
End If
Set olApp = Nothing
Set olNs = Nothing
Set olFldr = Nothing
Set olItms = Nothing
Set objItem = Nothing
End Function
This may not be the approach you were seeking, but if you add a project reference to Outlook, you can use the native datatypes instead of treating everything as an object, and from there Intellisense can be your best friend.
The advantage is that instead of guessing what the query string is in the Restrict method, you can simply loop through all mail items and then use the native properties to find the one(s) you are looking for. Here is an example with the specifications you identified above.
Public Function is_email_sent()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFldr As Outlook.Folder
Dim olItms As Outlook.Items
Dim objItem As Outlook.MailItem
Dim recipients() As String
Dim found As Boolean
found = False
On Error Resume Next
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.Folders("myemail#example.com").Folders("Sent Items")
For Each objItem In olFldr.Items
If objItem.Subject = "Test Email Sent on Friday" And _
objItem.SentOn >= DateSerial(2018, 7, 20) And _
objItem.SentOn < DateSerial(2018, 7, 21) Then
If InStr(objItem.To, "x#email.com") = 0 And _
InStr(objItem.To, "y#email.com") = 0 And _
InStr(objItem.To, "z#email.com") = 0 Then
found = True
Exit For
End If
End If
Next objItem
And of course, you can strip out the class references and it will still work, but like I said, let Intellisense be your friend.
There are some micro-optimizations that are in order (ie pre-declaring the dates rather than running DateSerial within each loop iteration), but this is a notional idea to demonstrate my point.
You can check the addresses in the items already found with Restrict.
Public Function is_email_sent()
Dim olApp As Object
Dim olNs As Object
Dim olFldr As Object
Dim olFldrItms As Object ' Outlook.Items
Dim objResItems As Object ' Outlook.Items
Dim objResItem As Object
'On Error Resume Next ' Learn how to use this.
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set olNs = GetNamespace("MAPI")
Set olFldr = olNs.Folders("myemail#example.com").Folders("Sent Items")
Set olFldrItms = olFldr.Items
Set objResItems = olFldrItms.Restrict("[Subject] = ""Test Email Sent on Friday"" And [SentOn] >= ""7/20/2018 12:00 AM"" AND [SentOn] <= ""7/20/2018 11:59 PM""")
If objResItems.count = 0 Then
MsgBox "Email not found."
Else
For Each objResItem In objResItems
Debug.Print objResItem.Subject
Debug.Print objResItem.To
If InStr(objResItem.To, "x#email.com") = 0 And _
InStr(objResItem.To, "y#email.com") = 0 And _
InStr(objResItem.To, "z#email.com") = 0 Then
MsgBox "Email to " & objResItem.To & vbCr & vbCr & "No bad addresses."
Exit For
End If
Debug.Print "At least one bad address in the mail."
Next
End If
Set olApp = Nothing
Set olNs = Nothing
Set olFldr = Nothing
Set olFldrItms = Nothing
Set objResItems = Nothing
Set objResItem = Nothing
End Function
Here is the solution
Public Function is_email_sent()
Dim olApp As Object
Dim olNs As Object
Dim olFldr As Object
Dim olItms As Object
Dim objItem As Object
On Error Resume Next
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.Folders("myemail#example.com").Folders("Sent Items")
Set olItms = olFldr.Items
Set objItem = olItms.Restrict("[Subject] = ""Test Email Sent on Friday"" And [SentOn] >= ""7/20/2018 12:00 AM"" AND [SentOn] <= ""7/20/2018 11:59 PM""")
If objItem.Count = 0 Then
is_email_sent_out_to_business = False
Else '*** Solution
Dim o As Object
For Each o In objItem
If Not (InStr(o.To, "x#email.com") > 0 Or InStr(o.To, "y#email.com") > 0) Then
MsgBox "Yes. Email found"
Exit For
Else
MsgBox "No. Email not found"
End If
Next
End If
Set olApp = Nothing
Set olNs = Nothing
Set olFldr = Nothing
Set olItms = Nothing
Set objItem = Nothing
End Function
I'm trying to get the .To email address from my sent box using Excel-VBA. However, To only returns the name not the email address. After some search found that the recipient should be what I'm looking for. Tried by following the msdn guide, but the code does not seem to work.
Sub test()
Dim objoutlook As Object
Dim objNamespace As Object
Dim olFolder As Object
Dim OutlookMail As outlook.MailItem
Set objoutlook = CreateObject("Outlook.Application")
Set objNamespace = objoutlook.GetNamespace("MAPI")
Set olFolder = objNamespace.GetDefaultFolder(olFolderSentMail)
Set OutlookMail = objoutlook.CreateItem(olMailItem)
Dim recips As outlook.Recipients
Dim recip As outlook.Recipient
Dim pa As outlook.PropertyAccessor
Const PR_SMTP_ADDRESS As String = _
"http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set recips = OutlookMail.Recipients
For Each recip In recips 'Something is wrong here
Set pa = recip.PropertyAccessor
Debug.Print recip.Name & " SMTP=" & pa.GetProperty(PR_SMTP_ADDRESS)
Next
Set olFolder = Nothing
Set objNamespace = Nothing
Set objoutlook = Nothing
End Sub
I'm not really familiar with VBA, please guide along.
You can try this:
Private Sub GetRecipientSMTP(objAllRecip As Outlook.Recipients)
Dim objRecip As Outlook.Recipient
Dim objExUser As Outlook.ExchangeUser
Dim objExDisUser As Outlook.ExchangeDistributionList
For Each objRecip In objAllRecip
Select Case objRecip.AddressEntry.AddressEntryUserType
Case 0, 10
Set objExUser = objRecip.AddressEntry.GetExchangeUser
If Not objExUser Is Nothing Then _
Debug.Print objExUser.PrimarySmtpAddress '/* or copy somewhere */
Case 1
Set objExDisUser = objRecip.AddressEntry.GetExchangeDistributionList
If Not objExDisUser Is Nothing Then _
Debug.Print objExDisUser.PrimarySmtpAddress '/* or copy somewhere */
Case Else
'/* Do nothing, recipient not recognized */
End Select
Next
End Sub
You can run it in your sub like below using recips from your code (or see sample usage).
GetRecipientSMTP recips
Basically, this will check on the each Recipient on Recipients you supplied. Then will check if it is an ExchangeUser type or ExchangeDistributionList before returning the PrimartSMTPAddress. HTH.
Sample Usage:
Sub marine()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFolder As Outlook.Folder
Dim olMail As Outlook.MailItem
Dim i As Integer
Set olApp = GetObject(, "Outlook.Application") '/* assuming OL is running */
Set olNs = olApp.GetNamespace("MAPI")
Set olFolder = olNs.GetDefaultFolder(olFolderInbox)
With olFolder
For i = .Items.Count To 1 Step -1
If TypeOf .Items(i) Is MailItem Then
Set olMail = .Items(i)
GetRecipientSMTP olMail.Recipients
End If
Exit For '/* I just want to process the first mail */
Next
End With
End Sub
Note: I used early binding and set reference to Outlook Object Library.
Quick Example
Option Explicit
Public Sub Example()
Dim OUTLOOK_APP As Outlook.Application
Dim olNs As Outlook.Namespace
Dim SENT_FLDR As MAPIFolder
Dim Items As Outlook.Items
Dim olRecip As Outlook.Recipient
Dim olRecipAddress As String
Dim i As Long
Set OUTLOOK_APP = New Outlook.Application
Set olNs = OUTLOOK_APP.GetNamespace("MAPI")
Set SENT_FLDR = olNs.GetDefaultFolder(olFolderSentMail)
Set Items = SENT_FLDR.Items
For i = Items.Count To 1 Step -1
DoEvents
If Items(i).Class = olMail Then
For Each olRecip In Items(i).Recipients
olRecipAddress = olRecip.Address
Debug.Print olRecipAddress
Next
End If
Next
End Sub
this is my way of getting Recipient email Address. I hope it would help you.
Sub CopyCurrentContact()
Dim objRcp As Outlook.Recipient
Dim objRcpS As Outlook.Recipients
Dim rcpStr As String
Set outLookObj = CreateObject("Outlook.Application")
Set InspectorObj = outLookObj.ActiveInspector
Set ItemObj = InspectorObj.CurrentItem
Set objRcpS = ItemObj.Recipients
For Each objRcp In objRcpS
rcpStr = objRcp.Address & "; " & rcpStr
Debug.Print rcpStr
Next objRcp
End Sub
I am trying to pull the sender's email address from every email in an inbox folder
I am not having any problems until I reach my For command for each email in the folder.
If I use the code as it is now I run into an error because olSender is not Dim As Variant, but if I change it to Dim As Variant I cannot Dim it as an Outlook.MailItem to retrieve the senderEmailAddress.
I'm assuming a nested For loop is the solution. Outlook 2013 is the version.
Sub ExportToExcel()
'EXCEL
'Opening Excel workbook
Dim oXLApp As Object, oXLwb As Object, oXLws As Object
Dim lRow As Long
On Error Resume Next
Set oXLApp = GetObject(, "Excel.Application")
'~~> If not found then create new instance
If Err.Number <> 0 Then
Set oXLApp = CreateObject("Excel.Application")
End If
Err.Clear
On Error GoTo 0
oXLApp.Visible = True
Set oXLwb = oXLApp.Workbooks.Open("C:\Users\******\Documents\******.xlsm")
Set oXLws = oXLwb.Sheets("Sheet1")
oXLws.Range("A" & 1).Select
'OUTLOOK
'Opening Outlook folder
Dim olNS As Outlook.NameSpace
Dim objOwner As Outlook.Recipient
Set olNS = Application.GetNamespace("MAPI")
Set objOwner = olNS.CreateRecipient("*********#email.com")
objOwner.Resolve
If objOwner.Resolved Then
Set BouncedEmailsFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderInbox).Folders("Bounced Emails")
End If
Dim olItms As Outlook.Items
Dim olMail As Variant
Dim i As Long
Dim olSender As Outlook.MailItem
Set olItms = BouncedEmailsFolder.Items
olItms.Sort ("Subject")
i = 1
For Each olSender In olItms
oXLws.Select
oXLws.Cells(i, 1).Select
oXLws.Cells(i, 1).Value = olSender.SenderEmailAddress
i = i + 1
Next olSender
Set BouncedEmailsFolder = Nothing
Set olNS = Nothing
End Sub
Your code works for me when set to my default inbox.
olNS.GetDefaultFolder(olFolderInbox)
I wonder if you're not coming across non-mail items in your bounced emails? You may want to try the code below, which will retrieve mail items only (instead of also trying to extract the sender for meeting requests, task assignments, etc):
For Each olSender In olItms
If TypeOf olSender Is MailItem Then
oXLws.Select
oXLws.Cells(i, 1).Select
oXLws.Cells(i, 1).Value = olSender.SenderEmailAddress
i = i + 1
End If
Next olSender
I'm trying to move emails from an inbox folder (named "A_Classer") into a Outlook public folder (variable name for the destination folder is olFolder)
I tried the getshareddefaultfolder method and the OpenSharedFolder method but I couldn't solve my syntax problem
The name of the shared folder is "Québec" and it's path (from the property Windows) is ("Dossiers publics - guillaume.hebert#cima.ca/Tous les dossiers publics/Québec")
Code stops at : set olFolder...
Here's my code below with all the versions I tried
Sub move_to_public_folder()
Dim msg As Outlook.MailItem
Dim olFolder As Outlook.Folder 'public folder where I want the email to be moved
Dim sourceFolder As Outlook.Folder 'current folder of the emails that are to be moved
Dim OlApp As Object
Dim myNamespace As Outlook.Namespace
Dim myRecipient As Outlook.Recipient
Set OlApp = CreateObject("Outlook.Application") 'Outlook application call
Set myNamespace = OlApp.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("Guillaume Hébert")
myRecipient.Resolve
If myRecipient.Resolved Then
Cells(1, 1) = Cells(1, 1) + 1
End If
Set olFolder = myNamespace.OpenSharedFolder("Québec") 'FIRST try I made
'Set olFolder = myNamespace.OpenSharedFolder _ 'Second try I made
'("Dossiers publics - guillaume.hebert#cima.ca/Tous les dossiers publics/Québec")
'Set olFolder = myNamespace.GetSharedDefaultFolder _ 'Last try I made
'(myRecipient, olPublicFoldersAllPublicFolders)
Set sourceFolder = Session.GetDefaultFolder(sourceFolderInbox)
Set sourceFolder = sourceFolder.Folders("A_Classer")
If sourceFolder Is Nothing Then Exit Sub
I = sourceFolder.Items.Count
nbre_op = I 'détermine combien de courriel dans le répertoire
I = 1
While I <= nbre_op
Set msg = olFolder.Items(1)
msg.Move olFolder
I = I + 1
Wend
Set OlApp = Nothing
End Sub
Thank you in advance for all the help you will kindly provide
Are you connected to the Exchange server?
If you use the OpenSharedFolder method you need to specify the URL. This method is used to access the following shared folder types:
Webcal calendars (webcal://mysite/mycalendar)
RSS feeds (feed://mysite/myfeed)
Microsoft SharePoint Foundation folders (stssync://mysite/myfolder)
iCalendar calendar (.ics) files
vCard contact (.vcf) files
Outlook message (.msg) files
I'd recommend using the GetSharedDefaultFolder method which returns a Folder object that represents the specified default folder for the specified user. For example, you can get the Inbox folder, then you can find the required one.
What error do you get in the code when you run the following line?
'Set olFolder = myNamespace.GetSharedDefaultFolder(myRecipient, olPublicFoldersAllPublicFolders)
Found it! Tx to #Eugene and #xmojmr.
Sub move_to_public_folder()
Dim msg As Outlook.MailItem
Dim olFolder As Outlook.Folder 'source folder
Dim objFolder As Outlook.Folder 'target folder
'Dim sourceFolder As Outlook.Folder 'current folder of the emails that are to be moved
Dim OlApp As Object
'Dim fldr As Outlook.Folder
Dim chemin_repertoire_outlook_cible As String 'path containing the target folder
Dim myNamespace As Outlook.Namespace
Dim myRecipient As Outlook.Recipient
Set OlApp = CreateObject("Outlook.Application") 'Outlook application call
Set myNamespace = OlApp.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("Guillaume Hébert")
myRecipient.Resolve
If myRecipient.Resolved Then
Cells(1, 1) = Cells(1, 1) + 1
End If
Set OlApp = CreateObject("Outlook.Application") 'Outlook application call
Set olFolder = Session.GetDefaultFolder(olFolderInbox)
Set olFolder = olFolder.Folders("A_Classer")
lig = 11
col = 4
chemin_repertoire_outlook_cible = Cells(lig, col) 'target folder name setting
Set objFolder = GetFolder(chemin_repertoire_outlook_cible)
I = olFolder.Items.Count
nbre_op = I
I = 1
While I <= nbre_op 'loop to move all msg in source folder (olFolder)
Set msg = olFolder.Items(1)
msg.Move objFolder
I = I + 1
Wend
Set OlApp = Nothing
End Sub
The function GetFolder is as follow
Public Function GetFolder(strFolderPath As String) As MAPIFolder
' source of this function is: http://www.outlookcode.com/d/code/getfolder.htm
' strFolderPath needs to be something like
' "Public Folders\All Public Folders\Company\Sales" or
' "Personal Folders\Inbox\My Folder"
Dim objApp As Outlook.Application
Dim objNS As Outlook.Namespace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.Folder
Dim arrFolders() As String
Dim I As Long
On Error Resume Next
strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objApp = Outlook.Application
Set objNS = objApp.GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For I = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(I))
If objFolder Is Nothing Then
Exit For
End If
Next
End If
Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Function
Hope it could help someone else sometime.