marcusmark
Board Regular
- Joined
- Nov 17, 2014
- Messages
- 98
Hi,
I'm stuck in my codes.
I copied a code from a site by Ron De Bruin related to mail range/selection in Outlook body. My problem is that it is only for one sample range/selection.
I need for 2 selections and I tried to edit the code but I always got an error as "ByRef Argument Type Mismatch".
Can you help me with this? Here's the code:
I'm stuck in my codes.
I copied a code from a site by Ron De Bruin related to mail range/selection in Outlook body. My problem is that it is only for one sample range/selection.
I need for 2 selections and I tried to edit the code but I always got an error as "ByRef Argument Type Mismatch".
Can you help me with this? Here's the code:
Code:
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-2013
Dim rng, cell As Range
Dim OutApp As Object
Dim OutMail As Object
Dim POSTN, WKDAY, LASTPIVOT As Integer
Dim CURNT, PRVDATE As Variant
CURNT = Date
WKDAY = Weekday(CURNT)
If WKDAY = 2 Then
PRVDATE = CURNT - 3
Else
PRVDATE = CURNT - 1
End If
Columns("AC:AH").Select
Selection.Find(What:="Grand", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
POSTN = ActiveCell.Column
LASTPIVOT = Cells(Rows.Count, POSTN).End(xlUp).Row
Range(Cells(LASTPIVOT, POSTN), Cells(1, 28)).Select
'This code will set below as its mail body
strbody = "Hi Team," & _
"<br><br>Please see below the status of Parked Items as of " & PRVDATE & ".<br>"
strbody2 = "<br><br>Kindly see the attached file for today's (" & CURNT & ") Parked Items. Thanks!<br>"
strbody3 = "<br><br>Kindly prioritize those invoices which are already overdue<br>"
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = Range(Cells(LASTPIVOT, POSTN), Cells(1, 28)).Select.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
'Set rng = Sheets("YourSheet").Range("D4:D12").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
Columns("AK:AO").Select
Selection.Find(What:="Grand", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
POSTN = ActiveCell.Column
LASTPIVOT = Cells(Rows.Count, POSTN).End(xlUp).Row
Range(Cells(LASTPIVOT, POSTN), Cells(1, 36)).Select
Set cell = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set cell = Range(Cells(LASTPIVOT, POSTN), Cells(1, 36)).Select.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If cell 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)
OutMail.Display
On Error Resume Next
With OutMail
.To = "magmo@vestas.com"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.HTMLBody = strbody & RangetoHTML(rng) & strbody2 & RangetoHTML2(cell) & strbody3
.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
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Function RangetoHTML2(cell As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
cell.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML2
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML2 = ts.readall
ts.Close
RangetoHTML2 = Replace(RangetoHTML2, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function