i Would like to know if i can count folders and subfolders in sharedmailbox ;
Here is some code that im using , but it works only for my default mail account.
is there a way to modify it to get the number of subfolders in the folder "Test" from my shared mailbox name's (AJ47 BOX)
Private Sub CommandButton1_Click()
Dim outapp As Outlook.Application
Set outapp = CreateObject("Outlook.Application")
Dim olNs As Outlook.NameSpace
Set olNs = outapp.GetNamespace("MAPI")
Dim olFolder As Outlook.MAPIFolder
TextBox1 = GetSubFolderCount(olNs.GetDefaultFolder(olFolderInbox).Folders("Tmp"))
End Sub
Private Function GetSubFolderCount(objParentFolder As MAPIFolder) As Long
Dim currentFolders As Folders
Dim fldCurrent As MAPIFolder
Set currentFolders = objParentFolder.Folders
If currentFolders.Count > 0 Then
Set fldCurrent = currentFolders.GetFirst
While Not fldCurrent Is Nothing
TempFolderCount = TempFolderCount + GetSubFolderCount(fldCurrent)
Set fldCurrent = currentFolders.GetNext
Wend
GetSubFolderCount = TempFolderCount + currentFolders.Count
Else
GetSubFolderCount = 0
End If
End Function
Use GetSharedDefaultFolder Method
Example
Dim olRecip As Recipient
Set olRecip = olNs.CreateRecipient("om3r#email.com") '// Owner's Name or email address
TextBox1 = GetSubFolderCount(olNs.GetSharedDefaultFolder(olRecip, olFolderInbox).Folders("Test"))
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 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
How do I select all Mails in the Deleted Items folder of a shared account (not my personal account) and then move them to a different folder not called "Deleted Items". For now, let's call the destination folder "Old Emails".
Here is what I have written so far:
'Macro for pseudo-archiving
Sub PseudoArchive()
On Error Resume Next
Dim objNamespace As Outlook.NameSpace
Dim sourceFolder As Outlook.MAPIFolder
Dim Messages As Selection
Dim Msg As MailItem
Set objNamespace = GetNamespace("MAPI")
Set sourceFolder = objNamespace.Folders("sharedemail#website.com")
Set sourceFolder = objFolder.Folders("Deleted Items")
'Define path to the target folder
Set destinationFolder = ns.Folders("sharedemail#website.com").Folders("Old Emails")
'Move emails in sourceFolder to destinationFolder
For Each Msg In sourceFolder
Msg.Move destinationFolder
Next
Set objNamespace = Nothing
Set sourceFolder = Nothing
Set Messages = Nothing
Set Msg = Nothing
End Sub
I am stuck on how to get the macro to select all items in the sourceFolder so it can then move them to the destinationFolder. I prefer not to manually select the emails in the folder before running the macro.
If anyone can provide assistance, that would be appreciated. Thanks!
You almost got it, try the following
Option Explicit
Sub PseudoArchive()
Dim objNamespace As Outlook.NameSpace
Dim sourceFolder As Outlook.MAPIFolder
Dim destinationFolder As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim Item As Object
Dim Msg As String
Dim i As Long
Set objNamespace = GetNamespace("MAPI")
Set sourceFolder = objNamespace.Folders("sharedemail#website.com").Folders("Deleted Items")
Set destinationFolder = objNamespace.Folders("sharedemail#website.com").Folders("Inbox").Folders("Old Emails")
Set Items = sourceFolder.Items
'Move emails in sourceFolder to destinationFolder
Msg = Items.Count & " Items in " & sourceFolder.Name & ", Move?"
If MsgBox(Msg, vbYesNo) = vbYes Then
For i = Items.Count To 1 Step -1
Set Item = Items.Item(i)
DoEvents
Item.Move destinationFolder
Next
End If
End Sub
Here is a code snippet that should help.
Dim olApp As Outlook.Application
Dim olFol As Outlook.Folder, olDestFol As Outlook.Folder
Dim olItem As Object
Dim i as Long, j as Long
Set olApp = New Outlook.Application olApp.GetNamespace("MAPI").Folders("mailboxnamehere").Folders("Deleted Items")
Set olDestFol = olApp.GetNamespace("MAPI").Folders("mailboxnamehere").Folders("Inbox").Folders("Deleted Items") ' Destination Folder
Do Until olFol.Items.Count = 0
olFol.Items(1).Move olDestFolder
Loop
I need a macro that will move messages received into a shared mailbox to a subfolder of that mailbox, depending on the sender's email address, basically a normal outlook rule.
I've been looking at some articles on http://www.slipstick.com/ which has got me part way there but there isn't an exact solution for what I want to do and I'm not proficient enough with VBA in Outlook yet to work it out.
So far I've got this code on ThisOutlookSession to watch the mailbox:
Dim i As Long
Private WithEvents olInboxItems As Items
Private Sub Application_Startup()
Dim objNS As NameSpace
Set objNS = Application.Session
Set olInboxItems = GetFolderPath(">Digital Analytics\Inbox").Items
Set objNS = Nothing
End Sub
And this function in a module to obtain the path of the watched mailbox folder:
' Use the GetFolderPath function to find a folder in non-default mailboxes
Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
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
This works, I used a case to move the item if it came from a specific email address:
Dim i As Long
Private WithEvents olInboxItems As Items
Private Sub Application_Startup()
Dim objNS As NameSpace
Set objNS = Application.Session
Set olInboxItems = GetFolderPath(">Digital Analytics\Inbox").Items
Set objNS = Nothing
For Each Item In olInboxItems
End Sub
Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
Dim objDestFolder As Outlook.MAPIFolder
Dim destFolder As String
Dim sendersAddress As String
If Item.Class = olMail Then
sendersAddress = Item.SenderEmailAddress
Select Case sendersAddress
Case "no-reply#omniture.com"
destFolder = ">Digital Analytics\Inbox\Reports"
Case "no-reply#edigitalresearch.com"
destFolder = ">Digital Analytics\Inbox\Reports"
End Select
Set objDestFolder = GetFolderPath(destFolder)
Item.Move objDestFolder
End If
End Sub
I have the following code to get contacts out of Outlook from Excel:
Public Sub GetGAL()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFldr As Outlook.Items
Dim olContact As Outlook.ContactItem
Set olApp = CreateObject("Outlook.Application.14")
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFolderContacts).Items
For Each olContact In olFldr
Debug.Print olContact.FullName
Next olContact
End
End Sub
It is failing on this line saying there is a type mismatch:
For Each olContact In olFldr
Does anyone know why this is?
Also, how do I access the GAL as opposed to just my own contacts?
Thanks for any help.
Edit: Here's my new code to access the addressEntry and ExchangeUser, however, not the country field yet:
Option Explicit
Public Sub GetGAL()
Application.ScreenUpdating = False
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olGAL As Outlook.addressEntries
Dim olAddressEntry As Outlook.addressEntry
Dim olUser As Outlook.ExchangeUser
Dim i As Long
'Dim sTemp As String
'Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(1)
Set olApp = CreateObject("Outlook.Application.14")
Set olNs = olApp.GetNamespace("MAPI")
Set olGAL = olNs.addressLists("Global Address List").addressEntries
'On Error Resume Next
For i = 1 To olGAL.Count
Set olAddressEntry = olGAL.Item(i)
If olAddressEntry.DisplayType = olRemoteUser Then
Set olUser = olAddressEntry.GetExchangeUser
'Debug.Print olUser.Name & ";" & olUser.StateOrProvince
'Debug.Print sTemp
'ws.Cells(i, 1) = olUser.Name
'ws.Cells(i, 2) = olUser.StateOrProvince
End If
Next i
End
Application.ScreenUpdating = True
End Sub
Give this a try. Although if you have tons and tons of entries in your GAL, it will take awhile to complete, and you may have to increase the 65000.
Sub tgr()
Dim appOL As Object
Dim oGAL As Object
Dim oContact As Object
Dim oUser As Object
Dim arrUsers(1 To 65000, 1 To 2) As String
Dim UserIndex As Long
Dim i As Long
Set appOL = CreateObject("Outlook.Application")
Set oGAL = appOL.GetNameSpace("MAPI").AddressLists("Global Address List").AddressEntries
For i = 1 To oGAL.Count
Set oContact = oGAL.Item(i)
If oContact.AddressEntryUserType = 0 Then
Set oUser = oContact.GetExchangeUser
If Len(oUser.lastname) > 0 Then
UserIndex = UserIndex + 1
arrUsers(UserIndex, 1) = oUser.Name
arrUsers(UserIndex, 2) = oUser.PrimarySMTPAddress
End If
End If
Next i
appOL.Quit
If UserIndex > 0 Then
Range("A2").Resize(UserIndex, UBound(arrUsers, 2)).Value = arrUsers
End If
Set appOL = Nothing
Set oGAL = Nothing
Set oContact = Nothing
Set oUser = Nothing
Erase arrUsers
End Sub
Your code assumes that you can only have ContactItem objects in the folder. It will break if you encounter an object of type DistListItem.
Declare the item variable as a generic Object, then check the Class property (exposed by all Outlook objects) or use TypeName function to figure out the exact item type.
EDIT: PR_BUSINESS_ADDRESS_COUNTRY DASL name is "http://schemas.microsoft.com/mapi/proptag/0x3A26001F"
For address entries you can see the DASS property names in OutlookSpy (I am its author). For example, you can click IMAPISession button, click QueryIdentity, select a property, look at the DASL edit box.