I am trying to create new task by clicking on Userform button with the following code:
Private Sub CreateTaskCMD_Click()
Dim oTask As TaskItem
Dim SelFolder As Outlook.Folder
Set oTask = Outlook.CreateItem(olTaskItem)
Set SelFolder = ObjNS.Folders(1).Folders(TaskFoldersList.List(TaskFoldersList.ListIndex, 1))
With oTask
'include time and from in subject of task
'.Subject = ""
'.Body = ""
.StartDate = Date
.Save
.Move SelFolder
.Save
.Display
End With
Set SelFolder = Nothing
Set oTask = Nothing
End Sub
The code gets the folder number from a list which already updated.
new task is created and moved to the selected folder, but problem is when I see the task window I cannot rename, or make changes in that rather I have to close it and then reopen it.
I am receiving message "The item cannot be saved because it was modified by another user or in another window"
I have already release the oTask at the end of subroutine? don't know where I am holding that new task. or where I need to release it from?
Instead of creating in the default folder then moving, you can add to the non-default task folder.
Option Explicit
Private Sub CreateTaskCMD_Click()
Dim oTask As TaskItem
Dim SelFolder As folder
Set SelFolder =
Session.Folders(1).Folders(TaskFoldersList.list(TaskFoldersList.ListIndex, 1))
Set oTask = SelFolder.items.Add(olTaskItem)
With oTask
.StartDate = Date
.Display
End With
Set SelFolder = Nothing
Set oTask = Nothing
End Sub
As #niton points out, you really need to use MAPIFolder.Items.Add instead of moving. But if you move, keep in mind that Move is a function that returns the new item, not a sub:
set oTask = oTask.Move(SelFolder)
Related
I use Outlook 365 on windows 10.
There are three calendars in the "My Calendars" group.
I would like to show all calendars at startup with the default calendar, Calendar 1, active using VBA.
To do this, I use the following VBA code, but there are two problems.
One problem is that a part of the code is redundant, which makes it time-consuming.
By default, only Calendar1 in My Calendars group is visible after startup.
To show all calendars, the code makes Calendar2 and Calendar3 visible.
After running these commands, Calendar3 is active.
To activate Calendar1 after startup, the code makes Calendar1 invisible and then visible.
I think, instead of this, it's an efficient way to use the command corresponding to check the checkbox of "My Calendars" in the navigation pane.
But I don't know how to do this.
The other problem is that, after startup using this macro, I can't switch day view and month view by shortcut keys, Cntl+Alt+1 and Cntl+Alt+2.
I think the way to check the check of "My Calendars" solves this problem
because I can switch these views by the shortcut keys when I manually check the checkbox.
So could you tell me the way to solve these problems?
Thank you in advance.
Private WithEvents g_Items As Outlook.Items
Private Sub Application_Startup()
Dim Ns As Outlook.NameSpace
Set Ns = Application.GetNamespace("MAPI")
Set g_Items = Ns.GetDefaultFolder(olFolderCalendar).Items
setupInitialDisplayCalendars
End Sub
Public Sub setupInitialDisplayCalendars()
Dim navModCal As CalendarModule
Dim navGroup As NavigationGroup
Set navModCal = ActiveExplorer.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
Set navGroup = navModCal.NavigationGroups.Item("My Calendars")
If Not (navGroup Is Nothing) Then
navGroup.NavigationFolders.Item("Calendar2").IsSelected = True
navGroup.NavigationFolders.Item("Calendar3").IsSelected = True
navGroup.NavigationFolders.Item("Calendar1").IsSelected = False
navGroup.NavigationFolders.Item("Calendar1").IsSelected = True
End If
End Sub
You can use the NavigationFolders object can be used to display calendars listed on the navigation page in Outlook.
Sub SelectCalendars()
Dim objPane As Outlook.NavigationPane
Dim objModule As Outlook.CalendarModule
Dim objGroup As Outlook.NavigationGroup
Dim objNavFolder As Outlook.NavigationFolder
Dim objCalendar As Folder
Dim objFolder As Folder
Dim i As Integer
Set Application.ActiveExplorer.CurrentFolder = Session.GetDefaultFolder(olFolderCalendar)
DoEvents
Set objCalendar = Session.GetDefaultFolder(olFolderCalendar)
Set objPane = Application.ActiveExplorer.NavigationPane
Set objModule = objPane.Modules.GetNavigationModule(olModuleCalendar)
With objModule.NavigationGroups
Set objGroup = .GetDefaultNavigationGroup(olMyFoldersGroup)
End With
For i = 1 To objGroup.NavigationFolders.Count
Set objNavFolder = objGroup.NavigationFolders.Item(i)
Select Case i
' Enter the calendar index numbers you want to open
Case 1, 3, 4
objNavFolder.IsSelected = True
' Set to True to open side by side
objNavFolder.IsSideBySide = False
Case Else
objNavFolder.IsSelected = False
End Select
Next
' set the view here
Set objPane = Nothing
Set objModule = Nothing
Set objGroup = Nothing
Set objNavFolder = Nothing
Set objCalendar = Nothing
Set objFolder = Nothing
End Sub
To change calendar folder view (day/week/month) you can use the view object:
Dim objViews As Views
Dim objView As View
Set objViews = Application.ActiveExplorer.CurrentFolder.Views
Set objView = objViews.Item("Calendar")
With objView
' Set the calendar view to show a
' single day.
.CalendarViewMode = olCalendarViewDay
End With
objView.Apply
The CalendarView.CalendarViewMode property returns or sets an OlCalendarViewMode that determines the current view mode of the CalendarView object.
I'm working within MS Access 2013 and MS Outlook 2013 on Windows 10 and I have a Access DB with a "Navigation Subforms" paradigm that allows sending a single e-mail on two separate occasions.
I'm trying to write code to do the following:
when a new e-mail is sent,
I want to save it as a .msg file on disk automatically.
From what I can tell, it seems the way to do this is via trapping the .ItemAdd event that fires on Outlook Sent Folder within Access, and in there executing the .SaveAs method.
I was trying to implement a solution based on these two answers:
How to Trap Outlook Events from Excel Application
Utilizing Outlook Events From Excel
but I just can't seem to combine the two and make the event fire.
My feeling is that either I'm not referencing/setting things correctly or the execution reaches an end before the e-mail is moved from the Outbox Folder to the Sent Folder, but I'm not sure.
How can I do this?
Thanks for reading, code follows:
My current class module - "cSentFolderItem"
Option Explicit
Public WithEvents myOlItems As Outlook.items
Private Sub Class_Initialize()
Dim oNS As NameSpace
Dim myOL As Outlook.Application
Set myOL = New Outlook.Application
Set oNS = myOL.GetNamespace("MAPI")
Set myOlItems = oNS.GetDefaultFolder(olFolderSentMail).items
End Sub
Private Sub myOlItems_ItemAdd(ByVal Item As Object)
Debug.Print "I got a new item on Sent box!"
Dim myOlMItem As Outlook.MailItem
Set myItem = myOlItems.items(email_subject)
myItem.Display
myItem.SaveAs "C:\Users\XXXXXX\Desktop\mail_test.msg", olMSGUnicode
End Sub
"Regular" code:
Public Function GetApplication(Class As String) As Object
'Handles creating/getting the instance of an application class
Dim ret As Object
On Error Resume Next
Set ret = GetObject(, Class)
If Err.Number <> 0 Then
Set ret = CreateObject(Class)
End If
Set GetApplication = ret
On Error GoTo 0
End Function
Sub Test()
email_subject = "Mail test match string - [aaaa-mm-dd]"
Set myOlItems = New cSentFolderItem 'declare class module object
Dim MyOutlook As Outlook.Application
Set MyOutlook = GetApplication("Outlook.Application") 'trying to get correct application object
'The following code is a dummy e-mail creation, after which I press SEND:
Dim MyMail As Outlook.MailItem
varTo = "target_email#address.com"
varSubject = email_subject
varbody = "test line 1" & vbCrLf & "test line 2" & vbCrLf & "test line 2"
varSubject = Replace(varSubject, "[aaaa-mm-dd]", NOW())
Dim linhas() As String
linhas = Split(varbody, vbCrLf)
bodyHTMLtext = "<body>"
For i = 0 To UBound(linhas) - 1
bodyHTMLtext = bodyHTMLtext & linhas(i) & "<br>"
Next
bodyHTMLtext = bodyHTMLtext & linhas(UBound(linhas))
bodyHTMLtext = bodyHTMLtext & "</body>"
Set MyMail = MyOutlook.CreateItem(OLMAILITEM)
MyMail.To = varTo
MyMail.Subject = varSubject
MyMail.Display
MyMail.HTMLBody = bodyHTMLtext & MyMail.HTMLBody
AppActivate varSubject
'trying to leave Outlook object open:
''Cleanup after ourselves
'Set MyMail = Nothing
''MyOutlook.Quit
'Set MyOutlook = Nothing
End Sub
Ok, after some long hours, I figured it out, and got to the following solution.
My class module "MyOutlook" is:
Option Explicit
Public myOutlookApp As Outlook.Application
Public mySentFolder As Outlook.Folder
Public WithEvents myItems As Outlook.items
Private Sub Class_Initialize()
Set myOutlookApp = GetApplication("Outlook.Application")
Dim oNS As NameSpace
Set oNS = myOutlookApp.GetNamespace("MAPI")
Set mySentFolder = oNS.GetDefaultFolder(olFolderSentMail)
Set myItems = mySentFolder.items
End Sub
Private Sub myItems_ItemAdd(ByVal Item As Object)
Debug.Print "Got_EMAIL!!! Looking for subject = " & email_subject
'"e-mail_subject" is Public a string, assigned in another part of the program
If Item.Subject = email_subject Then
Item.SaveAs "C:\Users\640344\Desktop\mail_test.msg", olMSGUnicode
End If
End Sub
Where GetApplication is:
Function GetApplication(Class As String) As Object
'Handles creating/getting the instance of an application class
'If there exists one already (in my case, Outlook already open),
'it gets its name, else it creates one
Dim ret As Object
On Error Resume Next
Set ret = GetObject(, Class)
If Err.Number <> 0 Then
Set ret = CreateObject(Class)
If Class = "Outlook.Application" Then
'Outlook wasn't opened, so open it
ret.Session.GetDefaultFolder(olFolderInbox).Display
ret.ActiveExplorer.WindowState = olMaximized
ret.ActiveExplorer.WindowState = olMinimized
End If
End If
Set GetApplication = ret
On Error GoTo 0
End Function
Note that I added the 3 lines of code after 'Outlook wasn't opened, so open it because otherwise I would get an error. It's not a bad idea for my users that the program opens Outlook, anyway.
On the "regular" code part of my project, outside any procedure, I declare:
Public myOutlook As myOutlook
Then, on my project's "main" sub:
Set myOutlook = New myOutlook
'[...]
'Code where entire program runs
'[...]
Set myOutlook = Nothing
This way, myOutlook object (and its variables) "lives" the entire time the program (with its Navigation Forms) is running, and is waiting to trap _ItemAdd events on the default Sent Folder of Outlook.
Note that I look only for e-mails with subject equal to the email_subject string, because I don't want to save all sent e-mails, just the one sent by using the program, and I have code to assign my desired subject to that string.
I use the Application_ItemSend event to trigger actions on mails I send.
Under certain conditions the mail shall be moved to a new subfolder.
Since one can't move the mail before it is sent without jeopardizing the send, I copy the mail before sending and delete the original after.
Set myCopiedItem = objItem.Copy
myCopiedItem.Move olTempFolder
myCopiedItem.UnRead = False
myCopiedItem.SentOnBehalfOfName = olSession.CurrentUser
myCopiedItem.SendUsingAccount = olSession.Accounts(1)
'myCopiedItem.SenderName = olSession.CurrentUser
'myCopiedItem.SenderEmailAddress = olSession.CurrentUser.Address
objItem.DeleteAfterSubmit = True
I would like to have me as a sender on the copied mail.
I tried to set several different properties:
.SendOnBehalfOfName and .SendUsingAccount do not do what I am after.
.SenderName and .SenderEmailAddress showed to be "read only"
How can I avoid that the mail shows up in the folder without a sender?
Would this work for you:
Save the email in the Application_ItemSend event first:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Item.Save
MoveEmail Item, "\\Mailbox - Darren Bartrup-Cook\Inbox\Some Folder\Some Sub Folder"
End Sub
In a separate module (excuse MoveEmail being a function - originally it returned the EmailID of the moved email):
'----------------------------------------------------------------------------------
' Procedure : MoveEmail
' Author : Darren Bartrup-Cook
' Date : 03/07/2015
'-----------------------------------------------------------------------------------
Public Function MoveEmail(oItem As Object, sTo As String) As String
Dim oNameSpace As Outlook.NameSpace
Dim oDestinationFolder As Outlook.MAPIFolder
Set oNameSpace = Application.GetNamespace("MAPI")
Set oDestinationFolder = GetFolderPath(sTo)
oItem.Move oDestinationFolder
End Function
'----------------------------------------------------------------------------------
' Procedure : GetFolderPath
' Author : Diane Poremsky
' Original : http://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/
'-----------------------------------------------------------------------------------
Function GetFolderPath(ByVal FolderPath As String) As Outlook.MAPIFolder
Dim oFolder As Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer
On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
'Return the oFolder
Set GetFolderPath = oFolder
Exit Function
GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function
Firstly, Move is a function, not a sub - it returns the newly created item. The original must be immediately discarded.
set myCopiedItem = myCopiedItem.Move(olTempFolder)
Secondly, sender related properties are set only after the message is sent and moved to the Sent Items folder. One solution is to wait until the Items.ItemAdd event fires on the Sent Items folder and make a copy then - the sender properties will be set by that time.
In theory, you can set a dozen or so PR_SENDER_* and PR_SENT_REPRESENTING_* MAPI properties, but if I remember my experiments correctly, MailItem.PropertyAccessor.SetProperty will not let you set sender related properties. If using Redemption is an option (I am its author), it allows to set the RDOMail.Sender and RDOMail.SentOnBehalfOf properties to an instance of an RDOAddressEntry object (such as that returned by RDOSession.CurrentUser).
I'm trying to create a recursive function which adds each folder (and subfolders) to a collection of custom objects. My code is working for around 75% of the folders / subfolders but seemingly random ones are being missed from the collection.
Any ideas?
FolderObj is a custom class, the collection I'm adding to is called ToPathList
Option Explicit
Sub RecurseFolderList(Foldername As String)
On Error Resume Next
Dim FSO, NextFolder
Dim OriginalRange As Range
Dim tempFolderObj As FolderObj
Dim i As Integer
i = 1
Set FSO = CreateObject("Scripting.FileSystemObject")
If Err.Number > 0 Then
Exit Sub
End If
If FSO.FolderExists(Foldername) Then
Set NextFolder = FSO.GetFolder(Foldername)
Set FolderArray = NextFolder.subfolders
For Each NextFolder In FolderArray
Set tempFolderObj = New FolderObj
'assign variables to temporary object
With tempFolderObj
.ID = i
.Filename = NextFolder.Name
.path = NextFolder.path
.first3ints = first3Non0Ints(NextFolder.Name)
End With
'add temporary object to colelction
Call ToPathList.Add(tempFolderObj, CStr(i))
i = i + 1
RecurseFolderList (NextFolder)
Next
' Set NextFolder = Nothing
' Set FolderArray = Nothing
End If
Set FSO = Nothing
End Sub
My key (i) was declared inside the function and therefore was being reset to '1' every time the function was recursed.
This resulted in non-unique keys and therefore some items were not being added to the collection.
Thanks to everyone for their help.
I was trying to implement a script to move a specific mail to a new folder - no tough stuff.
It is scripted in Outlook 2013 and implemented as a rule on incoming mails. The code:
Public Sub MoveToFolder(Item As Outlook.MailItem)
'' ... variable definitions ...
Set oloUtlook = CreateObject("Outlook.Application")
Set ns = oloUtlook.GetNamespace("MAPI")
Set itm = ns.GetDefaultFolder(olFolderInbox)
Set foldd = ns.Folders.GetFirst.Folders
For x = 1 To foldd.Count
If foldd.Item(x).Name = "Inbox" Then
Set fold = foldd.Item(x).Folders
For i = 1 To fold.Count
If fold.Item(i).Name = "Reports" Then
If fold.Item(i).Folders.GetFirst.Name <> Format(Date, "yyyy-mm") Then
fold.Item(i).Folders.Add (Format(Date, "yyyy-mm"))
End If
Set newfold = fold.Item(i).Folders.GetFirst
MsgBox newfold.Name
Item.Copy (newFold)
''Item.Move (newfold)
End If
Next i
End If
Next x
End Sub
The message comes to folder Inbox, I'd like to move it to:
Reports -> 2013-XX depending on the current month.
MessageBox shows the correct folder name. but the message is copied to folder "Inbox" as a duplicate.
What am I doing wrong? Cheers.
I'm not sure why your method isn't working. When I run it in 2010, it gets the right folder. I'm not sure why you think the current date folder will always be the first folder, but I've never used GetFirst, so maybe I just don't understand it. Here's a more straightforward way to test and create a folder and it may work for you.
Public Sub MoveToFldr(Item As MailItem)
Dim oFldr As Folder
Dim fReports As Folder
Set fReports = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Reports")
On Error Resume Next
Set oFldr = fReports.Folders(Format(Date, "yyyy-mm"))
On Error GoTo 0
If oFldr Is Nothing Then
Set oFldr = fReports.Folders.Add(Format(Date, "yyyy-mm"))
End If
Item.Move oFldr
End Sub