Hello everyone,
I've been trying in the last couple hours to do something that should be simple:
I want the body of the e-mail to be the same as the default signature - and when I say the default one, is because there can be more users, so the format cannot be fixed.
I will change the e-mail body to read a cell from a worksheet instead of having it written in the code, I don't know if it's relevant for know.
Here's the code:
Thank you for your help.
I've been trying in the last couple hours to do something that should be simple:
I want the body of the e-mail to be the same as the default signature - and when I say the default one, is because there can be more users, so the format cannot be fixed.
I will change the e-mail body to read a cell from a worksheet instead of having it written in the code, I don't know if it's relevant for know.
Here's the code:
Code:
Sub logistic()
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
'avoid multiple selections
If Selection.Count = 1 Then
Else
Exit Sub
End If
Dim sup_range As Range
Dim sup_type As Variant
Dim settings As Worksheet
Dim sup_contact As Variant
Dim sup_data As Variant
Dim activeloc As Variant
Dim iata As Variant
Dim suplistr As Variant
Dim suplistc As Variant
Dim singmult As Variant
Dim supname As Variant
Dim suptype As Variant
Dim supcontact As Variant
Dim airreg As Variant
Dim oprt As Variant
Dim icao As Variant
Dim cn As Variant
Set settings = ThisWorkbook.Worksheets("Settings")
iata = settings.Cells(7, 21)
suplistr = settings.Cells(37, 20)
suplistc = settings.Cells(37, 21)
singmult = settings.Cells(40, 21)
supname = settings.Cells(11, 21)
suptype = settings.Cells(39, 21)
supcontact = settings.Cells(38, 21)
airreg = settings.Cells(6, 21)
oprt = settings.Cells(5, 21)
icao = settings.Cells(15, 21)
cn = settings.Cells(34, 21)
first_row = 2
Set activeloc = ThisWorkbook.ActiveSheet.Cells(ActiveCell.Row, iata)
Set sup_range = settings.Range(settings.Cells(suplistr - 1, suplistc), settings.Cells(settings.Cells(suplistr - 1, suplistc).End(xlDown).Row, singmult))
sup_type = Application.VLookup(Cells(ActiveCell.Row, supname).Value, sup_range, suptype - 1, False)
sup_contact = Application.VLookup(Cells(ActiveCell.Row, supname).Value, sup_range, supcontact - 1, False)
sup_data = Application.VLookup(Cells(ActiveCell.Row, supname).Value, sup_range, singmult - 1, False)
If IsError(sup_type) Then
MsgBox ("Supplier not found")
Exit Sub
Else
End If
If sup_type <> "Email" Then
MsgBox ("Should be contacted by " & sup_type)
Exit Sub
End If
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim excel_body As Range
Dim headers As Range
Set headers = Range(Cells(first_row, airreg), Cells(first_row, airreg + 6))
If sup_data = "Single" Then
'Select cells that are to be sent, add temp sheet to rearrange info
Set excel_body = Range(Cells(ActiveCell.Row, airreg), Cells(ActiveCell.Row, airreg + 6))
headers.Select
Selection.Copy
Sheets.Add after:=ActiveSheet
ActiveSheet.Paste
Rows(2).Select
ActiveSheet.Previous.Select
excel_body.Select
Selection.Copy
ActiveSheet.Next.Select
ActiveSheet.Cells(2, 1).PasteSpecial Paste:=xlValues
ActiveSheet.Cells(2, 1).PasteSpecial Paste:=xlFormats
Cells.Select
Cells.EntireColumn.AutoFit
Cells(1, 1).Select
Application.CutCopyMode = False
ActiveSheet.Name = "Claim Info"
Set excel_body = Range(Cells(1, 1), Cells(Cells(1, 1).End(xlDown).Row, Cells(1, 1).End(xlToRight).Column))
ActiveSheet.Previous.Select
TempFileName = Cells(ActiveCell.Row, oprt).Value & " - Contract fuel " & Cells(ActiveCell.Row, iata).Value _
& "/" & Cells(ActiveCell.Row, icao).Value
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Dim mail_body_message As String
'still need to correct
mail_body_message = settings.Cells(10, 16).Text & _
Cells(ActiveCell.Row, iata).Value & "/" & Cells(ActiveCell.Row, icao).Value & settings.Cells(11, 16).Text
Else
ActiveSheet.Range(Cells(first_row, 1), Cells(Cells(first_row, oprt).End(xlDown).Row, cn)).AutoFilter Field:=airreg, _
Criteria1:=Cells(ActiveCell.Row, airreg).Value
'Select cells that are to be sent, add temp sheet to rearrange info
Set excel_body = Range(Cells(ActiveCell.Row - 1, airreg), Cells(ActiveCell.Row + 2, airreg + 6))
headers.Select
'excel_body.Select
Selection.Copy
Sheets.Add after:=ActiveSheet
ActiveSheet.Paste
Rows(2).Select
ActiveSheet.Previous.Select
excel_body.Select
Selection.Copy
ActiveSheet.Next.Select
ActiveSheet.Cells(2, 1).PasteSpecial Paste:=xlValues
ActiveSheet.Cells(2, 1).PasteSpecial Paste:=xlFormats
Cells.Select
Cells.EntireColumn.AutoFit
Cells(1, 1).Select
'Rows(ActiveCell.Row + 1).Select
Columns(2).Select
Selection.Find(What:=activeloc, after:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.EntireRow.Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Application.CutCopyMode = False
ActiveSheet.Name = "Claim Info"
Set excel_body = Range(Cells(1, 1), Cells(Cells(1, 1).End(xlDown).Row, Cells(1, 1).End(xlToRight).Column))
ActiveSheet.Previous.Select
TempFileName = Cells(ActiveCell.Row + 1, oprt).Value & " - Contract fuel " & Cells(ActiveCell.Row + 1, iata).Value _
& "/" & Cells(ActiveCell.Row + 1, icao).Value
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
mail_body_message = "Please arrange fuel at " & _
Cells(ActiveCell.Row + 1, iata).Value & "/" & Cells(ActiveCell.Row + 1, icao).Value & " for the following:"
End If
On Error Resume Next
With OutMail
.display
.To = sup_contact
.CC = ""
.BCC = ""
.Subject = TempFileName
.HTMLbody = mail_body_message & "<br>" & RangetoHTML(excel_body) & .HTMLbody ' & "<br>" & Signature
'If MsgBox("Do you want to review the e-mail?", vbYesNo) = vbYes Then
.display
' Else
' .Send
' End If
End With
Set OutMail = Nothing
Set OutApp = Nothing
If ActiveSheet.AutoFilterMode Then
ActiveSheet.AutoFilter.ShowAllData
Else
End If
Worksheets("Claim info").Delete
'ActiveSheet.Previous.Activate
Application.CutCopyMode = False
activeloc.Select
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
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 xlPasteAll, , False, False
'.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Range(Columns(1), Columns(7)).EntireColumn.AutoFit
.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 FunctionThank you for your help.
