I already have a Array of each resource in the distribution list. How do I check each resource in the array is available via exchange server during the start and end time user is requesting? This will be an outlook addin on the ribbon.
Public Sub AddElementToStringArray(ByVal stringToAdd As String)
ReDim Preserve distArray(distArrayElements)
distArray(distArrayElements) = stringToAdd
distArrayElements += 1
End Sub
Dim startDate As Date
Dim endDate As Date
Sub checkAvailable()
'distArray declared earlier.
If distArray Is Nothing Then
Exit Sub
Else
'Check if they are available.
'if available, add to resourceListBox.
End If
End Sub
Public Sub GetFreeBusyInfo()
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myRecipient As Outlook.Recipient
Dim myFBInfo As String
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myRecipient = myNameSpace.CreateRecipient("Nate Sun")
On Error GoTo ErrorHandler
myFBInfo = myRecipient.FreeBusy(#11/11/2003#, 60 * 24)
MsgBox myFBInfo
Exit Sub
ErrorHandler:
MsgBox "Cannot access the information. "
End Sub
Related
I'm attempting to move email with specific subject when received.
The mail is still in my Inbox. I've tested by sending mail from my account with specific subject.
Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application
Dim objectNS As Outlook.NameSpace
Set outlookApp = Outlook.Application
Set objectNS = outlookApp.GetNamespace("MAPI")
Set inboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Set myInbox = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
If TypeName(item) = "MailItem" Then
Set Msg = item
If InStr(0, Msg.Subject, "Testing Subject", vbTextCompare) > 0 Then
Set fldr = Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("Testing")
Msg.Move fldr
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
I created this macro in ThisOutlookSession.
I think you may have an error with the naming of your Sub which means it doesn't fire
Items_ItemAdd => inboxItems_ItemAdd
As an addendum: I recently implemented a RegEx filter to incoming e-mails as I found I couldn't easily use rules to filter out some junk e-mail coming my way. This should be able to adapted to your needs (I've added the rule I think should work for you, but it's untested)
Within the 'ThisOutlookSession'
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
On Error Resume Next
Call RegExFilterRules(EntryIDCollection)
End Sub
Within a module
Sub RegExFilterRules(ItemID As String)
' Requires Reference: Microsoft Scripting Runtime
Dim ThisNamespace As Outlook.NameSpace: Set ThisNamespace = Application.GetNamespace("MAPI")
Dim Inbox As Outlook.MAPIFolder: Set Inbox = ThisNamespace.GetDefaultFolder(olFolderInbox)
Dim Junk As Outlook.MAPIFolder: Set Junk = ThisNamespace.GetDefaultFolder(olFolderJunk)
Dim oMsg As Outlook.MailItem: Set oMsg = ThisNamespace.GetItemFromID(ItemID, Inbox.StoreID)
If Not oMsg Is Nothing And oMsg.Class = olMail Then
'If FindPattern(oMsg.Subject, "^M\d+$") Then oMsg.Move Junk ' oMsg.Delete
If FindPattern(oMsg.Subject, "^Testing Subject") Then oMsg.Move Inbox.Folders("Testing")
End If
End Sub
Private Function FindPattern(Str As String, Pattern As String) As Boolean
Dim RegEx As Object: Set RegEx = CreateObject("vbscript.RegExp")
With RegEx
.Global = True
.IgnoreCase = True
.MultiLine = True
.Pattern = Pattern
FindPattern = .Test(Str)
End With
End Function
I want to add user to an existing DL using outlook VBA. For example. I have a DL which has email id as "testdl#contoso.com" and want add an existing user name "John.Wick#contoso.com". I also know that I can use DistListItem.AddMember to add user to an existing DL. But I am getting idea to find the existing distribution list. Please help me with this.
Sub Add_User_To_DL()
Dim myNameSpace AS Outlook.NameSpace
Dim myFolder AS Outlook.Folder
Dim myDistList AS Outlook.DistListItem
Dim myFolderItems AS Outlook.Items
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderContacts)
myFolder.Display
End Sub
But this code just opens Contacts group window. What I want is , to open the specified DL and then add specified member to DL.
To find a distribution list that includes a specific address.
Option Explicit
Sub Find_ContactGroup_Given_Member()
Dim ContactGroup As String
Dim objItem As Object
Dim objContactsFolder As Folder
Dim i As Long
Set objContactsFolder = Session.GetDefaultFolder(olFolderContacts)
For Each objItem In objContactsFolder.Items
If TypeOf objItem Is DistListItem Then
Debug.Print objItem.DLName
For i = 1 To objItem.MemberCount
If objItem.GetMember(I).Address = "testdl#contoso.com" Then
Debug.Print objItem.GetMember(i).Name
objItem.Display
End If
Next i
End If
Next
End Sub
To reference a distribution list:
Option Explicit
Sub DistListDisplay()
Dim strDistListName As String
Dim objItem As Object
Dim objContactsFolder As Folder
Dim objContactGroup As DistListItem
Dim bFound As Boolean
strDistListName = InputBox("Name of an existing distribution list.", , "Test")
If Len(strDistListName) = 0 Then Exit Sub ' Cancel
Set objContactsFolder = Session.GetDefaultFolder(olFolderContacts)
For Each objItem In objContactsFolder.Items
If TypeOf objItem Is DistListItem Then
If objItem.DLName = strDistListName Then
Set objContactGroup = objItem
With objContactGroup
.Display
bFound = True
Exit For
End With
End If
End If
Next
If bFound = False Then
MsgBox strDistListName & " not found."
End If
End Sub
If only one email is sent at a time then my code works fine, otherwise, if multiple items come in at the same time then only one of the emails is processed and moved. Basically, my code is processing items as they come into outlook. And if the email is received as a distribution list then the email is sent to a sub folder based on the distribution list name and time of day.
Here's my code:
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal cusItem As Object)
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
Dim strEntryID As String
Dim objAddressentry As Outlook.AddressEntry
Dim objRecipient As Outlook.Recipient
Dim objDestFolder As Outlook.MAPIFolder
Dim objRecs As Outlook.Recipients
Dim i As Integer
If TypeName(cusItem) = "MailItem" Then
On Error GoTo ErrorHandler
Set objRecs = cusItem.Recipients
For i = 1 To objRecs.Count
Set objRecipient = objRecs.Item(i)
strEntryID = objRecipient.EntryID
Set objAddressentry = objNS.GetAddressEntryFromID(strEntryID)
If objAddressentry = "amazonselling" And TimeValue(Now()) >= TimeValue("08:00:00 AM") And TimeValue(Now()) <= TimeValue("05:00:00 PM") Then
Set objDestFolder = objNS.GetDefaultFolder(olFolderInbox).Folders("ryule")
cusItem.Move objDestFolder
Exit For
End If
Next
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description & vbCrLf & "Click Ok to continue operations"
Resume ProgramExit
End Sub
Also, if I don't declare and set those variables twice then my code doesn't work as intended. Why is that and how could that be fixed?
The ItemAdd event is not fired when a large number of items are added to the folder at once (more than sixteen). This is a known issue when dealing with the Outlook object model. Instead, I'd suggest considering the NewMailEx event which is fired when a new message arrives in the Inbox and before client rule processing occurs. You can use the Entry ID returned in the EntryIDCollection array to call the NameSpace.GetItemFromID method and process the item.
Anyway, it seems the problem is in your code, try to remove additional declarations from both methods:
Private WithEvents Items As Outlook.Items
Private objNS As Outlook.NameSpace
Private Sub Application_Startup()
Set objNS = Application.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal cusItem As Object)
Dim strEntryID As String
Dim objAddressentry As Outlook.AddressEntry
Dim objRecipient As Outlook.Recipient
Dim objDestFolder As Outlook.MAPIFolder
Dim objRecs As Outlook.Recipients
Dim i As Integer
If TypeName(cusItem) = "MailItem" Then
On Error GoTo ErrorHandler
Set objRecs = cusItem.Recipients
For i = 1 To objRecs.Count
Set objRecipient = objRecs.Item(i)
strEntryID = objRecipient.EntryID
Set objAddressentry = objNS.GetAddressEntryFromID(strEntryID)
If objAddressentry = "amazonselling" And TimeValue(Now()) >= TimeValue("08:00:00 AM") And TimeValue(Now()) <= TimeValue("05:00:00 PM") Then
Set objDestFolder = objNS.GetDefaultFolder(olFolderInbox).Folders("ryule")
cusItem.Move objDestFolder
Exit For
End If
Next
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description & vbCrLf & "Click Ok to continue operations"
Resume ProgramExit
End Sub
I would like to make it so if an email comes in with a phone number in the subject line (so 10 numerical digits) then the system automatically moves it to a folder called "Texting."
User Reidacus asked a very similar question here:
Move incoming mail to folders with RegEx in a rule
But I can't get it to work for me. When the email comes in it just sits in my inbox. I am very new the VBA and (sorry), I don't have a clue what I'm doing. Do I need to install anything special into my system to get this to work?
Here is my adapted code (note: in the real code I have my real email address)
Sub filter(Item As Outlook.MailItem)
Dim ns As Outlook.NameSpace
Dim MailDest As Outlook.Folder
Set ns = Application.GetNamespace("MAPI")
Set Reg1 = CreateObject("VBScript.RegExp")
Reg1.Global = True
Reg1.Pattern = "([\d][\d][\d][\d][\d][\d][\d][\d][\d][\d])"
If Reg1.Test(Item.Subject) Then
Set MailDest = ns.Folders("firstname.lastname#email.ca").Folders("Inbox").Folders("Texting")
Item.Move MailDest
End If
End Sub
In order for your Sub Filter to run everytime a new emails comes in, you need to add an "event listener", by adding the code below to the ThisOutlookSession module (this code is taken from home, here on SO : How do I trigger a macro to run after a new mail is received in Outlook? )
In order for this code to take affect, you must Restart Outlook.
ThisOutlookSession Module Code
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
' get default local Inbox
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = item
' Call your custom-made Filter Sub
Call filterNewMail_TenDig(item)
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Now, you only need to make the following modifications to your Module code. Using ns.GetDefaultFolder(olFolderInbox) will get you the default "Inbox" folder for the current profile (read here at MSDN link ).
Sub filterNewMail_TenDig Code
Sub filterNewMail_TenDig(item As Outlook.MailItem)
Dim ns As Outlook.NameSpace
Dim MailDest As Outlook.Folder
Set ns = Outlook.Application.GetNamespace("MAPI")
Set reg1 = CreateObject("VBScript.RegExp")
With reg1
.Global = True
.IgnoreCase = True
.Pattern = "\d{10,10}" ' Match any set of 10 digits
End With
If reg1.Test(item.Subject) Then
Set MailDest = ns.GetDefaultFolder(olFolderInbox).Folders("Texting")
item.Move MailDest
End If
End Sub
I'm trying a different approach to something that I was working on the other day. At work, we use Outlook 2010 and receive emails with .XLSX attachments throughout the day. I'm trying to figure out how to use VBA in Outlook to check incoming emails for attachments, then if the attachment count is > 0, test the attachment and if it's a spreadsheet, update tblOutlookLog with the senders address book information. This is only my 2nd or third day experimenting with VBA outside of MS Access and I'm fumbling in the dark trying to figure out syntax. I've posted the code below from Outlook below. I get an error in the olInbox_ItemAdd(ByVal Item As Object) section at the .Subject line stating that it is an "invalid or unqualified reference". I apologize in advance in it's sloppy. Thank you for any assistance or direction.
Option Explicit
Private WithEvents InboxItems As Outlook.Items
Dim olns As NameSpace
Dim olInbox As MAPIFolder
Dim olItem As Object
Dim olAtmt As Attachment
Dim db As DAO.Database
Dim rst As DAO.Recordset
Const strdbPath = "\\FMI-FS\Users\sharp-c\Desktop\"
Const strdbName = "MSOutlook.accdb"
Const strTableName = "tblOutlookLog"
Private Sub Application_Startup()
Set olns = GetNamespace("MAPI")
Set olInbox = olns.GetDefaultFolder(olFolderInbox).Items
Set db = OpenDatabase(strdbPath & strdbName)
Set rst = db.OpenRecordset(strTableName, dbOpenDynaset)
End Sub
Private Sub Application_Quit()
On Error Resume Next
rst.Close
db.Close
Set olns = Nothing
End Sub
Private Sub olInbox_ItemAdd(ByVal Item As Object)
Dim olItem As Outlook.MailItem
Dim olAtmt As Outlook.Attachment
Dim strFoldername As String
Dim strFilename As String
Dim i As Integer
i = 0
For Each olItem In olInbox.Items
For Each olAtmt In olItem.Attachments
If olItem.olAtmt.Count > 0 Then
If Right$(olAtmt.FileName, 5) = ".xlsx" Then
strFilename = "\\FMI-FS\Users\sharp-c\Desktop\Test" & olAtmt.FileName
olAtmt.SaveAsFile strFilename
i = i + 1
rst.AddNew
rst!Subject = Left(.Subject, 255)
rst!Sender = .Sender
rst!FromAddress = .SenderEmailAddress
rst!Status = "Inbox"
rst!Logged = .ReceivedTime
rst!AttachmentPath = strFilename
Next
rst.Update
End If
Next olAtmt
Next olItem
Set olAtmt = Nothing
Set olItem = Nothing
End Sub
You need to prefix items with the object:
rst!Subject = Left(olItem.Subject, 255)
And so forth. I think you may have removed With at some stage.