Trevor Osborne
New Member
- Joined
- Sep 12, 2016
- Messages
- 29
How to get this Marco to work in 2016?
Rich (BB code):
Sub Send_Part_Number_Request()
'Clear current data
Rows("102:155").Select
Selection.ClearContents
'Copy data below to be sorted before it is added to body of email
Range("B47:C97").Select
Selection.Copy
Range("B102").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Delete blank rows
Dim n As Long, lastrow1 As Long
lastrow1 = Range("b154").End(xlUp).Row
For n = lastrow1 To 100 Step -1
If Cells(n, 2).Value = "" Then Cells(n, 2).EntireRow.Delete
Next n
'Put line breaks in to separate part numbers
Rows("101:101").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("104:104").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("111:111").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("118:118").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("125:125").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("132:132").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
ActiveWindow.SmallScroll Down:=9
Rows("139:139").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("146:146").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("149:149").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
'Copy data to paste into email
Range("B100:C154").Select
Selection.Copy
ActiveWindow.SmallScroll Down:=-155
'Create email rto send
'Sends a specified range in an Outlook message and retains Excel formatting
'Dimension variables
Dim oOutlookApp As Object, oOutlookMessage As Object
Dim oFSObj As Object, oFSTextStream As Object
Dim rngeSend As Range, strHTMLBody As String, strTempFilePath As String
'Select the range to be sent
On Error Resume Next
Set rngeSend = Range("New_Part_Number_Request!B100:c153")
'Get the temp folder path
Set oFSObj = CreateObject("Scripting.FilesystemObject")
strTempFilePath = oFSObj.GetSpecialFolder(2)
strTempFilePath = strTempFilePath & "\XLRange.htm"
'Now create the HTML file - NOTE! xlSourceRange and xlHtmlStatic have been replaced by their
'numeric values
ActiveWorkbook.PublishObjects.Add(4, strTempFilePath, _
rngeSend.Parent.Name, rngeSend.Address, 0, "", "").Publish True
'Create an instance of Outlook (or use existing instance if it already exists
Set oOutlookApp = CreateObject("Outlook.Application")
'Create a mail item
Set oOutlookMessage = oOutlookApp.CreateItem(0)
'Open the HTML file using the FilesystemObject into a TextStream object
Set oFSTextStream = oFSObj.OpenTextFile(strTempFilePath, 1)
'Now set the HTMLBody property of the message to the text contained in the TextStream object
strHTMLBody = oFSTextStream.ReadAll
'By default the range will be centered, this line left aligns it
strHTMLBody = Replace(strHTMLBody, "align=center", "align=left", , , vbTextCompare)
oOutlookMessage.HTMLBody = strHTMLBody
oOutlookMessage.Display
'Fill out adress, subject, etc.
With oOutlookMessage
.To = "pricing@autobarn.com.au"
.CC = ""
.BCC = ""
.Subject = "New Part Number Request"
.OriginatorDeliveryReportRequested = True
.ReadReceiptRequested = True
.Display
End With
On Error GoTo 0
End Sub
Last edited by a moderator: