I have been trying to add a button where it pastes the content of a certain range into an Outlook email. By doing so, I'm using the following code:
Private Sub CommandButton4_Click()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Range("P25:P32,Q25:Q32,R25:R32,S25:S32,T25:T32").Select
Set rng = Nothing
On Error Resume Next
Set rng = Selection.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected"
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Range("F22").Value
.CC = ""
.BCC = ""
.Subject = Range("F23").Value
.HTMLBody = RangetoHTML(rng)
If Toggle_3.Value = True Then
.Display
ElseIf Toggle_4.Value = True Then
.Send
End If
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
Call SaveFile
End Sub
At line 7 of the code I used to have "P25:T32", but I changed it to that because I thought that might've been what caused the error.
When clicking the button, it gives me the error message:
Sub or function is not defined
and it highlights the .HTMLBody = RangetoHTML(rng) line.
What am I doing wrong?
I was missing the Function RangetoHTML(rng As Range) as Axel Richter commented.
Related
The following code allows me to select a range of cells using in a range of a excel sheet and send that as an email. However, pictures or images withing the range are not selected. How do i do that
Sub Mail_Selection_Range_Outlook_Body()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
'Set rng = Nothing
' On Error Resume Next
'Only the visible cells in the selection
'Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
Set rng = Sheets("Sheet1").Range("B8:M108").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Worksheets("Email").Range("A10").Value
.CC = Worksheets("Email").Range("B10").Value
.BCC = ""
.Subject = "This is the Subject line"
.HTMLBody = RangetoHTML(rng)
.Send 'or use .Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I am working on an Excel workbook to track appointments and to send an email to advise of the appointment.
I put together code to open an email in Outlook with inputs pulled from the Excel sheet.
Sub ButtonREMINDER41_Click()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
On Error Resume Next
' Only send the visible cells in the selection.
Set rng = Selection.SpecialCells(xlCellTypeVisible)
Set rng =
Sheets("Sheet1").RangeToHtml("D4:D12").SpecialCells(xlCellTypeVisible, xlTextValues)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected. " & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
`Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Range("$F$41")
.CC = Range("$B$41")
.BCC = ""
.Subject = "Upcoming Scheduled Appointment"
.HTMLBody = Range("$N$41")
' In place of the following statement, you can use ".Display" to
' display the e-mail message.
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
I am trying to also book an appointment in the receiver's calendar.
I would like an email generated with a meeting attachment for the appointment.
Mail is sent when the value in a cell of a specific row changes.
In addition we now want to send an Outlook task whenever that happens. The following first part is the email.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim OutApp As Object, OutMail As Object, strbody As String
If Target.Column = 44 Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "Text "
On Error Resume Next
With OutMail
.To = Sheets("Param").Cells(3, 4)
.CC = ""
.BCC = ""
.Subject = "Text"
.Body = strbody
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Exit Sub
End If
End Sub
Until here the code works. I've added the part about the task and although the code works without the IF THEN statement I can't get it to trigger with it or I get a 424 error.
Private Sub SendTask()
Dim objOut As Outlook.Application
Dim objTask As Outlook.TaskItem
Dim blnCrt As Boolean
If Target.Column = 6 Then 'modification numéro agrément
On Error GoTo CreateOutlook
Set objOut = GetObject(, "Outlook.Application")
CreateItem:
On Error GoTo 0
Set objTask = objOut.CreateItem(olTaskItem)
With objTask
.Assign
.Subject = "You need to fix this!"
.Body = "Please fix this problem by " & Format(Now + 10, "mm/dd/yy")
.DueDate = CDate(Now + 10)
.Recipients.Add ("youremail#domain.com")
.Display
End With
If blnCrt = True Then objOut.Quit
Set objTask = Nothing
Set objOut = Nothing
Exit Sub
CreateOutlook:
Set objOut = CreateObject("Outlook.Application")
blnCrt = True
Resume CreateItem
End If
End Sub
New version of the code that seems to work as intended
Private Sub Worksheet_Change(ByVal target As Range)
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
If target.Column = 6 Then 'Modification of value in row 6
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olTaskItem)
With OutMail
.Assign
.Subject = "You need to fix this!"
.Body = "Please fix this problem by " & Format(Now + 10, "mm/dd/yy")
.DueDate = CDate(Now + 10)
.Recipients.Add ("youremail#domain.com")
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "Den numèro d'agrément "
With OutMail
.To = Sheets("Param").Cells(3, 4)
.CC = ""
.BCC = ""
.Subject = "Fichier acquéreur: modification numéro agrément"
.Body = strbody
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
Exit Sub
End If
End Sub
I have found the following Macro and used it to my needs to copy range and create an email, I have copied the same code into several sheets, couple of things change in each code the range, email addresses & subject. How can I stack all these macros into one:
Sub Macro_Qu()
'
' Macro_Qu Macro
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2010
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set rng = Nothing
On Error Resume Next
Set rng = Sheets("Qusai").Range("A2:J20").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "Qu#msn.com"
.CC = ""
.BCC = ""
.Subject = "Test"
.HTMLBody = RangetoHTML(rng)
.Display 'or use .Send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Just pass the values that change as parameters:
Sub Test
Macro_Qu Sheets("Qusai").Range("A2:J20"), "Qu#msn.com", "Test"
End Sub
Sub Macro_Qu(parmRng As Range, parmTo As String, parmSubject As String)
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set rng = Nothing
On Error Resume Next
Set rng = parmRng.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = parmTo
.CC = ""
.BCC = ""
.Subject = parmSubject
.HTMLBody = RangetoHTML(rng)
.Display 'or use .Send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
You can use this to call other macros from inside another macro:
call <macro name>
However, if you're starting to get this complex it might be time to learn VBA :)
I have code to take a copy of a select worksheet but am haveing difficulties directing which draft folder in outlook to send the draft email to. The name of the folder I want to send the draft email to is "Draft NDIC". Here is the code:
Sub Mail_Body_NDIC()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set rng = Nothing
Set rng = Sheets("NDIC Renewals").UsedRange
'You can also use a sheet name
'Set rng = Sheets("YourSheet").UsedRange
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "dvandervieren#enerplus.com"
.CC = ""
.BCC = ""
.Subject = "NDIC Renewals for the Next 90 Days"
.Body = ""
.HTMLBody = RangetoHTML(rng)
.Save 'or use .Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
"You need to use the .Move method, with the olDestFolder as the argument." David Van der Vieren
http://blog.saieva.com/2010/03/27/move-messages-to-folders-with-outlook-vba/