I want to run a vba app to find the emails in this mailbox and give me the total number for each date from the last three days. The folder is correct and I can see the next mailitem. The main problem I am having is that I want the for each to end after it gets to the fourth day. I am getting compile errors at the end of the foreach and nested if statements. Do I need to have Next anywhere if it's a for each?
Sub NonTicketEmailsCount()
Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim EmailCount As Integer
Dim MailItem
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
On Error Resume Next
Set objFolder = objnSpace.Folders("Mailbox - IT Support Center").Folders("Non ticket related emails")
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder."
Exit Sub
End If
EmailCount = objFolder.Items.Count
Dim dateStr As String
Dim dict As Object
Dim msg As String
Set dict = CreateObject("Scripting.Dictionary")
' Determine date of each message:
For Each MailItem In objFolder.Items
rt = MailItem.ReceivedTime 'getting received time for each mailitem
nrt = Format(rt, "M/ d/ yyyy") 'formatting the received time to match value of datevalue keyword
If DateValue(nrt) = Empty Then
NonTicket0 = NonTicket0 + 1
ElseIf DateValue(Date - 1) = DateValue(nrt) Then
NonTicket1 = NonTicket1 + 1
ElseIf DateValue(Date - 2) = DateValue(nrt) Then
NonTicket2 = NonTicket2 + 1
ElseIf DateValue(Date - 3) = DateValue(nrt) Then
NonTicket3 = NonTicket3 + 1
ElseIf DateValue(Date - 4) = DateValue(nrt) Then
Exit For
End If
msg = "Total NonTicket emails in the folder: " & EmailCount & vbNewLine _
& NonTicket1 & " = NonTicket Emails on " & Date - 1 & vbNewLine _
& NonTicket2 & " = NonTicket Emails on " & Date - 2 & vbNewLine _
& NonTicket3 & " = NonTicket Emails on " & Date - 3 & vbNewLine _
MsgBox "Number of emails in the folder: " & EmailCount & vbNewLine _
& "NonTicket Emails Yesterday: " & NonTicket1 & vbNewLine _
& "NonTicket Emails Yesterday: " & NonTicket2 & vbNewLine _
& "NonTicket Emails Yesterday: " & NonTicket3
'Send Mail
Set OutApp = CreateObject("outlook.Application")
Set OutMail = OutApp.CreateItem(o)
With OutMail
.Subject = "Non Ticket Emails"
.To = "kylesparmark#glissondo.com; meisnert#glissondo.com"
.Body = msg
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
End Sub
You're missing the NEXT statement to close your FOR EACH loop:
For Each MailItem In objFolder.Items
rt = MailItem.ReceivedTime 'getting received time for each mailitem
nrt = Format(rt, "M/ d/ yyyy") 'formatting the received time to match value of datevalue keyword
If DateValue(nrt) = Empty Then
NonTicket0 = NonTicket0 + 1
ElseIf DateValue(Date - 1) = DateValue(nrt) Then
NonTicket1 = NonTicket1 + 1
ElseIf DateValue(Date - 2) = DateValue(nrt) Then
NonTicket2 = NonTicket2 + 1
ElseIf DateValue(Date - 3) = DateValue(nrt) Then
NonTicket3 = NonTicket3 + 1
ElseIf DateValue(Date - 4) = DateValue(nrt) Then
Exit For
End If
NEXT ' <--- Add this
Related
I am creating a macro to get email by subject and received date in our team shared box.
I use for loop to check all email in mailbox but it takes forever because my statement checks 1000+ mails.
How can I get email by specific date? Let's say I need email 12/1/2017 to 12/30/2017.
The key is using Restrict method but I don't know how I can use it.
Sub GetFromOutlook()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Dim olShareName As Outlook.Recipient
Set olShareName = OutlookNamespace.CreateRecipient("sharemailbox#example.ca")
Set Folder = OutlookNamespace.GetSharedDefaultFolder(olShareName, olFolderInbox).Folders("sharebox subfolder").Folders("sharebox subfolder2")
i = 1
For Each OutlookMail In Folder.Items
If ((Range("From_Date").Value <= OutlookMail.ReceivedTime) And _
(OutlookMail.ReceivedTime <= Range("To_Date").Value)) And _
OutlookMail.Sender = "sender#example.com" Then
Range("eMail_subject").Offset(i, 0).Value = OutlookMail.Subject
Range("eMail_date").Offset(i, 0).Value = OutlookMail.ReceivedTime
i = i + 1
End If
Next OutlookMail
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
End Sub
I assume the code I have to fix is:
<For Each OutlookMail In Folder.Items>
How can I make statement using Restrict Method?
You could probably use the GetTable instead of a loop which has to process each email (or item) one by one.
GetTable will allow you to apply a filter on the content of the folder which should operate much faster.
For more details and an example, you can check the MSDN article on the Folder.GetTable Method for Outlook.
And for the specific filter that you are trying to apply, I would try:
"([ReceivedTime]>=12/1/17) AND ([ReceivedTime]<=12/30/17)"
You can create a collection of items restricted by date like this.
Option Explicit
Private Sub EmailInTimePeriod()
Dim oOlInb As Folder
Dim oOlItm As Object
Dim oOlResults As Object
Dim i As Long
Dim sFilterLower As String
Dim sFilterUpper As String
Dim sFilter As String
Dim dStart As Date
Dim dEnd As Date
Set oOlInb = Session.GetDefaultFolder(olFolderInbox)
' https://msdn.microsoft.com/en-us/library/office/ff869597.aspx
' 12/1/2017 to 12/30/2017
'dStart = "2017/12/01"
'dEnd = "2017/12/30"
' 1/12/2018 to 1/15/2018
dStart = "2018/01/12"
dEnd = "2018/01/16"
' Lower Bound of the range
sFilterLower = "[ReceivedTime]>'" & Format(dStart, "DDDDD HH:NN") & "'"
Debug.Print vbCr & "sFilterLower: " & sFilterLower
' *** temporary demo lines
' Restrict the items in the folder
Set oOlResults = oOlInb.Items.Restrict(sFilterLower)
Debug.Print oOlResults.count & " items."
If oOlResults.count > 0 Then
For i = 1 To oOlResults.count
Set oOlItm = oOlResults(i)
Debug.Print oOlItm.ReceivedTime & " - " & oOlItm.subject
Next i
End If
' *** temporary demo lines
' Upper Bound of the range
sFilterUpper = "[ReceivedTime]<'" & Format(dEnd, "DDDDD HH:NN") & "'"
Debug.Print vbCr & "sFilterUpper: " & sFilterUpper
' *** temporary demo lines
' Restrict the Lower Bound result
Set oOlResults = oOlResults.Restrict(sFilterUpper)
Debug.Print oOlResults.count & " items."
If oOlResults.count > 0 Then
For i = 1 To oOlResults.count
Set oOlItm = oOlResults(i)
Debug.Print oOlItm.ReceivedTime & " - " & oOlItm.subject
Next i
End If
' *** temporary demo lines
' combine the filters
sFilter = sFilterLower & " AND " & sFilterUpper
Debug.Print vbCr & "sFilter: " & sFilter
Set oOlResults = oOlInb.Items.Restrict(sFilter)
Debug.Print oOlResults.count & " items."
If oOlResults.count > 0 Then
For i = 1 To oOlResults.count
Set oOlItm = oOlResults(i)
Debug.Print oOlItm.ReceivedTime & " - " & oOlItm.subject
Next i
End If
ExitRoutine:
Set oOlInb = Nothing
Set oOlResults = Nothing
Set oOlItm = Nothing
Debug.Print "Done."
End Sub
Note the code is set up to be used in Outlook.
How do i count the total participants of a meeting before adding another and sending it?
I've managed to automate calendar invites based on specific responses.
I now need to set a max number of participants and respond with a mail if the maximum number of participants for that meeting or event has been reached.
It seems to stay on "1" if i check the value.
This is as far as i've been able to come without reaching out for help on it.
Private Sub objNewMailItems_ItemAdd(ByVal Item As Object)
Dim objMeetingInvitation As Outlook.MeetingItem
Dim objMeeting As Outlook.AppointmentItem
Dim objAttendees As Outlook.Recipients
Dim objAttendee As Outlook.Recipient
Dim lRequiredAttendeeCount, lOptionalAttendeeCount, lResourceCount As Long
Dim strMsg As String
Dim nPrompt As Integer
On Error Resume Next
Dim olMailItem As MailItem
Dim strAttachementName As String
Dim oRespond As Outlook.MailItem
Dim mesgBody As String
Dim oApp As Outlook.Application
Dim oCalFolder As Outlook.MAPIFolder
Dim oAppt As Outlook.AppointmentItem
Dim sOldText As String
Dim sNewText As String
Dim iCalChangedCount As Integer
Dim mail As Outlook.MailItem
Set oApp = Outlook.Application
Dim nmSpace As Outlook.NameSpace
Set nmSpace = oApp.GetNamespace("MAPI")
Set oCalFolder = nmSpace.GetDefaultFolder(olFolderCalendar)
If TypeOf Item Is MailItem Then
Set olMailItem = Item
Set objMeetingInvitation = Item
Set objMeeting = objMeetingInvitation.GetAssociatedAppointment(True)
Set objAttendees = objMeetingInvitation.Recipients
lRequiredAttendeeCount = 0
lOptionalAttendeeCount = 0
lResourceCount = 0
'Count the required & optional attendees and resources, etc.
'===============================================================================================================
' Please note...
'
' I used mailto:jakes#******.co.za?subject=Yes,%20please%20include%20me&body=I%20would%20like%20to%20join
' as a "mailto:" response
'
'===============================================================================================================
If InStr(olMailItem.Subject, "Testing the Calendar") > 0 Then
sOldText = "Test Calendar"
For Each objAttendee In objAttendees
If objAttendee.Type = olRequired Then
lRequiredAttendeeCount = lRequiredAttendeeCount + 1
ElseIf objAttendee.Type = olOptional Then
lOptionalAttendeeCount = lOptionalAttendeeCount + 1
ElseIf objAttendee.Type = olResource Then
lResourceCount = lResourceCount + 1
End If
Next
If lRequiredAttendeeCount > 1 Then
MsgBox "Attendees on list too many :" & lRequiredAttendeeCount, vbOKOnly
Exit Sub
End If
Do
If Not (oCalFolder Is Nothing) Then
If (oCalFolder.DefaultItemType = olAppointmentItem) Then Exit Do
End If
'MsgBox ("Please select a calendar folder from the following list.")
'Set oCalFolder = GetDefaultFolder(olFolderCalendar)
On Error GoTo ErrHandler:
Loop Until oCalFolder.DefaultItemType = olAppointmentItem
' Loop through appointments in calendar, change text where necessary, keep count
iCalChangedCount = 0
For Each oAppt In oCalFolder.Items
If InStr(oAppt.Subject, sOldText) <> 0 Then
Debug.Print "Changed: " & oAppt.Subject & " - " & oAppt.Start
oAppt.Recipients.Add (olMailItem.SenderEmailAddress)
'oAppt.Display
oAppt.Save
oAppt.Send
iCalChangedCount = iCalChangedCount + 1
End If
Next
' Display results and clear table
MsgBox (iCalChangedCount & " appointments have been updated. You have " & lRequiredAttendeeCount & "attendees.")
Set oAppt = Nothing
Set oCalFolder = Nothing
Exit Sub
End If
ErrHandler:
MsgBox ("Macro terminated.")
End If
Set Item = Nothing
Set olMailItem = Nothing
End Sub
I've been able to count the participants with this but i'm lost trying to combine the two...
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim objMeetingInvitation As Outlook.MeetingItem
Dim objMeeting As Outlook.AppointmentItem
Dim objAttendees As Outlook.Recipients
Dim objAttendee As Outlook.Recipient
Dim lRequiredAttendeeCount, lOptionalAttendeeCount, lResourceCount As Long
Dim strMsg As String
Dim nPrompt As Integer
If TypeOf Item Is MeetingItem Then
Set objMeetingInvitation = Item
Set objMeeting = objMeetingInvitation.GetAssociatedAppointment(True)
Set objAttendees = objMeetingInvitation.Recipients
End If
lRequiredAttendeeCount = 0
lOptionalAttendeeCount = 0
lResourceCount = 0
'Count the required & optional attendees and resources, etc.
For Each objAttendee In objAttendees
If objAttendee.Type = olRequired Then
lRequiredAttendeeCount = lRequiredAttendeeCount + 1
ElseIf objAttendee.Type = olOptional Then
lOptionalAttendeeCount = lOptionalAttendeeCount + 1
ElseIf objAttendee.Type = olResource Then
lResourceCount = lResourceCount + 1
End If
Next
'Double check the meeting invitation details
strMsg = "Meeting Details:" & vbCrLf & vbCrLf & _
"Required Attendees: " & lRequiredAttendeeCount & vbCrLf & _
"Optional Attendees: " & lOptionalAttendeeCount & vbCrLf & _
"Resources: " & lResourceCount & vbCrLf & _
"Duration: " & GetDuration(objMeeting) & vbCrLf & vbCrLf & _
"Are you sure to send this meeting invitation?"
nPrompt = MsgBox(strMsg, vbExclamation + vbYesNo, "Double Check Meeting Invitation")
If nPrompt = vbYes Then
Cancel = False
Else
Cancel = True
End If
End Sub
Any ideas at all will be appreciated!
I believe the question is too broad and could be split into at least three separate questions. Focusing on "How do I count the total participants of a meeting" without the adding and sending part.
I have to assume you run the code when a response arrives.
Option Explicit
Private Sub objNewMailItems_ItemAdd_Test()
' first open up a response to a meeting invitation
objNewMailItems_ItemAdd ActiveInspector.currentItem
End Sub
Private Sub objNewMailItems_ItemAdd(ByVal Item As Object)
Dim oAppt As AppointmentItem
Dim objAttendees As Recipients
Dim objAttendee As Recipient
Dim lRequiredAttendeeCount As Long
Dim lOptionalAttendeeCount As Long
Dim lResourceCount As Long
Dim possibleAttendees As Long
Dim limitedAtendees As Long
' For testing purposes
limitedAtendees = InputBox(Prompt:="Enter the maximum number of invitations allowed", Default:="2")
'limitedAtendees = some maximum
' Kiss of death removed
'On Error Resume Next
If TypeOf Item Is MeetingItem Then
' Bypass one error only, for a specific purpose
On Error Resume Next
Set oAppt = Item.GetAssociatedAppointment(True)
' Turn off bypass
On Error GoTo 0
If oAppt Is Nothing Then
MsgBox "No associated appointment found."
Exit Sub
End If
Set objAttendees = oAppt.Recipients
'Debug.Print objAttendees.count
lRequiredAttendeeCount = 0
lOptionalAttendeeCount = 0
lResourceCount = 0
'Count the required & optional attendees and resources, etc.
For Each objAttendee In objAttendees
'Debug.Print objAttendee
If objAttendee.Type = olRequired Then
lRequiredAttendeeCount = lRequiredAttendeeCount + 1
'ElseIf objAttendee.Type = olOptional Then
' lOptionalAttendeeCount = lOptionalAttendeeCount + 1
'ElseIf objAttendee.Type = olResource Then
' lResourceCount = lResourceCount + 1
End If
Next
If lRequiredAttendeeCount > limitedAtendees Then
MsgBox "Invitations to Required Atendees: " & lRequiredAttendeeCount & vbCr & _
"This is more than the limit of.......: " & limitedAtendees, vbOKOnly
Else
MsgBox "Invitations to Required Atendees: " & lRequiredAttendeeCount & vbCr & _
"This is within the limit of...........: " & limitedAtendees, vbOKOnly
End If
If objAttendees.count > limitedAtendees Then
MsgBox "Invitations to All Atendees..: " & objAttendees.count & vbCr & _
"This is more than the limit of: " & limitedAtendees, vbOKOnly
Else
MsgBox "Invitations to All Atendees: " & lRequiredAttendeeCount & vbCr & _
"This is within the limit of....: " & limitedAtendees, vbOKOnly
End If
End If
ExitRoutine:
Set oAppt = Nothing
End Sub
Edit 2071010
The code in the question points to a count of invitations but appears you need a count of responses.
Private Sub objNewMailItems_ItemAdd(ByVal Item As Object)
Dim objAppt As AppointmentItem
Dim objAttendee As Recipient
Dim lOrganizerAttendeeCount As Long
Dim lRequiredAttendeeCount As Long
Dim lOptionalAttendeeCount As Long
Dim lResourceCount As Long
Dim attendeeOrganizerNoneCount As Long
Dim attendeeAcceptedCount As Long
Dim attendeeTentativeCount As Long
Dim attendeeDeclinedCount As Long
Dim attendeeNotRespondedCount As Long
Dim invitedAttendees As Long
Dim respondingAttendees As Long
Dim uPrompt As String
Dim uTitle As String
Debug.Print
Debug.Print "Item.Class: " & Item.Class
' 26 - AppointmentItem
'
' Various MeetingItems
' 53 to 57
' 53 - should be the initial invitation
' 181 - Meeting Forward Notification
' - with no response (0), the invited person counts as a "None" response
If Item.Class = 26 Then
Set objAppt = Item
' tested
' olMeetingResponsePositive
' 53
' 181
ElseIf Item.Class = olMeetingResponsePositive Or _
Item.Class = olMeetingResponseTentative Or _
Item.Class = olMeetingResponseNegative Or _
Item.Class = 53 Or _
Item.Class = 54 Or _
Item.Class = 55 Or _
Item.Class = 56 Or _
Item.Class = 57 Or _
Item.Class = 181 Then
' Bypass errors for a specific purpose
On Error Resume Next
Set objAppt = Item.GetAssociatedAppointment(True)
' Turn error bypass off
On Error GoTo 0
If objAppt Is Nothing Then
MsgBox "No appointment associated with the meeting response " & _
vbCr & vbCr & Item.Subject
Exit Sub
End If
Else
MsgBox "Item class " & Item.Class & " not recognized in this code. "
Exit Sub
End If
For Each objAttendee In objAppt.Recipients
Debug.Print
Debug.Print "Invitee name...: " & objAttendee.name
'Count the invitations
Debug.Print "Invitation Type: " & objAttendee.Type
' https://msdn.microsoft.com/en-us/vba/outlook-vba/articles/olmeetingrecipienttype-enumeration-outlook
' 0 = olOrganizer
' 1 = olRequired
' 2 = olOptional
' 3 = olResource
Select Case objAttendee.Type
Case 0
lOrganizerAttendeeCount = lOrganizerAttendeeCount + 1
Case 1
lRequiredAttendeeCount = lRequiredAttendeeCount + 1
Case 2
lOptionalAttendeeCount = lOptionalAttendeeCount + 1
Case 3
lResourceCount = lResourceCount + 1
End Select
' Count the responses
Debug.Print "Response Status: " & objAttendee.MeetingResponseStatus
' https://msdn.microsoft.com/VBA/Outlook-VBA/articles/olresponsestatus-enumeration-outlook
' 0 = "None" - This is what I get as the organizer
' 1 = "Organized"
' 2 = "Tentative"
' 3 = "Accepted"
' 4 = "Declined"
' 5 = "Not Responded"
Select Case objAttendee.MeetingResponseStatus
Case 0
attendeeOrganizerNoneCount = attendeeOrganizerNoneCount + 1
Case 1
attendeeOrganizerNoneCount = attendeeOrganizerNoneCount + 1
Case 2
attendeeTentativeCount = attendeeTentativeCount + 1
Case 3
attendeeAcceptedCount = attendeeAcceptedCount + 1
Case 4
attendeeDeclinedCount = attendeeDeclinedCount + 1
Case 5
attendeeNotRespondedCount = attendeeNotRespondedCount + 1
End Select
Set objAttendee = Nothing
Next
invitedAttendees = lOrganizerAttendeeCount + lRequiredAttendeeCount + _
lOptionalAttendeeCount + lResourceCount
respondingAttendees = attendeeOrganizerNoneCount + attendeeAcceptedCount + _
attendeeTentativeCount + attendeeDeclinedCount + attendeeNotRespondedCount
' Display results
uTitle = "Attendees for " & objAppt.Subject
uPrompt = "Invitations:" & vbCr & _
" " & lOrganizerAttendeeCount & " :Organizer" & vbCr & _
" " & lRequiredAttendeeCount & " :Required" & vbCr & _
" " & lOptionalAttendeeCount & " :Optional" & vbCr & _
" " & lResourceCount & " :Resource" & vbCr & _
" " & invitedAttendees & " : TOTAL" & vbCr & vbCr
uPrompt = uPrompt & " Responses:" & vbCr & _
" " & attendeeOrganizerNoneCount & " :organizer none" & vbCr & _
" " & attendeeAcceptedCount & " :accepts" & vbCr & _
" " & attendeeTentativeCount & " :tentatives" & vbCr & _
" " & attendeeDeclinedCount & " :declines" & vbCr & _
" " & attendeeNotRespondedCount & " :no responses" & vbCr & _
" " & respondingAttendees & " : TOTAL"
MsgBox Prompt:=uPrompt, Title:=uTitle
ExitRoutine:
Set objAppt = Nothing
Set objAttendee = Nothing
End Sub
Hi Guys I'm kind of new to the macros and how to set it up.
I'm trying to run a automatic birthday macros that send an email out to people saying a happy birthday message.
but I'm struggling with when its Monday i want it to initiate a message for the weekend birthdays as well, but only on a Monday. My Code keeps saying "Run-time error '13': type mismatch". Here is my Code please help as I've been struggling a week with it
Sub send_bday_greet2()
Dim i As Long
Dim vbSunday As String, vbSaturday As String
For i = 2 To Sheets("Sheet1").Range("a1048576").End(xlUp).Row
If Day(Now()) = Day(CDate(Sheets("Sheet1").Range("c" & i).Value)) And Month(Now()) = Month(CDate(Sheets("Sheet1").Range("c" & i).Value)) Then
Call sending_bday_greetings_method2(Sheets("Sheet1").Range("a" & i).Value, Sheets("Sheet1").Range("b" & i).Value)
ElseIf Day(Now(vbMonday)) = Day(CDate(Sheets("Sheet1").Range("c" & i).Value)) And Month(Now(vbSaturday)) And Month(Now(vbSunday)) = Month(CDate(Sheets("Sheet1").Range("c" & i).Value)) Then
Call sending_bday_greetings_method2(Sheets("Sheet1").Range("a" & i).Value, Sheets("Sheet1").Range("b" & i).Value)
End If
Next
End Sub
Sub sending_bday_greetings_method2(nm As String, emid As String)
Dim olApp As Outlook.Application
Dim olMail As MailItem
Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)
s = "<p> <p align='left'><font size='3' face='arial' color='blue'><i> Dear " & nm & ", </p>" & vbNewLine
s = s & "<p> <p align='CENTER'><font size='3' face='arial' color='red'><i> We Wish you a very Happy Birthday! </p>" & vbNewLine
s = s & "<left><p align='CENTER'><img src=""http://simplyizzy.files.wordpress.com/2012/05/happy_birthday1.png"">" & vbNewLine
s = s & vbNewLine & "<left><p><p align='Left'><font size='3' face='arial' color='blue'><i>Regards<br>" & "Reutech Radar Systems</p>"
With olMail
.To = emid
.Subject = "Happy B'day!"
.HTMLBody = s
.Send
End With
Set olApp = Nothing
Set olMail = Nothing
End Sub
Your 1st issue is with Dim vbSunday As String, vbSaturday As String.
vbSaturday and vbSaturday are constants in VBA that are numbers, and you're trying to use them as String.
Furthermore, they are most probably protected so you won't be able to use their names as variable's name.
Your second issue is with Now(vbMonday) and others, you'll need to use a function like this to get the last day from the current date :
Public Function GetLastDay(ByVal DayAsVbConstant As Integer) As Date
GetLastDay = Now - (Weekday(Now, DayAsVbConstant) - 1)
End Function
Here is a revision of your code :
Sub send_bday_greet2()
Dim i As Long
Dim wS As Worksheet
Dim SendMessage As Boolean
Dim BirthDay As Date
'Set wS = ThisWorkbook.Sheets("Sheet1")
Set wS = ThisWorkbook.Sheets("Feuil1")
With wS
For i = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
SendMessage = False
BirthDay = CDate(.Range("C" & i).Value)
Select Case True
Case Day(Now()) = Day(BirthDay) And Month(Now()) = Month(BirthDay)
'Birthday this day
SendMessage = True
Case Weekday(Now) = vbMonday And ( _
Day(GetLastDay(vbSaturday)) = Day(BirthDay) And _
Month(GetLastDay(vbSaturday)) = Month(BirthDay))
'Birthday on Saturday
SendMessage = True
Case Weekday(Now) = vbMonday And ( _
Day(GetLastDay(vbSunday)) = Day(BirthDay) And _
Month(GetLastDay(vbSunday)) = Month(BirthDay))
'Birthday on Sunday
SendMessage = True
Case Else
End Select
If SendMessage Then Call sending_bday_greetings_method2(.Range("a" & i).Value, .Range("b" & i).Value)
Next i
End With 'wS
End Sub
And the part to send the mail :
Sub sending_bday_greetings_method2(ByVal nm As String, ByVal emid As String)
Dim olApp As Outlook.Application
Dim olMail As MailItem
Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)
s = "<p> <p align='left'><font size='3' face='arial' color='blue'><i> Dear " & nm & ", </p>" & vbNewLine
s = s & "<p> <p align='CENTER'><font size='3' face='arial' color='red'><i> We Wish you a very Happy Birthday! </p>" & vbNewLine
s = s & "<left><p align='CENTER'><img src=""http://simplyizzy.files.wordpress.com/2012/05/happy_birthday1.png"">" & vbNewLine
s = s & vbNewLine & "<left><p><p align='Left'><font size='3' face='arial' color='blue'><i>Regards<br>" & "Reutech Radar Systems</p>"
With olMail
.To = emid
.Subject = "Happy B'day!"
.HTMLBody = s
.Display
'.Send
End With
Set olApp = Nothing
Set olMail = Nothing
End Sub
The code below does not count categories from specific day properly:
Sub HowManyEmails()
Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim EmailCount As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
On Error Resume Next
Set objFolder = Session.GetFolderFromID(Application.ActiveExplorer.CurrentFolder.EntryID)
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 dateStr As String
Dim myItems As Outlook.Items
Dim dict As Object
Dim msg As String
Dim oDate As String
Set dict = CreateObject("Scripting.Dictionary")
oDate = InputBox("Date for count (Format D-M-YYYY")
Set myItems = objFolder.Items.Restrict("[Received] >= '" & oDate & "'")
myItems.SetColumns ("Categories")
For Each myItem In myItems
dateStr = myItem.Categories
If Not dict.Exists(dateStr) Then
dict(dateStr) = 0
End If
dict(dateStr) = CLng(dict(dateStr)) + 1
Next myItem
msg = ""
For Each o In dict.Keys
msg = msg & o & ": " & dict(o) & vbCrLf
Next
MsgBox msg
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
End Sub
When you write a date, the output is just categories and emails count which doesn't match the chosen date.
The date format, valid for someone else, is likely not valid for you.
Option Explicit
Private Sub HowManyEmails()
Dim objFolder As Folder
Dim EmailCount As Integer
Dim myItem As Object
Dim o As Variant
Dim dateStr As String
Dim myItems As items
Dim dict As Object
Dim msg As String
Dim oDate As String
On Error Resume Next
Set objFolder = ActiveExplorer.CurrentFolder
If err.number <> 0 Then
err.Clear
MsgBox "No such folder."
Exit Sub
End If
' Must closely follow an On Error Resume Next
On Error GoTo 0
EmailCount = objFolder.items.count
MsgBox "Number of emails in the folder: " & EmailCount, , "email count"
Set dict = CreateObject("Scripting.Dictionary")
' oDate = InputBox("Date for count (Format D-M-YYYY")
oDate = InputBox("Date for count (Format YYYY-m-d")
Set myItems = objFolder.items.Restrict("[Received] >= '" & oDate & "'")
' myItems.SetColumns ("Categories") ' You will find this error due to On Error GoTo 0
For Each myItem In myItems
dateStr = myItem.Categories
If Not dict.exists(dateStr) Then
dict(dateStr) = 0
End If
dict(dateStr) = CLng(dict(dateStr)) + 1
Next myItem
msg = ""
For Each o In dict.Keys
If o = "" Then
msg = msg & dict(o) & ": " & "Not categorized" & vbCrLf
Else
msg = msg & dict(o) & ": " & o & vbCrLf
End If
Next
MsgBox msg
ExitRoutine:
Set objFolder = Nothing
Set dict = Nothing
End Sub
I sent an outlook (2010) meeting request to all company (4000+) and now I would like to send an additional email to those who accepted the request or accepted tentatively.
How do I do that? When I hit Contact Atendees --> New Email to Atendees in the ribbon it just send a response to all company and not only those who accepted. I also tried to export the contacts but it can only export the name alias and not the entire email addresses.
Any suggestions?
Thanks
The basis of the solution is found here Get Meeting Attendee List Macro
Here it is with minor changes.
Option Explicit
Sub GetAttendeeList()
Dim objApp As Outlook.Application
Dim objItem As Object
Dim objAttendees As Outlook.Recipients
Dim objAttendeeReq As String
Dim objAttendeeOpt As String
Dim objOrganizer As String
Dim dtStart As Date
Dim dtEnd As Date
Dim strSubject As String
Dim strLocation As String
Dim strNotes As String
Dim strMeetStatus As String
Dim strCopyData As String
Dim strCount As String
Dim ino, it, ia, ide
Dim x As Long
Dim ListAttendees As mailitem
'On Error Resume Next
Set objApp = CreateObject("Outlook.Application")
Set objItem = GetCurrentItem()
Set objAttendees = objItem.Recipients
On Error GoTo EndClean:
' Is it an appointment
If objItem.Class <> 26 Then
MsgBox "This code only works with meetings."
GoTo EndClean:
End If
' Get the data
dtStart = objItem.Start
dtEnd = objItem.End
strSubject = objItem.Subject
strLocation = objItem.location
strNotes = objItem.body
objOrganizer = objItem.Organizer
objAttendeeReq = ""
objAttendeeOpt = ""
Set ListAttendees = Application.CreateItem(olMailItem) ' <---
' Get The Attendee List
For x = 1 To objAttendees.count
strMeetStatus = ""
Select Case objAttendees(x).MeetingResponseStatus
Case 0
strMeetStatus = "No Response (or Organizer)"
ino = ino + 1
Case 1
strMeetStatus = "Organizer"
ino = ino + 1
Case 2
strMeetStatus = "Tentative"
it = it + 1
ListAttendees.Recipients.Add objAttendees(x) ' <---
Case 3
strMeetStatus = "Accepted"
ia = ia + 1
ListAttendees.Recipients.Add objAttendees(x) ' <---
Case 4
strMeetStatus = "Declined"
ide = ide + 1
End Select
If objAttendees(x).Type = olRequired Then
objAttendeeReq = objAttendeeReq & objAttendees(x).Name & vbTab & strMeetStatus & vbCrLf
Else
objAttendeeOpt = objAttendeeOpt & objAttendees(x).Name & vbTab & strMeetStatus & vbCrLf
End If
Next
strCopyData = "Organizer: " & objOrganizer & vbCrLf & "Subject: " & strSubject & vbCrLf & _
"Location: " & strLocation & vbCrLf & "Start: " & dtStart & vbCrLf & "End: " & dtEnd & _
vbCrLf & vbCrLf & "Required: " & vbCrLf & objAttendeeReq & vbCrLf & "Optional: " & _
vbCrLf & objAttendeeOpt & vbCrLf & "NOTES " & vbCrLf & strNotes
strCount = "Accepted: " & ia & vbCrLf & _
"Declined: " & ide & vbCrLf & _
"Tentative: " & it & vbCrLf & _
"No response: " & ino
'Set ListAttendees = Application.CreateItem(olMailItem)
ListAttendees.body = strCopyData & vbCrLf & strCount
ListAttendees.Display
ListAttendees.Recipients.ResolveAll ' <---
EndClean:
Set objApp = Nothing
Set objItem = Nothing
Set objAttendees = Nothing
End Sub
Building upon what #niton wrote, I've added support for checking against the Global Address List. This code could be extended to search all address lists available to you by iterating through myAddressLists, however, in most cases, that will probably be more than wanted.
Note that this isn't optimized for speed, but even a list with a few hundred people invited against a GAL of tens of thousands won't take a computer very long to iterate through. Since this doesn't get run very often, the time saved for optimizing this just didn't seem worth it.
Option Explicit
Sub GetAttendeeList()
Dim x As Integer
Dim y As Integer
Dim ino As Integer
Dim it As Integer
Dim ia As Integer
Dim ide As Integer
Dim objApp As Outlook.Application
Dim objItem As Object
Dim objAttendees As Outlook.Recipients
Dim objAttendeeReq As String
Dim objAttendeeOpt As String
Dim strAttendeeName As String
Dim strAttendeeEmail As String
Dim objOrganizer As String
Dim dtStart As Date
Dim dtEnd As Date
Dim strSubject As String
Dim strLocation As String
Dim strNotes As String
Dim strMeetStatus As String
Dim strCopyData As String
Dim strCount As String
Dim strCity As String
Dim folContacts As Outlook.MAPIFolder
Dim oContact As Outlook.ContactItem
Dim colItems As Outlook.Items
Dim oNS As Outlook.NameSpace
Dim ListAttendees As MailItem
Dim strNewRecord As String
Dim myAddressLists As AddressLists
Dim myAddressEntries As AddressEntries
Dim myAddressEntry As AddressEntry
Dim myExchangeUser As ExchangeUser
Dim myExchangeDL As ExchangeDistributionList
Dim myContactItem As ContactItem
On Error Resume Next
Set objApp = CreateObject("Outlook.Application")
Set oNS = Application.GetNamespace("MAPI")
Set folContacts = oNS.GetDefaultFolder(olFolderContacts)
Set colItems = folContacts.Items
Set myAddressLists = oNS.AddressLists
Set myAddressEntries = myAddressLists.Item("Global Address List").AddressEntries
Set objItem = GetCurrentItem()
Set objAttendees = objItem.Recipients
On Error GoTo EndClean:
' Is it an appointment
If objItem.Class <> 26 Then
MsgBox "This code only works with meetings."
GoTo EndClean:
End If
' Get the data
dtStart = objItem.Start
dtEnd = objItem.End
strSubject = objItem.Subject
strLocation = objItem.Location
strNotes = objItem.Body
objOrganizer = objItem.Organizer
objAttendeeReq = ""
objAttendeeOpt = ""
' Get The Attendee List
For x = 1 To objAttendees.Count
strMeetStatus = ""
Select Case objAttendees(x).MeetingResponseStatus
Case 0
strMeetStatus = "No Response (or Organizer)"
ino = ino + 1
Case 1
strMeetStatus = "Organizer"
ino = ino + 1
Case 2
strMeetStatus = "Tentative"
it = it + 1
Case 3
strMeetStatus = "Accepted"
ia = ia + 1
Case 4
strMeetStatus = "Declined"
ide = ide + 1
End Select
strAttendeeName = objAttendees(x).Name
strAttendeeEmail = objAttendees(x).Address
Set oContact = colItems.Find("[Email1Address] = '" & strAttendeeEmail & "'")
If Not oContact Is Nothing Then
Debug.Print "Test", oContact.BusinessAddressCity
strCity = oContact.MailingAddressCity & ", " & oContact.MailingAddressState
End If
If InStr(strAttendeeEmail, "#") = 0 Then
Debug.Print "Searching: " & objAttendees(x).Name
Set myAddressEntry = myAddressEntries.GetFirst()
Do While Not myAddressEntry Is Nothing
If myAddressEntry.Address Like objAttendees(x).Address Then
Debug.Print "Found: " & myAddressEntry.Name
Set myExchangeUser = myAddressEntry.GetExchangeUser()
Set myExchangeDL = myAddressEntry.GetExchangeDistributionList()
Set myContactItem = myAddressEntry.GetContact()
If Not myExchangeUser Is Nothing Then
strAttendeeEmail = myExchangeUser.PrimarySmtpAddress
End If
If Not myExchangeDL Is Nothing Then
strAttendeeEmail = myExchangeDL.PrimarySmtpAddress
End If
If Not myContactItem Is Nothing Then
strAttendeeEmail = myContactItem.Email1Address
End If
GoTo ContactFound
End If
Set myAddressEntry = myAddressEntries.GetNext()
Loop
End If
ContactFound:
strNewRecord = objAttendees(x).Name & vbTab & strAttendeeEmail & vbTab & strMeetStatus & vbTab & strCity & vbCrLf
If objAttendees(x).Type = olRequired Then
objAttendeeReq = objAttendeeReq & strNewRecord
Else
objAttendeeOpt = objAttendeeOpt & strNewRecord
End If
Next
strCopyData = "Organizer: " & objOrganizer & vbCrLf & "Subject: " & strSubject & vbCrLf & _
"Location: " & strLocation & vbCrLf & "Start: " & dtStart & vbCrLf & "End: " & dtEnd & _
vbCrLf & vbCrLf & "Required: " & vbCrLf & objAttendeeReq & vbCrLf & "Optional: " & _
vbCrLf & objAttendeeOpt & vbCrLf & "NOTES " & vbCrLf & strNotes
strCount = "Accepted: " & ia & vbCrLf & _
"Declined: " & ide & vbCrLf & _
"Tentative: " & it & vbCrLf & _
"No response: " & ino
Set ListAttendees = Application.CreateItem(olMailItem)
ListAttendees.Body = strCopyData & vbCrLf & strCount & vbCrLf & Time
ListAttendees.Display
EndClean:
Set objApp = Nothing
Set objItem = Nothing
Set objAttendees = Nothing
End Sub
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
Set objApp = Nothing
End Function