I am trying to create a task in Outlook with reminder via Excel.
My code gives
Run-time error '438': Object doesn't support this property or method
on line
.StartDate = CDate(DelDate)
How do I set date of task from cell value?
Sub RectangleRoundedCorners1_Click()
Dim OutApp As Object
Dim OutTask As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutTask = OutApp.CreateItem(olTaskItem)
Dim ws As Worksheet
Dim Ads As String
Dim Subj As String
Dim Body As String
Dim DelDate As Date
Set ws = ActiveSheet
Ads = ws.Cells(4, 2).Value
Subj = ws.Cells(7, 2).Value
Body = ws.Cells(4, 9).Value
DelDate = ws.Cells(10, 6).Value
DelHour = ws.Cells(12, 6).Value
Dim myRecipient As Object
Set myRecipient = OutTask.Recipients.Add(Cells(4, 2))
myRecipient.Resolve
If myRecipient.Resolved Then
With OutTask
.Subject = Subj
.StartDate = CDate(DelDate)
.DueDate = CDate(DelDate)
.ReminderTime = CDate(DelDate)
.Body = Body
.Assign
.Display
End With
End If
Set OutTask = Nothing
Set OutApp = Nothing
End Sub
Related
I have developed a template with which I can automate invoice reminders by outputting emails. Currently the code loops through the list outputting an email for each individual row (= each individual invoice). I would like to update the code so that it skips outfiltered rows in the excel doc to make it more efficient and easier in use.
My code is as follows:
Sub Send_email_fromtemplate()
Dim edress As String
Dim cc1, cc2, cc3 As String
Dim group As String
Dim number As String
Dim outlookapp As Object
Dim outlookmailitem As Object
Dim r As Long
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
r = 3
Do While Sheet1.Cells(r, 1) <> ""
Set outlookapp = CreateObject("Outlook.Application")
'call your template
Set outlookmailitem = outlookapp.CreateItemFromTemplate([location])
outlookmailitem.Display
edress = Sheet1.Cells(r, 7)
cc1 = Sheet1.Cells(r, 8)
cc2 = Sheet1.Cells(r, 9)
cc3 = Sheet1.Cells(r, 10)
group = Sheet1.Cells(r, 4)
number = Sheet1.Cells(r, 3).Value
With outlookmailitem
.To = edress
.cc = cc1 & ";" & cc2 & ";" & cc3
.bcc = ""
.Subject = "First invoice reminder " & group
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
With oRng.Find
Do While .Execute(FindText:="{{Number}}")
oRng.Text = number
Exit Do
Loop
End With
Set xInspect = outlookmailitem.GetInspector
.Display
'.send
End With
'clear your email address
edress = ""
r = r + 1
Loop
'clear your fields
Set outlookapp = Nothing
Set outlookmailitem = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
End Sub
I've tried to solve the problem using a Range function and ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible), but as the template will be filled with a variable number of rows (each time I send reminders) this is causing troubles, as the range differs each time.
Please, try the next updated code. As I said in my above comment, it is able to calculate the last row on A:A, then create a range from visible rows of the filtered area and iterate between its rows:
Sub Send_email_fromtemplate()
Dim edress As String, cc1 As String, cc2 As String, cc3 As String
Dim group As String, number As String
Dim outlookapp As Object, outlookmailitem As Object, olInsp As Object
Dim wdDoc As Object, xInspect As Object
Dim oRng As Object, lastR As Long, rngVis As Range, r As Range
lastR = Sheet1.Range("A" & Sheet1.rows.count).End(xlUp).row 'last row on A:A
On Error Resume Next 'this is necessary in case of no any filtered visible cell
Set rngVis = Sheet1.Range("A3:J" & lastR).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rngVis Is Nothing Then MsgBox "No visible filtered values in the necessary range...": Exit Sub
Set outlookapp = CreateObject("Outlook.Application") 'you should set it only ones, outside of the iteration...
For Each r In rngVis.rows 'iterate between the discontinuous (visible cells) rows
'call your template
Set outlookmailitem = outlookapp.CreateItemFromTemplate([Location])
outlookmailitem.Display
edress = r.cells(1, 7) 'extract the necessary values from the iterated row
cc1 = r.cells(1, 8)
cc2 = r.cells(1, 9)
cc3 = r.cells(1, 10)
group = r.cells(1, 4)
number = r.cells(1, 3).Value
With outlookmailitem
.To = edress
.cc = cc1 & ";" & cc2 & ";" & cc3
.BCC = ""
.Subject = "First invoice reminder " & group
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
With oRng.Find
Do While .Execute(FindText:="{{Number}}")
oRng.Text = number
Exit Do
Loop
End With
Set xInspect = outlookmailitem.GetInspector
.Display
'.send
End With
'clear your email address
edress = ""
Next r
'clear memory of used objects:
Set outlookapp = Nothing: Set outlookmailitem = Nothing
Set wdDoc = Nothing: Set oRng = Nothing
End Sub
Please, send some feedback after testing it.
I'd like to create an Outlook calendar meeting request each time a workbook is saved.
The meeting requests need to be added to a shared mailbox so that all users that have access see the meeting invite.
So far it adds an entry to my personal calendar.
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("2021") 'define your sheet!
Dim olApp As Object 'create outlook application
Set olApp = CreateObject("Outlook.Application")
Dim olNS As Object 'get namespace
Set olNS = olApp.GetNamespace("MAPI")
'define constants if using late binding
Const olFolderCalendar As Long = 9
Const olAppointmentItem As Long = 1
Dim olRecItems As Object 'get all appointments
Set olRecItems = olNS.GetDefaultFolder(olFolderCalendar)
Dim strFilter As String 'filter for appointments
Dim olFilterRecItems As Object 'filtered appointments
Dim iRow As Long
iRow = 3
Do Until Trim$(ws.Cells(iRow, 3).Value) = vbNullString
'filter appointments for subject
strFilter = "[Subject] = '" & Trim$(ws.Cells(iRow, 4).Value) & "'"
Set olFilterRecItems = olRecItems.Items.Restrict(strFilter)
If olFilterRecItems.Count = 0 Then 'if subject does not exist
With olApp.CreateItem(olAppointmentItem)
.Subject = ws.Cells(iRow, 4).Value
.Start = ws.Cells(iRow, 3).Value
.AllDayEvent = True
.BusyStatus = 5
.ReminderSet = True
.Save
End With
ws.Cells(iRow, 3).Interior.ColorIndex = 50
End If
iRow = iRow + 1
Loop
End Sub
Update:
I managed to get this. The problem now is that it'll only create the calendar entry for the last line.
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("2020") 'define your sheet!
Dim olApp As Object 'create outlook application
Set olApp = CreateObject("Outlook.Application")
Dim olNS As Object 'get namespace
Set olNS = olApp.GetNamespace("MAPI")
Dim olAppItem As Outlook.AppointmentItem
Dim myRequiredAttendee As Outlook.Recipient
'define constants if using late binding
Const olFolderCalendar As Long = 9
Const olAppointmentItem As Long = 1
Dim olRecItems As Object 'get all appointments
Set olRecItems = olNS.GetDefaultFolder(olFolderCalendar)
Set olAppItem = olRecItems.Items.Add(olAppointmentItem)
Dim strFilter As String 'filter for appointments
Dim olFilterRecItems As Object 'filtered appointments
Dim iRow As Long
iRow = 3
Do Until Trim$(ws.Cells(iRow, 3).Value) = vbNullString
'filter appointments for subject
strFilter = "[Subject] = '" & Trim$(ws.Cells(iRow, 4).Value) & "'"
Set olFilterRecItems = olRecItems.Items.Restrict(strFilter)
If olFilterRecItems.Count = 0 Then 'if subject does not exist
With olAppItem
Set myRequiredAttendee = .Recipients.Add("email address")
myRequiredAttendee.Type = olRequired
.MeetingStatus = olMeeting
.ReminderMinutesBeforeStart = 30
.Subject = ws.Cells(iRow, 4).Value
.Start = ws.Cells(iRow, 3).Value
.AllDayEvent = True
.BusyStatus = 5
.ReminderSet = True
.Send
End With
ws.Cells(iRow, 3).Interior.ColorIndex = 50
End If
iRow = iRow + 1
Loop
End Sub
Instead of the following code:
Dim olRecItems As Object 'get all appointments
Set olRecItems = olNS.GetDefaultFolder(olFolderCalendar)
You need to use the NameSpace.GetSharedDefaultFolder method which returns a Folder object that represents the specified default folder for the specified user. This method is used in a delegation scenario, where one user has delegated access to another user for one or more of their default folders (for example, their shared Calendar folder). For example:
Sub ResolveName()
Dim myNamespace As Outlook.NameSpace
Dim myRecipient As Outlook.Recipient
Dim CalendarFolder As Outlook.Folder
Set myNamespace = Application.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("Eugene Astafiev")
myRecipient.Resolve
If myRecipient.Resolved Then
Call ShowCalendar(myNamespace, myRecipient)
End If
End Sub
Sub ShowCalendar(myNamespace, myRecipient)
Dim CalendarFolder As Outlook.Folder
Set CalendarFolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
CalendarFolder.Display
End Sub
In this email sender how do I replace the text "employee_name" and "voucher_no" with the value in a cell.
Trying to send personalized email with an individual voucher for each email address.
Sub bulk_emails()
Dim ol As Outlook.Application
Dim olm As Outlook.MailItem
Dim inspect As Outlook.Inspector
Dim wd As Word.Document
Set ol = New Outlook.Application
For r = 2 To Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
Sheet2.Range("C7:R26").Copy
Set olm = ol.CreateItem(olMailItem)
With olm
'Display
.To = Sheet1.Cells(r, 3).Value
.Subject = Sheet2.Range("C6").Value
.Body = Sheet1.Cells(r, 2).Value
.BodyFormat = olFormatHTML
.Display
Set inspect = olm.GetInspector
Set wd = inspect.WordEditor
wd.Content.Paste
.HTMLBody = Replace(.HTMLBody, "employee_name", Sheet1, Cells(r, 1), Value)
.HTMLBody = Replace(.HTMLBody, "voucher.no", Sheet1, Cells(r, 2), Value)
End With
Next
Set olm = Nothing
Set ol = Nothing
Set wd = Nothing
End Sub
I am attempting to loop through a column (n=96) in my worksheet, when it comes across a value <10 I would like the macro to open outlook and email offset values (four columns across) from the values it found.
I've generated a working example though it seems to be limited to only one example I've tested. I think I am approaching it from the wrong angle.
Sub SendReminderMail()
Dim p As Long
Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim iCounter As Integer
Dim MailDest As String
'If MsgBox("Are you sure?", vbYesNo) = vbNo Then Exit Sub
Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.CreateItem(0)
p = 2
Do Until Trim$(Cells(p, 1).Value) = ""
If Cells(p, 1).Value <= 10 Then
Set OutLookMailItem = OutLookApp.CreateItem(0)
With OutLookMailItem
.To = "Emailaddress etc"
.Subject = "Reminder: " & Cells(1, 7).Value
.Body = Cells(p, 1).Offset(0, 4).Value
.Display
End With
End If
p = p + 1
Loop
End Sub
How do I set it up to loop through all the <10 values and tell it to paste the offset values into the body of the email?
I think that you need to split this into two blocks of code.
First block would iterate through rows, check criteria and, if needed, call the second one, so the mail sending Sub, passing by necessary parameters.
Someting similar to the below code:
Sub SendReminderMail(ByVal MailSubject As String, mailBody As String)
Dim p As Long
Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim iCounter As Integer
Dim MailDest As String
'If MsgBox("Are you sure?", vbYesNo) = vbNo Then Exit Sub
Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.CreateItem(0)
Set OutLookMailItem = OutLookApp.CreateItem(0)
With OutLookMailItem
.To = "Emailaddress etc"
.Subject = MailSubject
.Body = mailBody
.Display
End With
End Sub
Sub IterateThroughRows()
Dim p As Integer
Dim Sht As Worksheet
Dim MailSubject As String
Dim mailBody As String
Set Sht = ThisWorkbook.Sheets("SheetName")
p = 2
Do Until Sht.Cells(p, 1).Value = ""
If Cells(p, 1).Value <= 10 Then
mailBody = mailBody + " | " + Sht.Cells(p, 1).Offset(0, 4).Value
End If
p = p + 1
Loop
Call SendReminderMail(MailSubject, mailBody)
MailSubject = "Reminder: " & Sht.Cells(1, 7).Value
End Sub
I have a folder with 50 files and I have a list of 50 email addresses. Each file goes to a different email address. Is there a way to write a macro that performs this task?
The problem with the set of code below is two-fold:
1) I have 3 COLUMNS of data in an Excel file: One for subject, one for email address to send to, and the third for the FILE PATH of where the attachment to be attached is stored.
The code below does not allow for a pre-determined set of subject arguments. It also uses ROWS?? for the filepath field instead of a column like it does for send to? So confusing.
Sub Send_Files()
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Here is quick example, assuming col A = Email, Col B = Subject & Col C = Path
Option Explicit
Public Sub Example()
Dim olApp As Object
Dim olMail As Object
Dim olRecip As Object
Dim olAtmt As Object
Dim iRow As Long
Dim Recip As String
Dim Subject As String
Dim Atmt As String
iRow = 2
Set olApp = CreateObject("Outlook.Application")
Dim Sht As Worksheet
Set Sht = ThisWorkbook.Worksheets("Sheet1")
Do Until IsEmpty(Sht.Cells(iRow, 1))
Recip = Sht.Cells(iRow, 1).Value
Subject = Sht.Cells(iRow, 2).Value
Atmt = Sht.Cells(iRow, 3).Value ' Attachment Path
Set olMail = olApp.CreateItem(0)
With olMail
Set olRecip = .Recipients.Add(Recip)
.Subject = Subject
.Body = "Hi "
.Display
Set olAtmt = .Attachments.Add(Atmt)
olRecip.Resolve
End With
iRow = iRow + 1
Loop
Set olApp = Nothing
End Sub