I am trying to wite a macro that will allow us to create ad-hoc reports from data in excel. This macro will create an email for every unique code in column A. I then create the body of the email by pulling the info from a word file then adding the excel data.
The excel data is in HTML and looks great. The problem is that I cannot get any formatting for the word doc. Is there anyway of getting it to convert the word into HTML?
This is what it looks like (BTW - The formating for the excel part is fine) It's just the part that comes from word) I also attached my word doc and my excel data
This is a test Good Job So Long
Bob Johnson
CarrierPar
Carrier PctAward Freq EffDate AAWV TempPro
DestCity DestSt ######## ######## ######## ######## 1/0/1900 1/0/1900 1/0/1900 1/0/1900
BBBBB CRCR 1 WEEK ######## 4.9 N/A MIDWAY TN 2.00 0.0 2.0 0.0 0 0 0 0
This is what I want it to look like
This is a test
1. Good Job
2. So Long
Bob Johnson
CarrierPar
Carrier PctAward Freq EffDate AAWV TempPro
DestCity DestSt ######## ######## ######## ######## 1/0/1900 1/0/1900 1/0/1900 1/0/1900
BBBBB CRCR 1 WEEK ######## 4.9 N/A MIDWAY TN 2.00 0.0 2.0 0.0 0 0 0 0
Option Explicit
Public Sub Email_Report()
'Working in 97-2010
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim mailAddress As String
Dim NewWB As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim I As Long
Dim newRng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim userName As String
Dim OL As Object, MailSendItem As Object
Dim W As Object
Dim MsgTxt As String, SendFile As String
Dim msgRng As Range
userName = ADtest()
Application.ScreenUpdating = False
SendFile = Application.GetOpenFilename(Title:="Select MS Word " & _
"file to mail, then click 'Open'", buttontext:="Send", _
MultiSelect:=False)
Set W = GetObject(SendFile)
MsgTxt = W.Range(Start:=W.Paragraphs(1).Range.Start, _
End:=W.Paragraphs(W.Paragraphs.Count).Range.End)
strbody = MsgTxt
strbody = strbody & "<br><br><B>" & userName & "</B>"
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
On Error GoTo cleanup
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet
'Set filter range and filter column (column with names)
Set FilterRange = Ash.Range("A1:Q" & Ash.Rows.Count)
FieldNum = 1 'Filter column = A because the filter range start in column A
'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=True
'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount
mailAddress = ""
On Error Resume Next
On Error GoTo 0
'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value
'Copy the visible data in a new workbook
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
Set NewWB = Workbooks.Add(xlWBATWorksheet)
rng.Copy
With NewWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With
'
'
Set newRng = Nothing
Set newRng = NewWB.ActiveSheet.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
'Set body format to HTML
.BodyFormat = 2
.To = Cws.Cells(Rnum, 1).Value
.CC = ""
.BCC = ""
.Subject = "Daily Forecast " & Format(Now, "mm-dd-yy")
.HTMLBody = strbody & RangetoHTML(newRng)
.Display 'or use .Send
End With
'Save, Mail, Close and Delete the file
With NewWB
.Close savechanges:=False
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
'Close AutoFilter
Ash.AutoFilterMode = False
Next Rnum
End If
cleanup:
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
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 & "</br>"
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 GetBoiler(ByVal sFile As String) As String
'**** Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Public Function ADtest() As String
Dim ADSI As Object, UN As Object
Set ADSI = CreateObject("ADSystemInfo")
Set UN = GetObject("LDAP://" & ADSI.userName)
ADtest = UN.FirstName
ADtest = ADtest & " " & UN.LastName
Set UN = Nothing
Set ADSI = Nothing
End Function
Thanks
Bookmarks