T
tcooper007
Hey guys.
First time posting here e and I am glad to see that Ron de Bruin post
here, because my question is in regards to his script
I have been trying to use the script that would email each row to
different person in the range… the link i
http://www.rondebruin.nl/mail/folder3/row.htm
I have tried, but the Outlook creates the email but does not post th
text in the body of the email. Truly, I am not sure why… as I am no
good with VBA.
When the instruction states that I need to post the script in norma
module, that means that I just need to open VBA and post it, right?
I have created a button to trigger the script, so this is what I have.
Any help would be appreciate, as I think the functionality of thi
script is tremendous.
Private Sub CommandButton1_Click()
' You must add a reference to the Microsoft outlook Library
' Don't forget to copy the function RangetoHTML2 in the module.
' Is not working in Office 97
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim cell As Range
Dim rng As Range
Dim Ash As Worksheet
Dim Nsh As Worksheet
Set Ash = ActiveSheet
Set Nsh = Worksheets.Add
On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
Application.ScreenUpdating = False
For Each cell I
Ash.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And LCase(cell.Offset(0
1).Value) = "yes" Then
Ash.Range("A1:J100").AutoFilter Field:=2
Criteria1:=cell.Value
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
rng.Copy
With Nsh
.Cells(1).PasteSpecial Paste:=8
' Paste:=8 will copy the column width in Excel 2000 an
higher
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
Application.CutCopyMode = False
End With
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.To = cell.Value
.Subject = "Grades Aug"
.HTMLBody = RangetoHTML2
.Send 'Or use Display
End With
Set OutMail = Nothing
Nsh.Cells.Clear
Ash.AutoFilterMode = False
End If
Next cell
cleanup:
Application.DisplayAlerts = False
Nsh.Delete
Application.DisplayAlerts = True
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Public Function RangetoHTML2()
' You can't use this function in Excel 97
Dim fso As Object
Dim ts As Object
Dim TempFile As String
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss"
& ".htm"
With ActiveWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=ActiveSheet.Name, _
Source:=ActiveSheet.UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML2 = ts.ReadAll
ts.Close
Set ts = Nothing
Set fso = Nothing
Kill TempFile
End Functio
First time posting here e and I am glad to see that Ron de Bruin post
here, because my question is in regards to his script
I have been trying to use the script that would email each row to
different person in the range… the link i
http://www.rondebruin.nl/mail/folder3/row.htm
I have tried, but the Outlook creates the email but does not post th
text in the body of the email. Truly, I am not sure why… as I am no
good with VBA.
When the instruction states that I need to post the script in norma
module, that means that I just need to open VBA and post it, right?
I have created a button to trigger the script, so this is what I have.
Any help would be appreciate, as I think the functionality of thi
script is tremendous.
Private Sub CommandButton1_Click()
' You must add a reference to the Microsoft outlook Library
' Don't forget to copy the function RangetoHTML2 in the module.
' Is not working in Office 97
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim cell As Range
Dim rng As Range
Dim Ash As Worksheet
Dim Nsh As Worksheet
Set Ash = ActiveSheet
Set Nsh = Worksheets.Add
On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
Application.ScreenUpdating = False
For Each cell I
Ash.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And LCase(cell.Offset(0
1).Value) = "yes" Then
Ash.Range("A1:J100").AutoFilter Field:=2
Criteria1:=cell.Value
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
rng.Copy
With Nsh
.Cells(1).PasteSpecial Paste:=8
' Paste:=8 will copy the column width in Excel 2000 an
higher
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
Application.CutCopyMode = False
End With
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.To = cell.Value
.Subject = "Grades Aug"
.HTMLBody = RangetoHTML2
.Send 'Or use Display
End With
Set OutMail = Nothing
Nsh.Cells.Clear
Ash.AutoFilterMode = False
End If
Next cell
cleanup:
Application.DisplayAlerts = False
Nsh.Delete
Application.DisplayAlerts = True
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Public Function RangetoHTML2()
' You can't use this function in Excel 97
Dim fso As Object
Dim ts As Object
Dim TempFile As String
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss"
& ".htm"
With ActiveWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=ActiveSheet.Name, _
Source:=ActiveSheet.UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML2 = ts.ReadAll
ts.Close
Set ts = Nothing
Set fso = Nothing
Kill TempFile
End Functio