I hope there is someone who have an idea about this issue.
I want to archive a sender's emails(for example send form : test#tect.com) to more than one folder in outlook concurrently by using automatic rule function.
Is this possible?
Yes it is possible with help of script rule and vba code.
the following code creates a copy of the identified message as it arrives and then moves the copy message to multiple to folders.
Option Explicit
Public Sub MoveItems(olItem As Outlook.MailItem)
Dim olApp As New Outlook.Application
Dim olNameSpace As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Dim olDestFolder As Outlook.MAPIFolder
Dim olItems As Outlook.Items
Dim CopyItem As Object
Set olNameSpace = olApp.GetNamespace("MAPI")
Set olInbox = olNameSpace.GetDefaultFolder(olFolderInbox)
Set olItems = olInbox.Items
'// loop
While TypeName(olItem) <> "Nothing"
Set olDestFolder = olInbox.Folders("TEMP1") 'Folder
Set CopyItem = olItem.copy
olItem.Move olDestFolder
Set olDestFolder = olInbox.Folders("TEMP2") 'Folder
olItem.Move olDestFolder
Set olDestFolder = olInbox.Folders("TEMP3") 'Folder
olItem.Move olDestFolder
'// Add more folders here
Set olItem = olItems.FindNext
Wend
Set olNameSpace = Nothing
Set olInbox = Nothing
Set olDestFolder = Nothing
Set olItems = Nothing
Set olItem = Nothing
Set CopyItem = Nothing
End Sub
Related
I changed from Windows to MacOS.
I used VBA code to create a folder under the inbox based on email title and move the email to the folder.
I'm trying to do the same with AppleScript.
I would appreciate if someone can help me write the same logic in AppleScript (or suggest an alternative to somehow keep using the VBA code).
Public Function ReturnNonAlpha(ByVal sString As String) As String
Dim i As Integer
For i = 1 To Len(sString)
If Mid(sString, i, 1) Like "[0-9]" Then
ReturnNonAlpha = ReturnNonAlpha + Mid(sString, i, 1)
End If
Next i
End Function
Function CheckForFolder(strFolder As String) As Boolean
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Dim FolderToCheck As Outlook.MAPIFolder
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
On Error Resume Next
Set FolderToCheck = olInbox.Folders(strFolder)
On Error GoTo 0
If Not FolderToCheck Is Nothing Then
CheckForFolder = True
End If
ExitProc:
Set FolderToCheck = Nothing
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function
Function CreateSubFolder(strFolder As String) As Outlook.MAPIFolder
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
Set CreateSubFolder = olInbox.Folders.Add(strFolder)
ExitProc:
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function
Function SearchAndMove(lookFor As String)
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Dim FolderToCheck As Outlook.MAPIFolder
Dim myItem As Object
Dim MyFolder As Outlook.MAPIFolder
Dim lookIn As String
Dim newName As String
Dim location As Integer
Dim endLocation As Integer
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
For Each myItem In olInbox.Items
lookIn = myItem.Subject
If InStr(lookIn, lookFor) Then
endLocation = InStr(lookIn, "SUP-")
newName = ReturnNonAlpha(lookIn)
newName = Mid(newName, 1, 5)
If CheckForFolder(newName) = False Then
Set MyFolder = CreateSubFolder(newName)
myItem.Move MyFolder
Else
Set MyFolder = olInbox.Folders(newName)
myItem.Move MyFolder
End If
End If
Next myItem
End Function
Sub myMacro(Item As Outlook.MailItem)
Dim str As String
str = "[JIRA]"
SearchAndMove (str)
End Sub
I was really determined to find a solution, so eventually with some help from https://hackernoon.com/automated-inbox-cleansing-with-outlook-2016-and-applescript-49cf4c4422fa
I was able to write a script which does what I need.
I thought I'll share it for future references since I don't see a lot of info about applescript around here.
This script basically creates a subfolder under inbox based on email subject and move the email there. I wrote it with my own problem to solve in mind, but you can do adjustments to your own problems.
tell application "Microsoft Outlook"
set myInbox to folder "Inbox" of default account
set theMessages to messages 1 through 20 of inbox
repeat with theMessage in theMessages
try
set theSubject to subject of theMessage
if theSubject contains "[JIRA]" then
set s to quoted form of theSubject
do shell script "sed s/[a-zA-Z\\']//g <<< " & s
set newFolderName to the result
set numlist to {}
repeat with i from 1 to count of words in newFolderName
set this_item to word i of newFolderName
try
set this_item to this_item as number
set the end of numlist to this_item
end try
end repeat
set newFolderName to first item of numlist as text
if mail folder newFolderName exists then
move theMessage to mail folder newFolderName of myInbox
else
make new mail folder at myInbox with properties {name:newFolderName}
move theMessage to mail folder newFolderName of myInbox
end if
end if
on error errorMsg
log "Error: " & errorMsg
end try
end repeat
end tell
I want a macro/rule/code that creates a folder in Outlook based on the sender's domain, after that I want it to create a folder based on the sender's name in the sender's domain folder, and then move the mail to that folder.
I am thinking of a folder layout like this:
Inbox\#senders domain\#Senders name\Email.msg
Please refer to this code, however, you may need to change something as your special request.
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
' set object reference to default Inbox
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
' fires when new item added to default Inbox
' (per Application_Startup)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim targetFolder As Outlook.MAPIFolder
Dim senderName As String
' don't do anything for non-Mailitems
If TypeName(item) <> "MailItem" Then GoTo ProgramExit
Set Msg = item
' move received email to target folder based on sender name
senderName = Msg.senderName
If CheckForFolder(senderName) = False Then ' Folder doesn't exist
Set targetFolder = CreateSubFolder(senderName)
Else
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set targetFolder = _
objNS.GetDefaultFolder(olFolderInbox).Folders(senderName)
End If
Msg.Move targetFolder
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Function CheckForFolder(strFolder As String) As Boolean
' looks for subfolder of specified folder, returns TRUE if folder exists.
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olInbox As Outlook.MAPIFolder
Dim FolderToCheck As Outlook.MAPIFolder
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
' try to set an object reference to specified folder
On Error Resume Next
Set FolderToCheck = olInbox.Folders(strFolder)
On Error Goto 0
If Not FolderTocheck Is Nothing Then
CheckForFolder = True
End If
ExitProc:
Set FolderToCheck = Nothing
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function
Function CreateSubFolder(strFolder As String) As Outlook.MAPIFolder
' assumes folder doesn't exist, so only call if calling sub knows that
' the folder doesn't exist; returns a folder object to calling sub
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olInbox As Outlook.MAPIFolder
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
Set CreateSubFolder = olInbox.Folders.Add(strFolder)
ExitProc:
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function
More information, please see,
Create new folder for new sender name and move message into new folder
I've tried countless ways of deleting items from a custom folder called "Spam Digests" older than 14 days. I have successfully done this when I nest this folder underneath the olDefaultFolder(Inbox) but when I have it outside of the default inbox, I cannot reference it as I receive object not found.
Here is what I have and I cannot seem to figure out why the object is not found when referencing "fldSpamDigest"
Dim outapp As Outlook.Application
Set outapp = CreateObject("outlook.application")
Dim olitem As Object
Dim fldSpamDigest As Outlook.MAPIFolder
Set fldSpamDigest = outapp.GetNamespace("MAPI").Folders("Spam Digests")
For Each olitem In fldSpamDigest.Items
If DateDiff("d", olitem.CreationTime, Now) > 14 Then olitem.Delete
Next
Set fldSpamDigest = Nothing
Set olitem = Nothing
Set outapp = Nothing
GetDefaultFolder(olFolderInbox) is a shortcut.
You can reference any folder the long way.
Sub reference_walk_the_path()
Dim outapp As Outlook.Application
Set outapp = CreateObject("outlook.application")
Dim olitem As Object
Dim fldSpamDigest As Outlook.MAPIFolder
' from the default inbox to the parent which is your mailbox
Set fldSpamDigest = outapp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent
' from the mailbox to a folder at the same level as the Inbox
Set fldSpamDigest = fldSpamDigest.folders("Spam Digests")
' or
' directly from the mailbox to a folder at the same level as the Inbox
'Set fldSpamDigest = outapp.GetNamespace("MAPI").folders("your email address").folders("Spam Digests")
For Each olitem In fldSpamDigest.Items
If dateDiff("d", olitem.CreationTime, Now) > 14 Then olitem.Delete
Next
Set fldSpamDigest = Nothing
Set olitem = Nothing
Set outapp = Nothing
End Sub
Dim outapp As Outlook.Application
Set outapp = CreateObject("outlook.application")
There is no need to create a new Outlook Application instance in the Outlook VBA, simply use the Application property
To reference a folder that is not under default Inbox - example would be
Option Explicit
Public Sub Example()
Dim olNs As Outlook.NameSpace
Set olNs = Application.Session
Dim Digest_Fldr As Outlook.MAPIFolder
Set Digest_Fldr = olNs.GetDefaultFolder(olFolderInbox) _
.Parent.Folders("fldSpamDigest")
Dim Items As Outlook.Items
Set Items = Digest_Fldr.Items
Dim i As Long
For i = Items.Count To 1 Step -1
DoEvents
Debug.Print Items(i).Subject
Next
End Sub
I have an email account "Fred.Smith#domain.co.uk" (domain being made up).
Outlook shows an archive named " Archive - Fred.Smith#domain.co.uk" where Outlook automatically moves emails after a certain period.
Current code:
Set olRecip = olNS.CreateRecipient("Archive - Fred.Smith#domain.co.uk")
olRecip.Resolve
Set olFolder = olNS.GetSharedDefaultFolder(olRecip, olFolderInbox)
This opens the main inbox. How do I select the archive folder?
"Archive" folder is usually at the root level - like inbox
in that case:
Sub ArchiveItems()
' Moves each of the selected items on the screen to an Archive folder.
Dim olApp As New Outlook.Application
Dim olExp As Outlook.Explorer
Dim olSel As Outlook.Selection
Dim olNameSpace As Outlook.NameSpace
Dim olArchive As Outlook.Folder
Dim intItem As Integer
Set olExp = olApp.ActiveExplorer
Set olSel = olExp.Selection
Set olNameSpace = olApp.GetNamespace("MAPI")
Set olArchive = olNameSpace.Folders("myMail#mail.com").Folders("Archive")
For intItem = 1 To olSel.Count
olSel.Item(intItem).Move olArchive
Next intItem
End Sub
to get Inbox you could use default access:
Dim olInbox As Outlook.Folder
Set olInbox = olNameSpace.GetDefaultFolder(olFolderInbox)
Note - This will get you the default Inbox folder, if you have a few accounts in outlook you should verify it's really the folder you want - or use the mail specific approach like in Archive folder above
For Debugging - if you want to check all available subfolders
For i = 1 To olInbox.Folders.Count
Debug.Print olInbox.Folders(i).Name
Next i
Should be
Dim ARCHIVE_FOLDER As Outlook.MAPIFolder
Set ARCHIVE_FOLDER = olNs.Folders("Archive - Fred.Smith#domain.co.uk")
Full Example
Option Explicit
Public Sub Example()
Dim olNs As Outlook.NameSpace
Dim ARCHIVE_FOLDER As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim i As Long
Set olNs = Application.Session
Dim ARCHIVE_FOLDER As Outlook.MAPIFolder
Set ARCHIVE_FOLDER = olNs.Folders("Archive - Fred.Smith#domain.co.uk") _
.Folders("Inbox")
Debug.Print ARCHIVE_FOLDER.Name
Debug.Print ARCHIVE_FOLDER.FolderPath
Debug.Print ARCHIVE_FOLDER.Store.DisplayName
ARCHIVE_FOLDER.Display
Set Items = ARCHIVE_FOLDER.Items
For i = Items.Count To 1 Step -1
DoEvents
Debug.Print Items(i).Subject
Next
End Sub
MAPIFolder Object
I made code to copy a contact list to a public folder but if I am not on the contact source it does not work.
Sub Movecopycontacts()
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objSourceFolder As Outlook.MAPIFolder
Dim objDestFolder As Outlook.MAPIFolder
Dim objItem As ContactItem
Set objOutlook = Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderContacts)
Set objItem = Application.ActiveExplorer.Selection.Item(1)
Set objDestFolder = objNamespace.Folders("Public folder - oky#test.com").Folders("all public folder").Folders("test")
objItem.Move objDestFolder
Set objDestFolder = Nothing
End Sub
The error comes from:
Set objItem = Application.ActiveExplorer.Selection.Item(1)
That is correct - your code assumes that the item to be moved is selected. It does what it is supposed to do.
\What else do you want it to do?