I am trying to get details for users in a distribution list (containing ~200 people).
When I create a new email, add this DL as the only recipient and run the macro below, it returns ~15 first results, then "Outlook is trying to retrieve data from the Microsoft Exchange server" tray message appears and after some time I get "The operation failed" error.
If I continue the code execution the next ~15 values are returned and this issue reappears. Seams like there is some Exchange anti-spam limit.
Sub GetDetails(olMail As MailItem)
Dim i As Integer, j As Integer
For i = 1 To olMail.Recipients.Count ' count = 1
If olMail.Recipients.Item(i).AddressEntry.GetExchangeUser Is Nothing Then
For j = 1 To olMail.Recipients.Item(i).AddressEntry.Members.Count ' count ~= 200
Debug.Print olMail.Recipients.Item(i).AddressEntry.Members.Item(j).GetExchangeUser.FirstName
Next j
End If
Next i
End Sub
But if I expand the distribution list (using the '+' icon) and run slightly modified code, results for all users are returned with no issues (taking a few seconds only).
Sub GetDetails(olMail As MailItem)
Dim i As Integer
For i = 1 To olMail.Recipients.Count ' count ~= 200
If Not olMail.Recipients.Item(i).AddressEntry.GetExchangeUser Is Nothing Then
Debug.Print olMail.Recipients.Item(i).AddressEntry.GetExchangeUser.FirstName
End If
Next i
End Sub
Any ideas?
You need to release Outlook COM objects instantly in the code. This is particularly important if your add-in attempts to enumerate more than 256 Outlook items in a collection that is stored on a Microsoft Exchange Server. If you do not release these objects in a timely manner, you can reach the limit imposed by Exchange on the maximum number of items opened at any one time. When you are done, just set a variable to Nothing to release the reference to the object.
Updated (working) code based on Eugene's feedback:
Sub GetDetails(olMail As MailItem)
Dim oRecipients As Recipients
Dim oRecipient As Recipient
Dim oMembers As AddressEntries
Dim oMember As AddressEntry
Dim i As Integer, j As Integer, dRecCnt As Integer, dMemCnt As Integer
Set oRecipients = olMail.Recipients
dRecCnt = oRecipients.Count
For i = 1 To dRecCnt
Set oRecipient = oRecipients.Item(i)
If oRecipient.AddressEntry.GetExchangeUser Is Nothing Then
Set oMembers = oRecipient.AddressEntry.Members
dMemCnt = oMembers.Count
For j = 1 To dMemCnt
Set oMember = oMembers.Item(j)
Debug.Print c & ": " & oMember.GetExchangeUser.FirstName
Set oMember = Nothing
Next j
Set oMembers = Nothing
End If
Set oRecipient = Nothing
Next i
Set oRecipients = Nothing
End Sub
Related
I provided a solution to click on a folder and return how many items were contained within that folder.
Now, they've asked if that return can be kept, and broken down by sub-folders within the main folder clicked on.
Example:
INBOX has 3 sub-folders: Folder1, Folder2, Folder3
INBOX contains 3 emails of which one email comes from each sub-folder.
Thus:
INBOX Total: 3
Folder1 Total: 1
Folder2 Total: 1
Folder3 Total: 1
I created a loop that gets all subfolders contained within a main folder into an array.
My next thought was to convert that to a dictionary where I pre-set the items contained to 0. Then upon forming the dictionary using the loop I'm currently using to check if something is within the date range to also see what "folder" it belongs to and add one to the value I've pre-set to zero in the dictionary (associated array) as many times as there is a "match"
Below is what I've attempted:
Sub Countemailsperday()
Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim EmailCount As Integer
Dim ODate As String
Dim ODate2 As String
Dim dict As Dictionary
Set dict = New Dictionary
Dim coll As New Collection
Dim oDict As Object
Set oDict = CreateObject("Scripting.Dictionary")
' Dim Dict As Scripting.Dictionary
ODate = InputBox("Start Date? (format YYYY-MM-DD")
ODate2 = InputBox("End Date? (format YYYY-MM-DD")
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
On Error Resume Next
Set objFolder = Application.ActiveExplorer.CurrentFolder
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder."
Exit Sub
End If
EmailCount = objFolder.Items.Count
MsgBox "Number of emails in the folder: " & EmailCount, , "email count"
Dim ssitem As MailItem
Dim dateStr As String
Dim numholder As Integer
Dim myItems As Outlook.Items
'Dim dict As Object
Dim msg As String
Dim oParentFolder As MAPIFolder
Dim i As Integer
Dim iElement As Integer
Dim sArray() As String
Dim ArrayLen As Integer
Dim Subtractor As Integer
Dim str As String
ReDim sArray(0) As String
Set oParentFolder = objFolder
Set myItems = objFolder.Items
'Set Dict = New Scripting.Dictionary
If oParentFolder.Folders.Count Then
For i = 1 To oParentFolder.Folders.Count
If Trim(oParentFolder.Folders(i).Name) <> "" Then
iElement = IIf(sArray(0) = "", 0, UBound(sArray) + 1)
ReDim Preserve sArray(iElement) As String
sArray(iElement) = oParentFolder.Folders(i).Name
End If
Next i
Else
sArray(0) = oParentFolder.Name
End If
ArrayLen = UBound(sArray) - LBound(sArray) + 1
'MsgBox "thingy thing"
'MsgBox "thing" & sArray(1) ' This is how to iterate through the Dictionary
myItems.SetColumns ("ReceivedTime")
' Determine date of each message:
' MsgBox DateValue(ODate)
For Subtractor = 0 To (ArrayLen - 1)
If oDict.Exists(sArray(Subtractor)) Then
oDict(sArray(Subtractor)).Add
With dict
For Subtractor = 0 To (ArrayLen - 1)
If ArrayLen = 1 Then
.Add Key = objFolder.Name, Item = 0
Else
If Subtractor = 0 Then
.Add Key = CStr(sArray(Subtractor)), Item = 0
Else
End If
str = CStr(sArray(Subtractor))
End If
Next Subtractor
End With
MsgBox str
If dict.Exists(str) Then
Debug.Print (dict(str))
Else
Debug.Print ("Not Found")
End If
MsgBox dict(str)
numholder = 0
'For Each
For Each myItem In myItems
dateStr = GetDate(myItem.ReceivedTime)
' MsgBox DateValue(dateStr)
If DateValue(dateStr) >= DateValue(ODate) And DateValue(dateStr) <= DateValue(ODate2) Then
If Not dict.Exists(dateStr) Then
dict(dateStr) = 0
numholder = numholder
End If
dict(dateStr) = CLng(dict(dateStr)) + 1
numholder = numholder + 1
End If
Next myItem
' Output counts per day:
msg = ""
For Each o In dict.Keys
msg = msg & o & ": " & dict(o) & " items" & vbCrLf
Next
If msg = "" Then
MsgBox "There are no emails during this time range"
End If
If msg <> "" Then
MsgBox "Number of emails during date range: " & numholder
MsgBox msg
End If
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
End Sub
Function GetDate(dt As Date) As Date
GetDate = Year(dt) & "-" & Month(dt) & "-" & Day(dt)
End Function
I want to accomplish the following:
INBOX Total: 3
Folder1 Total: 1
Folder2 Total: 1
Folder3 Total: 1
as well as to handle the case where the folder that's clicked on contains no subfolders.
I do not understand your code. You do things but do not explain how they contribute to your objective. There is date processing code which does not appear relevant. If one could write code and never need to look at it again, the lack of comments would be OK. But normally, after six, twelve or twenty months, a routine needs some attention. Perhaps there is an edge condition that is not handled correctly or perhaps the requirement has changed. Maintaining poorly documented code is a nightmare.
The code at the bottom of this answer is a simplified version of a routine I wrote some years ago. It does not do exactly what you appear to request and it does not use the technique you request. Perhaps my code will be acceptable. If not, I believe I have included enough explanations to allow you to amend my code to your requirements.
First an introduction to the techniques I have used. As peakpeak suggests, my code uses recursion. I have also used a collection instead of a dictionary. These techniques are not documented in the code because they are standard features of VBA and I do not document VBA within my code.
I do not use dictionaries. Collections provide all the functionality I have ever required. Dictionaries, as I understand it, have much in common with collections and have some functionality that collections lack. But more importantly for me, they lack some of the functionality of collections that I find essential.
You specify a collection so:
Dim Coll As New Collection
or
Dim Coll As Collection
Set Coll = New Collection
Coll.Add X will create a new entry at the end of Coll containing X. You can add new entries in the middle of existing entries and you can remove existing entries but I do not use this functionality in the code below.
In Coll.Add X, X can be almost anything. It can be a simple value such as a string, a long or a Boolean. It can be an array or an instance of a class. It cannot be an instance of a user type. You cannot amend an entry within a collection. Should you need to amend an entry, you must remove the existing entry and add the amended version in the same position.
Since an entry within a collection can be anything, you need to be careful. If variable I is a Long:
I = I + Coll(5)
will give a runtime error if Coll(5) is a string or anything else that cannot be added to a Long.
If you add an array to a Collection, the syntax for reading it is, perhaps, not immediately obvious. Consider:
Coll.Add VBA.Array(Fldr.Name, Level, NumEmails)
Suppose the above Add has created the third entry in Coll; that is Coll(3). Then:
Coll(3)(0) is FldrName
Coll(3)(1) is Level
Coll(3)(2) is NumEmails
Note that I use VBA.Array instead of Array because Array is affected by the Option Base statement. By using VBA.Array I know the lower bound will always be zero.
On reflection, perhaps this syntax is not so strange. If I declare Dim Arr(0 To 5) As Long, I write Arr(0) to access element 0 of Arr. My Coll(3) is an array so I write Coll(3)(0) to access element 0 of Coll(3).
Recursion is where a routine calls itself. This technique is ideal for processing tree-like structures. There are techniques that are faster and not such heavy users of memory but none of these other techniques are so simple to use.
Suppose the folder hierarchy to be processed is:
FolderA
FolderB
FolderC
FolderD
FolderE
FolderF
FolderG
My routine is NumEmailsByFolder and has parameters:
Reference to top level folder
Long Level
Reference to collection FldrDtls
Level is not mentioned in your requirement but without it you cannot tell that FolderF is within FolderA. I tend to think of the top level as level 0 but you can use any value you find convenient.
The external routine creates an empty collection, which my routine call FldrDtls, and then calls:
NumEmailsByFolder([FolderA], 0, [FldrDtls])
Where [X] indicates a reference to object X.
NumEmailsByFolder counts the number of emails in FolderA, adds an entry to FldrDtls with the name “FolderA”, level 0, and the email count. It then calls itself for FolderB, FolderF and FolderG with level 1. This makes for pretty simple code. The secret of recursion is the sequence in which the interpreter actions all the different calls:
Calls in sequence executed Entry added to FldrDtls
NumEmailsByFolder([FolderA], 0, [FldrDtls]) FolderA 0 Count
NumEmailsByFolder([FolderB], 1, [FldrDtls]) FolderB 1 Count
NumEmailsByFolder([FolderC], 2, [FldrDtls]) FolderC 2 Count
NumEmailsByFolder([FolderD], 2, [FldrDtls]) FolderD 2 Count
NumEmailsByFolder([FolderE], 2, [FldrDtls]) FolderE 3 Count
NumEmailsByFolder([FolderF], 1, [FldrDtls]) FolderF 1 Count
NumEmailsByFolder([FolderG], 1, [FldrDtls]) FolderG 1 Count
The entries in FldrDtls are in the sequence wanted with subfolders following their parent folders. I have only four levels in my example hierarchy but the same code will handle 10 or 100 levels with all the difficult stuff handled by the interpreter.
Most people seem to find recursion difficult to understand at first; certainly I did when I was taught it at university many years ago. Then suddenly you see the light and you no longer understand why you found it difficult. I compare it with learning to drive a car. At the end of the first lesson you know you will never be able to turn the wheel, press one or more pedals, move the gearstick, look in the mirror and use the indicator while trying to avoid other road users all at the same time. But a few lessons later, you can do all that and more.
My routine is:
Sub NumEmailsByFolder(ByRef FldrPrnt As Folder, ByVal Level As Long, _
ByRef FldrDtls As Collection)
' Adds an entry to FldrDtls for FldrPrnt.
' Calls itself for each immediate subfolder of FldrPrnt.
' Each entry in FldrDtls is an zero-based array containing:
' * (0) Folder name
' * (1) Level of folder within hierarchy. The level of the first (top)
' folder is as specified in the call. Each level down is one more.
' * (2) Number of emails in folder. Note: this value does not include
' any emails in any subfolders
' The external routine that calls this routine will set the parameters:
' * FldrPrnt can be a Store or a MAPIFolder at any level with the
' folder hierarchy.
' * Level might typically be set to zero or one but the initial value
' is unimportant to this routine.
' * FldrDtls would normally be an empty collection. This is not checked
' so FldrDtls may contain existing entries if this is convenient for
' the calling routine.
' On return to the external routine, the entries in FldrDtls might be:
' Inbox 0 10
' SubFldr1 1 5
' SubSubFldr1 2 3
' SubSubFldr2 2 4
' SubFldr2 1 9
Dim ErrNum As Long
Dim InxI As Long
Dim InxS As Long
Dim ItemsCrnt As Items
Dim SubFldrsCrnt As Folders
Dim NumMailItems As Long
With FldrPrnt
'Count MailItems, if any
Err.Clear
NumMailItems = 0
' In the past, I have had code crash when I attempted to access the
' Items of a folder but I have had no such error recently. This could
' be because I am now retired and my employer's Outlook installation
' had folders without items. Alternatively, it could be because
' Outlook 2016 is more robust than Outlook 2003. I use On Error to
' ensure any such error does not crash my routine.
On Error Resume Next
Set ItemsCrnt = FldrPrnt.Items
ErrNum = Err.Number
On Error GoTo 0
If ErrNum = 0 Then
' Only attempt to count MailItems within FldrPrnt if attempting to
' access its Items does not give an error.
For InxI = 1 To ItemsCrnt.Count
If ItemsCrnt(InxI).Class = olMail Then
NumMailItems = NumMailItems + 1
End If
Next
End If
FldrDtls.Add VBA.Array(FldrPrnt.Name, Level, NumMailItems)
Set SubFldrsCrnt = FldrPrnt.Folders
' See above for explanation of On Error
ErrNum = Err.Number
On Error GoTo 0
If ErrNum = 0 Then
' Only attempt to count MailItems within FldrPrnt if attempting to
' access its Folders does not give an error.
For InxS = 1 To SubFldrsCrnt.Count
Call NumEmailsByFolder(SubFldrsCrnt(InxS), Level + 1, FldrDtls)
Next
End If
End With
End Sub
I hope you agree that this code is simple considering what it can achieve. If I thought it was safe to remove the error handling code, the routine would be even smaller.
To demonstrate how to call this routine, add the following code:
Option Explicit
Sub TestNumEmailsByFolder()
Dim FldrDtls As Collection
Dim Fldr1 As Folder
Dim Fldr2 As Folder
Dim Fldr3 As Folder
Dim FldrCrnt As Folder
Dim FldrInx As Variant
Dim InxF As Long
Set Fldr1 = Session.Folders("johndoe#acme.com").Folders("Inbox").Folders("Test")
Set Fldr2 = Session.Folders("johndoe#acme.com").Folders("Inbox")
Set Fldr3 = Session.Folders("johndoe#acme.com")
For Each FldrInx In Array(Fldr1, Fldr2, Fldr3)
Set FldrCrnt = FldrInx
Set FldrDtls = New Collection
Call NumEmailsByFolder(FldrCrnt, 0, FldrDtls)
Debug.Print "Emails"
For InxF = 1 To FldrDtls.Count
Debug.Print PadL(FldrDtls(InxF)(2), 5) & _
Space(1 + FldrDtls(InxF)(1) * 2) & FldrDtls(InxF)(0)
Next
Next
End Sub
Public Function PadL(ByVal Str As String, ByVal PadLen As Long, _
Optional ByVal PadChr As String = " ") As String
' Pad Str with leading PadChr to give a total length of PadLen
' If the length of Str exceeds PadLen, Str will not be truncated
' Sep15 Coded
' 20Dec15 Added code so overlength strings are not truncated
' 10Jun16 Added PadChr so could pad with characters other than space
If Len(Str) >= PadLen Then
' Do not truncate over length strings
PadL = Str
Else
PadL = Right$(String(PadLen, PadChr) & Str, PadLen)
End If
End Function
Amend the Set Fldr1, Set Fldr2 and Set Fldr3 statements to reference folders on your system. I have started with a folder at the bottom of the hierarchy then a folder in the middle and then a folder at the top. I suggest you pick a similar set of folders. Study the output to the Immediate Window and consider how the sequence of the list has been created.
Is this the routine you want?
It uses a Collection instead of a Dictionary? Does this matter? If my understanding of Dictionaries is correct, a Dictionary would be inappropriate.
You use an array and ReDim Preserve. A Collection is a good choice when you have no idea how many entries will be required. ReDim Preserve is an expensive command in terms of time and memory. The interpreter has to find a new block of memory big enough for the enlarged array. It has to copy values from the old array to the new and initialise the new elements. Finally, it has to release the old array for garbage collection. If I need the final result to be in an array then, with this type of problem, I normally build the list in a collection, size my array according to the size of the collection and then copy data from the collection to the array.
The count of emails against a folder does not include emails in its subfolders. This appears to be a requirement. You cannot amend an entry in a collection so, if this is a requirement, I would handle it as part of the conversion to an array.
Subfolders are not listed in alphabetic sequence. I have never investigated properly but I suspect subfolders are listed in the sequence created. If this is unsatisfactory, you will need a sort. There are several possible approaches. Given there will normally be a small number of subfolders per folder, I suspect the simplest approach will be the best. If you need something a lot more powerful, I have an implementation of Quick Sort that uses indices to avoid sorting the source list.
Can someone point out what I am missing here. Every time I run this it says that an object is required.
I apologize I feel like this is a very easy fix but I have been wrecking my brain for a while.
Basically what I am trying to accomplish is count how many emails are mark as high importance.
Again I feel like this is such a simple error but I am still learning this.
Sub CheckForImportance()
Dim myNs As Outlook.NameSpace
Dim infldr As Outlook.Folder
Dim impMail As Outlook.MailItem
Dim ttlcount As Integer
Set myNs = Application.GetNamespace("MAPI")
Set infldr = myNs.GetDefaultFolder(olFolderInbox)
Set impMail = infldr.Items
Set ttlcount = 0
If impMail.Importance = olImportanceHigh Then ttlImp = ttlImp + 1
MsgBox ("count:" & ttlImp)
End Sub
Outlook stores mail items, calendar items, tasks and so on in files it calls Stores. Sometimes people say mail items and so on are stored in PST files which is usually true. However, all PST files are stores but not all stores are PST files.
I remember when the default was for messages sent to any of your email addresses to be loaded to the same store. In that situation, Set infldr = myNs.GetDefaultFolder(olFolderInbox)was useful since the default Inbox was in that one store.
With Outlook 2016, and perhaps some other recent versions, the default is to have a separate store for each email address. Each of these stores is named for the email address, for example: “JohnDoe#hotmail.com” or “DoeJ#gmail.com”.
Copy this macro to an Outlook module and run it:
Sub DsplUsernameOfDefaultStore()
Dim NS As Outlook.NameSpace
Dim DefaultInboxFldr As MAPIFolder
Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI")
Set DefaultInboxFldr = NS.GetDefaultFolder(olFolderInbox)
Debug.Print DefaultInboxFldr.Parent.Name
End Sub
On my system, this macro outputs “Outlook Data File”. This was the default store that came with Outlook but none of my emails are loaded to it.
You will need something like:
Set infldr = Session.Folders("Xxxx").Folders("Inbox")
where Xxxx is the name of the store containing the Inbox you wish to interrogate.
Below I have three alternative macros that count the number of high importance emails in an Inbox. Points of particular note:
Version 1 uses a For Each loop as I suggested in my comment. Version 2 uses a For IndexVariable loop. To my knowledge, neither type of For has an advantage over the other. I use whichever seems more convenient for the task at hand. Version 3 uses a filter. I have not found a use for the Outlook filter often enough to have become expert in its use so I normally use a For loop. olImportanceHigh is a constant with a value of 2. It appears you cannot use a constant within a Restrict string which is why it says [Importance] = 2.
I find Debug.Print much more convenient than MsgBox during development.
Come back with questions about my code as necessary.
Option Explicit
Sub CountHighImportanceEmails1()
Dim FldrInbox As Folder
Dim MailItemCrnt As MailItem
Dim NumEmailsHighImport As Long
Set FldrInbox = Session.Folders("Xxxx").Folders("Inbox")
NumEmailsHighImport = 0
For Each MailItemCrnt In FldrInbox.Items
If MailItemCrnt.Importance = olImportanceHigh Then
NumEmailsHighImport = NumEmailsHighImport + 1
End If
Next
Debug.Print "Number of high importance emails=" & NumEmailsHighImport
End Sub
Sub CountHighImportanceEmails2()
Dim FldrInbox As Folder
Dim InxMi As Long
Dim NumEmailsHighImport As Long
Set FldrInbox = Session.Folders("Xxxx").Folders("Inbox")
NumEmailsHighImport = 0
With FldrInbox
For InxMi = 1 To .Items.Count
If .Items(InxMi).Importance = olImportanceHigh Then
NumEmailsHighImport = NumEmailsHighImport + 1
End If
Next
End With
Debug.Print "Number of high importance emails=" & NumEmailsHighImport
End Sub
Sub CountHighImportanceEmails3()
Dim FldrInbox As Folder
Dim MailItemsHighImport As Items
Set FldrInbox = Session.Folders("Xxxx").Folders("Inbox")
Set MailItemsHighImport = FldrInbox.Items.Restrict("[Importance] = 2")
Debug.Print "Number of high importance emails=" & MailItemsHighImport.Count
End Sub
Example would be
Option Explicit
Public Sub Example()
Dim Inbox As Outlook.folder
Set Inbox = Application.Session.GetDefaultFolder( _
olFolderInbox)
Dim Filter As String
Filter = "[Importance] = 2"
Dim Items As Outlook.Items
Set Items = Inbox.Items.Restrict(Filter)
Debug.Print Items.Count
MsgBox Items.Count & " High importance Items are in " & Inbox.Name
End Sub
I am writing a macro that should remove attachments. From my debugging sessions, it appears as if it should work. The breakpoint is hit and it recognizes the message object:
I know this sounds a bit silly, but, oddly enough, it seems to work if I set a breakpoint, and open the expression/watch, but not otherwise.
I have been struggling with this for quite some time; I would appreciate any guidance.
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim header As String
Dim objNewMail As Outlook.MailItem
Dim Item As Object
Dim count As Integer
Dim objInbox As Outlook.Folder
Set objInbox = Outlook.Session.GetDefaultFolder(olFolderInbox)
Dim entryIDs
entryIDs = Split(EntryIDCollection, ",")
Dim i As Integer
For i = 0 To UBound(entryIDs)
Set objNewMail = Application.Session.GetItemFromID(entryIDs(i))
If objNewMail.Attachments.count > 0 Then
header = GetHeader(objNewMail)
If DoesIPMatch(header) <> True Then
DeleteMessage (objNewMail)
ElseIf IsAttachmentPDF(objNewMail) <> True Then
For count = 1 To objNewMail.Attachments.count
objNewMail.Attachments.Remove (count)
Next
End If
End If
Next
End Sub
Try this, as a most likely culprit if you are removing items from a collection it should always be done in reverse order, otherwise you have to re-index your counter variable, and that makes for messy code:
It may also be necessary to Save the objNewMail item after you've modified it (e.g., by removing attachments)
For count = objNewMail.Attachments.count to 1 Step - 1
objNewMail.Attachments.Remove count
Next
objNewMail.Save '## Not sure if this is necessary
Alternatively:
With objNewMail.Attachments
While .Count > 0
.Remove 1
Wend
End With
objNewMail.Save
I am trying to send a group message to more than one user over Lync/Microsoft Communicator from Excel using VBA.
The below code works for a single e-mail address/user but if a cell range of two e-mail addresses is provided, it gives "Method 'CreateGroup' of Object IMessengerAdvanced' failed" error. Any advice would be greatly appreciated.
Sub sendIM()
Dim msgr As CommunicatorAPI.IMessengerConversationWndAdvanced
Dim msgTo As Variant
msgTo = Sheets("Sheet1").Range("A1:A2").Value
msgr = Messenger.InstantMessage(msgTo)
msgr.SendText ("Test")
End Sub
The InstantMessage(Object) method supposedly works for >1 user according to this previous topic below, but in practice it doesn't seem to...
Lync notification of offline people using VBA
The interface expects an Array of email addresses when sending to a group.
instead of:
Sub sendIM()
Dim msgr As CommunicatorAPI.IMessengerConversationWndAdvanced
Dim msgTo As Variant
msgTo = Sheets("Sheet1").Range("A1:A2").Value
msgr = Messenger.InstantMessage(msgTo)
msgr.SendText ("Test")
End Sub
test this:
Sub sendIM()
Dim msgr As CommunicatorAPI.IMessengerConversationWndAdvanced
Dim msgTo() As Variant
ReDim msgTo(0 To 0) 'Allocate first element
For Each cell In Sheets("Sheet1").Range("A1:A2")'put your range here
msgTo(UBound(msgTo)) = cell.Value2 'Assign the array element
ReDim Preserve msgTo(UBound(msgTo) + 1) 'Allocate next element
Next
ReDim Preserve msgTo(LBound(msgTo) To UBound(msgTo) - 1) 'Deallocate the last, unused element
'sometimes you need to use Set, sometimes you dont, depending on environment you have, or maybe OPTION EXPLICIT
Set msgr = Messenger.InstantMessage(msgTo)
'msgr = Messenger.InstantMessage(msgTo)
msgr.SendText ("Test")
End Sub
I need to build a tool that will allow the user to select an email from his Outlook so I can then save that email as a .msg file or alternately save just the attachment as a file.
I'm stumbling a little bit over what might be the easiest and the best way to allow searching/filtering of emails. I need to give the user a view that is at least slightly similar to Outlook (for example, folders should be the same order/hierarchy.
Does the Outlook Object Model have some kind of Explorer/Picker/Selection dialog I can call that will return a storeid and an entryid after the user selects an email? Or do I need to roll my own?
I should mention that I already know how to save the email or attachment so my question is only about handling selection and filtering of emails.
FYI, I'm programming this in MS Access 2007 with Outlook 2007. The target machines have either 2007 or 2010 versions of Access and Outlook.
Linking to the Outlook table is fine. The problem is that Outlook doesn't provide a unique ID to each message and if the message is moved from one folder to another, its ID changes. Clearly not designed by someone who understands databases.
A better approach may be to create an Outlook add-in that runs within Outlook, then performs the tasks you need to send the info to Access.
I rarely program with Access but I moved some code across from Outlook, hacked it around a bit and it seems to work. This is not a solution but it should show you how to access all the information you need.
I had one problem. Neither Set OutApp = CreateObject("Outlook.Application") nor Set OutApp = New Outlook.Application create a new instance of Outlook if one is already open. So Quit closes Outlook whether or not it was open before the macro started. I suggest you post a new question on this issue; I am sure someone knows how to tell if Outlook is already open and therefore not to quit it.
The folder structure in Outlook is slightly awkward because the top level folders are of type Folders while all sub-folders are of type MAPIFolder. Once you have got past that it is fairly straightforward.
The code below includes function GetListSortedChildren(ByRef Parent As MAPIFolder) As String. This function finds all the children of Parent and returns a string such as "5,2,7,1,3,6,4" which lists the indices for the children in ascending sequence by name. I would use something like this to populates a ListView by expanding nodes as the user required.
I have provided a subroutine CtrlDsplChld() which controls the output to the immediate windows of all the folders in sequence. I believe that should give you enough guidance to get started on accessing the folder hierarchy.
Subroutine DsplChld(ByRef Parent As MAPIFolder, ByVal Level As Long) includes code to find the first message with attachments. This will you tell you how to look through a folder for a particular message.
Finally, CtrlDsplChld() displayes selected properties of the message: Subject, To, HTMLBody and the display names of the attachments.
Hope this helps.
Option Compare Database
Option Explicit
Dim ItemWithMultipleAttachments As Outlook.MailItem
Sub CtrlDsplChld()
Dim ArrChld() As String
Dim ListChld As String
Dim InxAttach As Long
Dim InxChld As Long
Dim InxTopLLCrnt As Long
Dim OutApp As Outlook.Application
Dim TopLvlList As Folders
Set ItemWithMultipleAttachments = Nothing
Set OutApp = CreateObject("Outlook.Application")
'Set OutApp = New Outlook.Application
With OutApp
Set TopLvlList = .GetNamespace("MAPI").Folders
For InxTopLLCrnt = 1 To TopLvlList.Count
' Display top level children and their children
Call DsplChld(TopLvlList.Item(InxTopLLCrnt), 0)
Next
If Not ItemWithMultipleAttachments Is Nothing Then
With ItemWithMultipleAttachments
Debug.Print .Subject
Debug.Print .HTMLBody
Debug.Print .To
For InxAttach = 1 To .Attachments.Count
Debug.Print .Attachments(InxAttach).DisplayName
Next
End With
End If
.Quit
End With
Set OutApp = Nothing
End Sub
Sub DsplChld(ByRef Parent As MAPIFolder, ByVal Level As Long)
Dim ArrChld() As String
Dim InxChld As Long
Dim InxItemCrnt As Long
Dim ListChld As String
Debug.Print Space(Level * 2) & Parent.Name
If ItemWithMultipleAttachments Is Nothing Then
' Look down this folder for a mail item with an attachment
For InxItemCrnt = 1 To Parent.Items.Count
With Parent.Items(InxItemCrnt)
If .Class = olMail Then
If .Attachments.Count > 1 Then
Set ItemWithMultipleAttachments = Parent.Items(InxItemCrnt)
Exit For
End If
End If
End With
Next
End If
ListChld = GetListSortedChildren(Parent)
If ListChld <> "" Then
' Parent has children
ArrChld = Split(ListChld, ",")
For InxChld = LBound(ArrChld) To UBound(ArrChld)
Call DsplChld(Parent.Folders(ArrChld(InxChld)), Level + 1)
Next
End If
End Sub
Function GetListSortedChildren(ByRef Parent As MAPIFolder) As String
' The function returns "" if Parent has no children.
' If the folder has children, the functions returns "P,Q,R, ..." where
' P, Q, R and so on indices of the children of Parent in ascending
' order by name.
Dim ArrInxFolder() As Long
'Dim ArrFolder() As MAPIFolder
Dim InxChldCrnt As Long
Dim InxName As Long
Dim ListChld As String
If Parent.Folders.Count = 0 Then
' No children
GetListSortedChildren = ""
Else
'ReDim ArrName(1 To Parent.Folders.Count)
'For InxChldCrnt = 1 To Parent.Folders.Count
' ArrFolder(InxChldCrnt) = Parent.Folders(InxChldCrnt)
'Next
Call SimpleSortMAPIFolders(Parent, ArrInxFolder)
ListChld = CStr(ArrInxFolder(1))
For InxChldCrnt = 2 To Parent.Folders.Count
ListChld = ListChld & "," & CStr(ArrInxFolder(InxChldCrnt))
Next
GetListSortedChildren = ListChld
End If
End Function
Sub SimpleSortMAPIFolders(ArrFolder As MAPIFolder, _
ByRef InxArray() As Long)
' On exit InxArray contains the indices into ArrFolder sequenced by
' ascending name. The sort is performed by repeated passes of the list
' of indices that swap adjacent entries if the higher come first.
' Not an efficient sort but adequate for short lists.
Dim InxIACrnt As Long
Dim InxIALast As Long
Dim NoSwap As Boolean
Dim TempInt As Long
ReDim InxArray(1 To ArrFolder.Folders.Count) ' One entry per sub folder
' Fill array with indices
For InxIACrnt = 1 To UBound(InxArray)
InxArray(InxIACrnt) = InxIACrnt
Next
If ArrFolder.Folders.Count = 1 Then
' One entry list already sorted
Exit Sub
End If
' Each repeat of the loop moves the folder with the highest name
' to the end of the list. Each repeat checks one less entry.
' Each repeats partially sorts the leading entries and may result
' in the list being sorted before all loops have been performed.
For InxIALast = UBound(InxArray) To 1 Step -1
NoSwap = True
For InxIACrnt = 1 To InxIALast - 1
If ArrFolder.Folders(InxArray(InxIACrnt)).Name > _
ArrFolder.Folders(InxArray(InxIACrnt + 1)).Name Then
NoSwap = False
' Move higher entry one slot towards the end
TempInt = InxArray(InxIACrnt)
InxArray(InxIACrnt) = InxArray(InxIACrnt + 1)
InxArray(InxIACrnt + 1) = TempInt
End If
Next
If NoSwap Then
Exit For
End If
Next
End Sub