email active sheet and code associated with it

[RobertCotton]

I am using the code that follows this message to email the active sheet in my workbook. The active sheet has a number of macros that, when executed, hide and unhide columns.

Can this code be adapted to also copy the VBA macro code so that the sheet will be functional for the recipient?

Thanks

Here is the code...

Sub Mail_ActiveSheet()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
'Copy the ActiveSheet to a new workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With
' 'Change all cells in the worksheet to values if you want
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & ""
TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.to = "ron@debruin.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

 

[Logit]

.
Why not just email the entire workbook to the other person, that way they will have all of the macros included ?

This email macro will attached the current workbook (the one you want to send) to the other person. You would place this macro
into the workbook you want to send.

Option Explicit


Sub Mail_workbook_Outlook()




    Dim OutApp As Object
    Dim OutMail As Object
    Dim sndEmail As String
    Dim ccEmail As String
    Dim bccEmail As String


    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    toEmail = Sheets("EMAIL").Range("D2").Value         '<-- Edit sheet name and range as required
    ccEmail = Sheets("EMAIL").Range("D3").Value         '<-- Edit sheet name and range as required
    bccEmail = Sheets("EMAIL").Range("D4").Value        '<-- Edit sheet name and range as required


    On Error Resume Next
    With OutMail
        .To = sndEmail                  '<-- Use variables above with sheet range or ... just enter email address
        .CC = ccEmail                   '<-- Use variables above with sheet range or ... just enter email address
        .BCC = bccEmail                 '<-- Use variables above with sheet range or ... just enter email address
        .Subject = "Spare Parts Maintenance"
        .Body = "The parts have been placed on today's load sheet and will be processed by EOB today.  The parts have also been transferred to the repository file."
        .Attachments.Add (Application.ActiveWorkbook.FullName) 'attaches this workbook to email
        
        '.Send                              '<-- .Send will auto send email without review
        .Display                            '<-- .Display will show the email first for review
    End With
    On Error GoTo 0




    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub