i need to sync my 2 calendars of my 2 accounts in outlook, is that possible?
thanks
I must insert a for each command for read all Appointments in calendar Account 1 and copy him to calendar of account 2.
this is possible?
My Start Is:
Dim oApp As Outlook.Application
Dim oCalFolder As Outlook.MAPIFolder
Dim oAppt As Outlook.AppointmentItem
Dim sOldText As String
Dim sNewText As String
Dim iCalChangedCount As Integer
oApp = New Outlook.Application
oCalFolder = oApp.Application.Session.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderCalendar)
For Each oAppt In oCalFolder.Items
If Year(oAppt.Start) >= Year(Now()) Then
Debug.Print(String.Concat("APPUTAMENTO: ", oAppt.Subject, " INI: ", oAppt.Start, " END: ", oAppt.End))
***-------
INSERT CODE FOR ADD ITEMS TO CALENDAR OF ACCOUNT 2
-------***
End If
Next
oAppt = Nothing
oCalFolder = Nothing
Related
I found VBA code to sync my Outlook calendar with OneNote.
On line 7, I get
User-defined type not defined.
I have One Note 15 and Outlook 16 selected in references.
Sub SyncCalendarWithOneNote()
Dim olApp As Outlook.Application
Dim olCalendar As Outlook.Folder
Dim olItems As Outlook.Items
Dim olItem As Object
Dim onApp As OneNote.Application
Dim onNotebook As OneNote.Notebook
Dim onSection As OneNote.Section
Dim onPage As OneNote.Page
Dim onPageContent As String
Dim onPageID As String
' Connect to Outlook and OneNote
Set olApp = Outlook.Application
Set onApp = OneNote.Application
' Get the calendar folder and its items
Set olCalendar = olApp.Session.GetDefaultFolder(olFolderCalendar)
Set olItems = olCalendar.Items
' Loop through the calendar items
For Each olItem In olItems
' Check if the item is an appointment
If TypeOf olItem Is Outlook.AppointmentItem Then
' Get the appointment information
Dim olSubject As String
Dim olStart As Date
Dim olEnd As Date
olSubject = olItem.Subject
olStart = olItem.Start
olEnd = olItem.End
' Create a OneNote page for the appointment
Set onNotebook = onApp.ActiveNotebook
Set onSection = onNotebook.Sections("Calendar")
onApp.CreateNewPage Onenote.nsHierarchyScopeSection, onSection.ID, onPageID
Set onPage = onApp.GetPageContent(onPageID)
onPageContent = "Subject: " & olSubject & vbCrLf & _
"Start: " & olStart & vbCrLf & _
"End: " & olEnd
onApp.UpdatePageContent onPage.ID, onPageContent
End If
Next
' Clean up
Set olCalendar = Nothing
Set olItems = Nothing
Set olItem = Nothing
Set onApp = Nothing
Set onNotebook = Nothing
Set onSection = Nothing
Set onPage = Nothing
End Sub
I want to sync Outlook Calendar with OneNote where a new note will be created for each calendar event.
Having problems moving Outlook specific mail item to subfolder. I have spent time with an Outlook MVP on Access Vba Code To Move Outlook Mail Item To Different Folder Fails - Sometimes to figure this out.
Just determined that Windows 10 Access and Outlook 2019 show the same behavior. so it must be in the code??
Maybe need an experienced Access person to take a look.
I have verified that:
Dim Mailobject As Outlook.MailItem
Dim myDestFolder As Outlook.MAPIFolder
immediately before the MOVE code, I have verified that Mailobject is still defined and is what I want by printing mailobject.subject and mailobject.sender.
I have verified myDestFolder by printing mydestfolder.name and mydestfolder.folderpath
Note that the code does work occasionally but certainly not very often.
I have listed below my code without the processing I do on each message and hiding an email address:
Public Sub ReadInbox()
Dim a As Boolean
'''http://www.blueclaw-db.com/read_email_access_outlook.htm
Dim TempRst As DAO.Recordset
Dim TempRst2 As DAO.Recordset
Dim TempRst3 As DAO.Recordset
Dim TempRst4 As DAO.Recordset
Dim rst As DAO.Recordset
Dim mynamespace As Outlook.NameSpace
Dim myOlApp As Outlook.Application
On Error Resume Next
Set myOlApp = GetObject(, "outlook.Application")
If Err.Number <> 0 Then
Set myOlApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
Set mynamespace = myOlApp.GetNamespace("MAPI")
Dim Inbox As Outlook.MAPIFolder
Dim InboxItems As Outlook.Items
Dim Mailobject As Outlook.MailItem
Dim db As DAO.Database
Dim selstr As String
Dim myDestFolder As Outlook.MAPIFolder
Dim myInbox As Outlook.folder
Dim myInbox2 As Outlook.MAPIFolder
Dim myitems As Outlook.Items
Dim strFilter As String
' let the user choose which account to use
Set myaccounts = myOlApp.GetNamespace("MAPI").Stores
For i = 1 To myaccounts.Count
If myaccounts.Item(i).DisplayName = "volunteerform#?????.org" Then
Set Items = GetFolderPath("volunteerform#?????.org\inbox").Items
Set myInbox2 = mynamespace.Folders("volunteerform#?????.org")
Exit For
End If
Next
If myInbox2 Is Nothing Then
'If Items Is Nothing Then
MsgBox ("mailbox not found")
Exit Sub ' avoid error if no account is chosen
End If
'
'''''Set InboxItems = myInbox2.Items
Set InboxItems = Items
'
For Each Mailobject In InboxItems
If Mailobject.Subject <> "test" Then GoTo NextMessage
MsgBox ("found one message")
'**** do my processing here *****
On Error GoTo 0
'Set myDestFolder = GetFolderPath("volunteerform#????.org\inbox\Volunteeremailsprocessed")
Set myDestFolder = myInbox2.Folders("Inbox")
Set myDestFolder = myDestFolder.Folders("Volunteeremailsprocessed")
'Set myDestFolder = myInbox2.Folders("Volunteeremailsprocessed")
Stop
Mailobject.Move myDestFolder
NextMessage:
' Next email message
Next Mailobject
'''Set OlApp = Nothing
Set myInbox2 = Nothing
Set InboxItems = Nothing
Set Mailobject = Nothing
Exit Sub
error_Handling:
Stop
Dim errornumber As String
Dim errordescr As String
errornumber = Err.Number
errordescr = Err.Description
MsgBox (errornumber + " " + errordesc)
Exit Sub
End Sub
Note that I have tried this in windows 10 with Access 2019 and Outlook 2019 with the same results/same problem.
OK this is code that works. It obviously has a backwards processing of messages in the inbox to avoid problems with inability to MOVE more than one matching message. However my original code code not MOVE ANY matching messages.
The code I used as a base for this solution is from a web site listed at the beginning of my code as a comment. I am thankful for that code.
Public Sub ReadInbox()
'' http://www.vbaexpress.com/forum/showthread.php?58433-VBA-Outlook-Move-mail-shared-Folder-to-shared-subfolder
Dim a As Boolean
'''******Open Outlook if not already open
On Error Resume Next
Set myOlApp = GetObject(, "outlook.Application")
If Err.Number <> 0 Then
Set myOlApp = CreateObject("Outlook.Application")
End If
On Error GoTo error_Handling
'''http://www.blueclaw-db.com/read_email_access_outlook.htm
'''On Error GoTo error_Handling
Dim TempRst As DAO.Recordset
Dim TempRst2 As DAO.Recordset
Dim TempRst3 As DAO.Recordset
Dim TempRst4 As DAO.Recordset
Dim rst As DAO.Recordset
Dim mynamespace As Outlook.namespace
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
Dim MessageBody As String
Dim selstr As String
Dim myDestFolder As Outlook.folder
Dim myInbox As Outlook.folder
Dim alreadyindb As Boolean
Dim n As Integer
'****
Set mynamespace = myOlApp.getnamespace("MAPI")
Dim NS As namespace
Dim Destinationfolder As folder
Dim myitems As Outlook.items
Dim myInbox2 As folder
Set NS = myOlApp.getnamespace("MAPI")
Set myInbox = NS.Folders("volunteerform#?????.org").Folders("Inbox")
Set myitems = myInbox.items
Set myInbox2 = NS.Folders("volunteerform#?????.org").Folders("inbox")
If myInbox2 Is Nothing Then
Exit Sub ' avoid error if no account is chosen
End If
Set myitems = myInbox2.items
'
''''For Each Mailobject In myitems
For n = myitems.Count To 1 Step -1
'''MsgBox ("process mailobject")
If myitems(n).Subject <> "ANV Volunteer Form Submission for Import" Then GoTo NextMessage
'************* all my processing here ********************
NextMessage:
' Next email message
Next n
'''Set OlApp = Nothing
Set myInbox2 = Nothing
Set InboxItems = Nothing
Set Mailobject = Nothing
Exit Sub
error_Handling:
Dim errornumber As String
Dim errordescr As String
errornumber = Err.Number
errordescr = Err.Description
a = WriteHistory("Process Form Retrieve_ProcessEmails", "Error = " & errornumber & " Mysection = " & MySection & " errordescription = " & errordescr & " MySection=" & MySection)
Exit Sub
End Sub
I want search though Outlook folders of now to previous weekday, so will exclude weekends, and if file doesn’t exist, output “this report was not sent on date”.
And for file to save as: following a condition that the title of the heading contains some text at most two. And that the file will be saved with the two found letters in the body of the title.
I want to do this for six different cases.
Sub SaveOutlookAttachments()
Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim ofolder As Outlook.folder
Dim i As Object
Dim mi As Outlook.MailItem
Dim at As Outlook.Attachment
Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set ofolder = ns.Folders(1).Folders("Inbox")
For Each i In ofolder.Items
If i.Class = olMail Then
Set mi = i 'This ensure that were looking at an email object rather than any potential item
'I need to find a way to create a case or an if statement that would reference 2 keywords in the title of the email subject in order to download and save the file with those keywords + date at the end.
'The logic is to use the title to distinguish between 4 regional reports for 1 Partner and 3 reports for 3 different partners. These would save files in their names associated with the title of the email. Eg: Comp.ABC Regional Reports 20/10/2019. I should also only search for previous days only within weekdays/working days - Mondays to Fridays.
Debug.Print mi.SenderName, mi.ReceivedTime, mi.Attachments.Count
For Each at In mi.Attachments
at.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" & at.FileName & Format(mi.ReceivedTime, "dd-mm-yyyy") 'Put in a valid folder location to store attachements
Next at
End If
Next i
End Sub
Here's code that first checks the MailItem's ReceivedTime for the Date condition (you can go further and exclude weekends). Then it checks the MailItem's Subject for Keywords from a colKeywords collection you can edit and add to. It also This should get you pretty close to what you want to do. I've also renamed the variables for clarity:
Dim objOutlook As New Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objFolder As Outlook.Folder
Dim objItem As Object
Dim objMailItem As Outlook.MailItem
Dim objAttachment As Outlook.Attachment
Dim colKeywords As New Collection
Dim sKeyword As String
Dim iCounter As Integer
Dim iBackdate As Integer
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.Folders(1).Folders("Inbox")
' Add your Keywords here
colKeywords.Add "keyword1"
colKeywords.Add "keyword2"
For Each objItem In objFolder.Items
' Check Item Class
If objItem.Class = Outlook.olMail Then
' Set as Mail Item
Set objMailItem = objItem
With objMailItem
Select Case Weekday(Now)
Case 7 ' Saturday: add extra day
iBackdate = 3
Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
iBackdate = 4
Case Else ' Other days
iBackdate = 2
End Select
' Check date
If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then
' Loop through all keywords
For iCounter = 1 To colKeywords.Count
' Get keyword
sKeyword = colKeywords.Item(iCounter)
' Check if keyword exists
If InStr(.Subject, sKeyword) > 0 Then
' Save Attachments
For Each objAttachment In .Attachments
objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" & objAttachment.FileName & Format(.ReceivedTime, "dd-mm-yyyy") 'Put in a valid folder location to store attachements
Next
End If
Next
End If
End With
End If
Next
I am trying to put together Outlook VBA to find all emails in the primary inbox from the previous weekday (Monday-Friday) and move them to a new folder, which I am also creating.
I tried to add in the logic to skip Saturday and Sunday. Since today is Monday, I should be moving all emails from Friday. It successfully creates the new folder with last Friday's date, but it doesn't move any emails. Last I checked, on Friday it did move the Thursday items. I'm struggling to determine why it wont move last Friday's emails today?
My question is, can anyone determine why Friday's emails are not being moved at all?
Below is the code I currently use:
Sub Move_Yesterdays_Emails()
'***Creates a new folder named yesterdays date under the inbox***
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myNewFolder As Outlook.Folder
Dim xDay As String
Dim XDate As Date
If Weekday(Now()) = vbMonday Then
XDate = Date - 3
Else
XDate = Date - 1
End If
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myNewFolder = myFolder.Folders.Add(XDate)
'***Releases memory***
Set myNameSpace = Nothing
Set myFolder = Nothing
Set myNewFolder = Nothing
'***Finds all emails in the inbox from yesterday and moves them to the created folder***
Dim myNameSpace As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim Item As Object
Dim Filter As String
Dim i As Long
Filter = "[ReceivedTime] >= '" & _
CStr(XDate) & _
" 12:00AM' AND [ReceivedTime] < '" & _
CStr(XDate) & " 12:00AM'"
Debug.Print Filter
Set myNameSpace = Application.GetNamespace("MAPI")
Set Inbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items.Restrict(Filter)
Items.Sort "[ReceivedTime]"
For i = Items.Count To 1 Step -1
DoEvents
If TypeOf Items(i) Is MailItem Then
Debug.Print Items(i)
Set Item = Items(i)
Item.Move Inbox.Folders(XDate)
End If
Next
End Sub
Thank you in advance. I'd like to get this solved today, so I don't have to wait until next Monday to try the situation live again.
There were several issues with your code, I fixed everything and it now runs fine
The main mistake: your filter was
[ReceivedTime] >= '15/06/2018 12:00AM' AND [ReceivedTime] < '15/06/2018 12:00AM'
So basically it searched for nothing as the 2 datetime in between were the same. You should make your filter like this
Filter = "[ReceivedTime] >= '" & _
CStr(XDate) & _
" 12:00AM' AND [ReceivedTime] < '" & _
CStr(XDate + 1) & " 12:00AM'"
You also had issue with the Item.Move. You should specify an Outlook.Folder type of object there
Whole sub becomes
Option Explicit
Sub Move_Yesterdays_Emails()
'***Creates a new folder named yesterdays date under the inbox***
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myNewFolder As Outlook.Folder
Dim xDay As String
Dim XDate As Date
If Weekday(Now()) = vbMonday Then
XDate = Date - 3
Else
XDate = Date - 1
End If
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myNewFolder = myFolder.Folders.Add(XDate)
'***Finds all emails in the inbox from yesterday and moves them to the created folder***
'Dim myNameSpace As Outlook.NameSpace ---> DUPLICATE DECLARATION
Dim Inbox As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim Item As Object
Dim Filter As String
Dim i As Long
Filter = "[ReceivedTime] >= '" & _
CStr(XDate) & _
" 12:00AM' AND [ReceivedTime] < '" & _
CStr(XDate + 1) & " 12:00AM'"
Debug.Print Filter
Set myNameSpace = Application.GetNamespace("MAPI")
Set Inbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items.Restrict(Filter)
Items.Sort "[ReceivedTime]"
For i = Items.Count To 1 Step -1
DoEvents
If TypeOf Items(i) Is MailItem Then
Debug.Print Items(i)
Set Item = Items(i)
Item.Move myNewFolder
End If
Next
End Sub
I have code that is supposed to loop through all future appointments; and if they match a certain criteria, delete them from the calendar.
Sub DeleteFutureImportedCalendarItems()
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim objAppointment As Outlook.AppointmentItem
Dim strSubject As String
Dim strLocation As String
Dim dteStartDate As Date
Dim Category As String
'******************************** Set Criteria for DELETION here ********************************
strSubject = "[Imported]"
strLocation = "AC"
dteStartDate = Date
Category = "Yellow Category"
'************************************************************************************************
Set objOutlook = Outlook.Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderCalendar)
For Each objAppointment In objFolder.Items
If Right(objAppointment.Subject, 10) = strSubject And objAppointment.Location = strLocation And _
objAppointment.Start >= dteStartDate And objAppointment.Categories = Category Then
objAppointment.Delete
End If
Next
End Sub
This does not delete all of the appointments that meet the criteria. If I run the code multiple times, it grabs a few more each time, but I have to run this 5 or 6 times to get all of them.
Deleting an item changes the collection. Loop from Count down to 1 instead:
set oItems = objFolder.Items
for i = oItems.Count to 1 step -1 do
set objAppointment = oItems.Item(I)
...