How to send email from excel using VBA with excel content copy paste onto email

[luvnet18]

attach is the 2 files for your checking.

this file can:-

• populate email To & CC email ID based on NewSI K13 & K14 (vlookup with Disty_Forwarder.xls]Distributor & Forwarder)
• email subject can be populated based on K12
• remove vlookup formula & change it to value before saving the excel file on C drive Data folder
• saving the excel file name based on a specific cell name in the excel (A19)
• attach the saved excel file onto email

1) Previously the data from excel file onto email content but after some adjustment, this function not working. i think something to do with NewSI K10 & K11. need help.

2) Can I do a drop down list on NewSI-Versions2 based on the Forwarder (Disty_Forwarder B11~B16) according to Country (Disty_Forwarder A11~A16) Nepal / Indonesia / Philippines.

</SPAN></SPAN>Eg. If country show Nepal, i want to see only 2 option on the drop down list on NewSI-Versions2 which is TMI Shipping (M) SDN BHD or YCH DISTRIPARK SDN BHD PG.

Eg. If country show Philippines, I only want to see the drop down list showing Coconut Shipping & Strawberry Vessel.</SPAN></SPAN>

3) How to auto-close the NewFile after doing the attachment in email?


*** How can i attach my file for your to review? ***



Sub Outlook_Mail_Every_Worksheet_Body()
Dim NewFile As String
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
ThisWorkbook.Save
' ActiveWorkbook.SaveAs Filename:="C:\Data\NewSI.xls", FileFormat:=xlNormal, WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
With Application
.EnableEvents = False
.ScreenUpdating = False
End With

Dim TotalRange As String
TotalRange = Sheets("SI Template").Range("K11").Value
'MsgBox TotalRange

Set rng = Nothing
On Error Resume Next
Set rng = Sheets("SI Template").Range(TotalRange).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

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next

Set rng = Cells.Find(What:="Vlookup", _
After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)

If Not rng Is Nothing Then
Do
rng.Formula = rng.Value
Set rng = Cells.FindNext(rng)
Loop Until rng Is Nothing
End If

Range("P:Q").Select 'add on
Selection.EntireColumn.Delete = True 'add on

Columns("K:O").Select 'Add on
Selection.EntireColumn.Hidden = True 'Add on

ActiveWorkbook.SaveAs Filename:="C:\Data\" & Range("A19").Value & ".xls"


NewFile = "C:\Data\" & Range("A19").Value & ".xls"


With OutMail
.To = Sheets("SI Template").Range("K14").Value
.CC = Sheets("SI Template").Range("K15").Value
.BCC = ""
.Subject = Sheets("SI Template").Range("K12").Value
.HTMLBody = RangetoHTML(rng)
.Attachments.Add NewFile
.Display 'or use .Send
End With



On Error GoTo 0

With Application
.EnableEvents = True
.ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing




End Sub