• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

VB & xlam question

BCBSSC_Jon

New Member
I borrowed the code described here...
http://chandoo.org/wp/2012/04/23/send-mails-using-excel-vba-and-outlook/
What I need is a method to attach macros, to the "Generated Excel" sheet.
or a way to add the Name.xlam to the add-ins of the "Generated Excel" sheet.

Below is the code that generates the Email, and the new workbook.

Code:
Option Explicit
Sub Export_LSA_MAIL()
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("Email", "NGD-Cover", "NGD-data", "NGD-Form")).Copy
 
  Set newWB = ActiveWorkbook
 
  'Sheets("NGD-FORM").Visible = True
  'Sheets("NGD-FORM").Select
 
  Range("A1").Select
  Sheets("NGD-Data").Visible = True
  Sheets("NGD-Cover").Visible = True
  Sheets("Email").Visible = True
  Sheets("NGD-FORM").Select
 
 
  '******************************Creating Pathways*********************************
 
  xDir = AWBookPath
  xMonth = Format(xDate, "mm mmmm yy") & "\"
 
  xFile = "CCTG - NGD Form " & Format(xDate, "mm-dd-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 & "CCTG.STAFF"
 
 
  olMail.Attachments.Add xPath
  olMail.Display
 
  Application.StatusBar = False
  Application.ScreenUpdating = True
  Application.DisplayAlerts = False
 
 
'  If you want to attach the workbook that contains the code, you need to make the file read-only when you send it and then change access back to read-write. For example,
' ThisWorkbook.Save
' ThisWorkbook.ChangeFileAccess xlReadOnly
' B = SendEmail( _
'  ... parameters ...
'  Attachments:=ThisWorkbook.FullName)
' ThisWorkbook.ChangeFileAccess xlReadWrite

End Sub

Thanks Jon
 
Last edited by a moderator:
Back
Top