Hi Forum Experts ,
Can some one advice me with small tweak in the code that helps me sending me email as values ..
to be more precise , i have code that sends email with selected sheets given in the range . below is the code for your reference . everything is working fine until sending mails but the problem aroused at ... selected sheets links getting disabled and we are getting error (#VALUE!)..
Option Explicit Sub ExportEmail() Dim objfile As FileSystemObject Dim xNewFolder Dim xDir As String, xMonth As String, xFile As String, xPath As String Dim olApp As Outlook.Application Dim olMail As Outlook.MailItem Dim NameX As Name, xStp As Long Dim xDate As Date, AWBookPath As String Dim currentWB As Workbook, newWB As Workbook Dim strEmailTo As String, strEmailCC As String, strEmailBCC As String, strDistroList As String AWBookPath = ActiveWorkbook.Path & "\" Application.ScreenUpdating = False Application.DisplayAlerts = False Application.StatusBar = "Creating Email and Attachment for " & Format(Date, "dddd dd mmmm yyyy") Set currentWB = ActiveWorkbook xDate = Date '******************************Grabbing New WorkBook and Formatting************* Sheets(Array("Brake up", "Summary")).Copy Set newWB = ActiveWorkbook Range("A1").Select Sheets("Brake up").Visible = True 'Sheets ("Email") '******************************Creating Pathways********************************* xDir = AWBookPath xMonth = Format(xDate, "mm mmmm yy") & "\" xFile = "Daily DA_DB_DZ analysis report " & Format(xDate, "dd-mm-yyyy") & ".xlsx" xPath = xDir & xMonth & xFile '******************************Saving File in Pathway********************************* Set objfile = New FileSystemObject If objfile.FolderExists(xDir & xMonth) Then If objfile.FileExists(xPath) Then objfile.DeleteFile (xPath) newWB.SaveAs Filename:=xPath, FileFormat:=xlOpenXMLWorkbook, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _ , CreateBackup:=False Application.ActiveWorkbook.Close Else newWB.SaveAs Filename:=xPath, FileFormat:=xlOpenXMLWorkbook, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _ , CreateBackup:=False Application.ActiveWorkbook.Close End If Else xNewFolder = xDir & xMonth MkDir xNewFolder newWB.SaveAs Filename:=xPath, FileFormat:=xlOpenXMLWorkbook, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _ , CreateBackup:=False Application.ActiveWorkbook.Close End If '******************************Preparing Distribution List ********************************* currentWB.Activate Sheets("Email").Visible = True Sheets("Email").Select strEmailTo = "" strEmailCC = "" strEmailBCC = "" xStp = 1 Do Until xStp = 4 Cells(2, xStp).Select Do Until ActiveCell = "" strDistroList = ActiveCell.Value If xStp = 1 Then strEmailTo = strEmailTo & strDistroList & "; " If xStp = 2 Then strEmailCC = strEmailCC & strDistroList & "; " If xStp = 3 Then strEmailBCC = strEmailBCC & strDistroList & "; " ActiveCell.Offset(1, 0).Select Loop xStp = xStp + 1 Loop Range("A1").Select '******************************Preparing Email********************************* Set olApp = New Outlook.Application Dim olNs As Outlook.Namespace Set olNs = olApp.GetNamespace("MAPI") olNs.Logon Set olMail = olApp.CreateItem(olMailItem) olMail.To = strEmailTo olMail.CC = strEmailCC olMail.BCC = strEmailBCC olMail.Subject = Mid(xFile, 1, Len(xFile) - 4) olMail.Body = vbCrLf & "Hello Everyone," _ & vbCrLf & vbCrLf & "Please find attached the " & Mid(xFile, 1, Len(xFile) - 4) & "." _ & vbCrLf & vbCrLf & "Regards," _ & vbCrLf & "Genpact" olMail.Attachments.Add xPath olMail.Display Application.StatusBar = False Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub
Reply With Quote
