attaching a file to an email VBA

K

karolina1406

Board Regular
Joined
Apr 18, 2016
Messages
110
Office Version
  1. 365
Platform
  1. Windows
hi,
i have a code for attaching a file to an outlook email but I would like to attach just an active sheet rather than whole workbook and I would like to remove all passwords from the sheet and leave the password on the original workbook.

can someone help?
VBA Code: 
Dim SourceWB As Workbook
Dim DestinWB As Workbook
Dim OutlookApp As Object
Dim OutlookMessage As Object
Dim TempFileName As Variant
Dim ExternalLinks As Variant
Dim TempFilePath As String
Dim FileExtStr As String
Dim DefaultName As String
Dim UserAnswer As Long
Dim x As Long

Set SourceWB = ActiveWorkbook

'Check for macro code residing in
  If Val(Application.Version) >= 12 Then
    If SourceWB.FileFormat = 51 And SourceWB.HasVBProject = True Then
      UserAnswer = MsgBox("There was VBA code found in this xlsx file. " & _
        "If you proceed the VBA code will not be included in your email attachment. " & _
        "Do you wish to proceed?", vbYesNo, "VBA Code Found!")
   
    If UserAnswer = vbNo Then Exit Sub 'Handle if user cancels
 
    End If
  End If

'Determine Temporary File Path

  TempFilePath = Environ$("temp") & "\"

'Determine Default File Name for InputBox
  If SourceWB.Saved Then
    DefaultName = Left(SourceWB.Name, InStrRev(SourceWB.Name, ".") - 1)
  Else
    DefaultName = SourceWB.Name
  End If

'Ask user for a file name
  TempFileName = Application.InputBox("Please enter name of the file? (No Special Characters!)", _
    "File Name", Type:=2, Default:=DefaultName)
   
    If TempFileName = False Then Exit Sub 'Handle if user cancels
 
'Determine File Extension
  If SourceWB.Saved = True Then
    FileExtStr = "." & LCase(Right(SourceWB.Name, Len(SourceWB.Name) - InStrRev(SourceWB.Name, ".", , 1)))
  Else
    FileExtStr = ".xlsm"
  End If

'Optimize Code
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.DisplayAlerts = False

'Save Temporary Workbook
  SourceWB.SaveCopyAs TempFilePath & TempFileName & FileExtStr
  Set DestinWB = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)
  
'Save Changes

  DestinWB.Save
'Create Instance of Outlook
  On Error Resume Next
    Set OutlookApp = GetObject(class:="Outlook.Application") 'Handles if Outlook is already open
  Err.Clear
    If OutlookApp Is Nothing Then Set OutlookApp = CreateObject(class:="Outlook.Application") 'If not, open Outlook
   
    If Err.Number = 429 Then
      MsgBox "Outlook could not be found, aborting.", 16, "Outlook Not Found"
      GoTo ExitSub
    End If
  On Error GoTo 0

'Create a new email message
  Set OutlookMessage = OutlookApp.CreateItem(0)

'Create Outlook email with attachment
  On Error Resume Next
    With OutlookMessage
     .To = ""
     .CC = ""
     .BCC = ""
     .Subject = TempFileName
     .htmlBody = "<p style='font-family:cambria maths;font-size:18'<font color=""blue"">Hi Team," & "<br><br>" _
     & "Please see attached spreadheet for you to complete when on site." & "<br><br>" _
     & "Kind regards,"
     .Attachments.Add DestinWB.FullName
     .Display
    End With
  On Error GoTo 0

'Close & Delete the temporary file
  DestinWB.Close SaveChanges:=False
  Kill TempFilePath & TempFileName & FileExtStr

'Clear Memory
  Set OutlookMessage = Nothing
  Set OutlookApp = Nothing
 
'Optimize Code
ExitSub:
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.DisplayAlerts = True
 

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Sort by date Sort by votes
How about:

VBA Code: 
Sub SaveActiveSheet_PDF()
  Dim SourceWB As Workbook
  Dim DestinWB As Workbook
  Dim OutlookApp As Object
  Dim OutlookMessage As Object
  Dim TempFileName As Variant
  Dim ExternalLinks As Variant
  Dim TempFilePath As String
  Dim FileExtStr As String
  Dim DefaultName As String
  Dim UserAnswer As Long
  Dim x As Long
  
  Set SourceWB = ActiveWorkbook

'Check for macro code residing in
  If Val(Application.Version) >= 12 Then
    If SourceWB.FileFormat = 51 And SourceWB.HasVBProject = True Then
      UserAnswer = MsgBox("There was VBA code found in this xlsx file. " & _
        "If you proceed the VBA code will not be included in your email attachment. " & _
        "Do you wish to proceed?", vbYesNo, "VBA Code Found!")
    If UserAnswer = vbNo Then Exit Sub 'Handle if user cancels
    End If
  End If

'Determine Temporary File Path
  TempFilePath = Environ$("temp") & "\"

'Determine Default File Name for InputBox
  If SourceWB.Saved Then
    DefaultName = Left(SourceWB.Name, InStrRev(SourceWB.Name, ".") - 1)
  Else
    DefaultName = SourceWB.Name
  End If

'Ask user for a file name
  TempFileName = Application.InputBox("Please enter name of the file? (No Special Characters!)", _
    "File Name", Type:=2, Default:=DefaultName)
  If TempFileName = False Then Exit Sub 'Handle if user cancels
 
'Determine File Extension
  'If SourceWB.Saved = True Then
  '  FileExtStr = "." & LCase(Right(SourceWB.Name, Len(SourceWB.Name) - InStrRev(SourceWB.Name, ".", , 1)))
  'Else
    FileExtStr = ".xlsx"
  'End If

'Optimize Code
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.DisplayAlerts = False

'Save Temporary Workbook
  ActiveSheet.Copy
  ActiveWorkbook.SaveAs TempFilePath & TempFileName & FileExtStr
  ActiveWorkbook.Close
'  Set DestinWB = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)
  
'Save Changes
'  DestinWB.Save
'Create Instance of Outlook
  On Error Resume Next
    Set OutlookApp = GetObject(class:="Outlook.Application") 'Handles if Outlook is already open
  Err.Clear
    If OutlookApp Is Nothing Then Set OutlookApp = CreateObject(class:="Outlook.Application") 'If not, open Outlook
   
    If Err.Number = 429 Then
      MsgBox "Outlook could not be found, aborting.", 16, "Outlook Not Found"
      GoTo ExitSub
    End If
  On Error GoTo 0

'Create a new email message
  Set OutlookMessage = OutlookApp.CreateItem(0)

'Create Outlook email with attachment
  On Error Resume Next
    With OutlookMessage
     .To = ""
     .CC = ""
     .BCC = ""
     .Subject = TempFileName
     .htmlBody = "<p style='font-family:cambria maths;font-size:18'<font color=""blue"">Hi Team," & "<br><br>" _
     & "Please see attached spreadheet for you to complete when on site." & "<br><br>" _
     & "Kind regards,"
     .Attachments.Add TempFilePath & TempFileName & FileExtStr
     .Display
    End With
  On Error GoTo 0

'Close & Delete the temporary file
  'DestinWB.Close SaveChanges:=False
  Kill TempFilePath & TempFileName & FileExtStr

'Clear Memory
  Set OutlookMessage = Nothing
  Set OutlookApp = Nothing
 
'Optimize Code
ExitSub:
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.DisplayAlerts = True

End Sub
 
Upvote 0
DanteAmor said:
How about:

VBA Code: 
Sub SaveActiveSheet_PDF()
  Dim SourceWB As Workbook
  Dim DestinWB As Workbook
  Dim OutlookApp As Object
  Dim OutlookMessage As Object
  Dim TempFileName As Variant
  Dim ExternalLinks As Variant
  Dim TempFilePath As String
  Dim FileExtStr As String
  Dim DefaultName As String
  Dim UserAnswer As Long
  Dim x As Long
 
  Set SourceWB = ActiveWorkbook

'Check for macro code residing in
  If Val(Application.Version) >= 12 Then
    If SourceWB.FileFormat = 51 And SourceWB.HasVBProject = True Then
      UserAnswer = MsgBox("There was VBA code found in this xlsx file. " & _
        "If you proceed the VBA code will not be included in your email attachment. " & _
        "Do you wish to proceed?", vbYesNo, "VBA Code Found!")
    If UserAnswer = vbNo Then Exit Sub 'Handle if user cancels
    End If
  End If

'Determine Temporary File Path
  TempFilePath = Environ$("temp") & "\"

'Determine Default File Name for InputBox
  If SourceWB.Saved Then
    DefaultName = Left(SourceWB.Name, InStrRev(SourceWB.Name, ".") - 1)
  Else
    DefaultName = SourceWB.Name
  End If

'Ask user for a file name
  TempFileName = Application.InputBox("Please enter name of the file? (No Special Characters!)", _
    "File Name", Type:=2, Default:=DefaultName)
  If TempFileName = False Then Exit Sub 'Handle if user cancels

'Determine File Extension
  'If SourceWB.Saved = True Then
  '  FileExtStr = "." & LCase(Right(SourceWB.Name, Len(SourceWB.Name) - InStrRev(SourceWB.Name, ".", , 1)))
  'Else
    FileExtStr = ".xlsx"
  'End If

'Optimize Code
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.DisplayAlerts = False

'Save Temporary Workbook
  ActiveSheet.Copy
  ActiveWorkbook.SaveAs TempFilePath & TempFileName & FileExtStr
  ActiveWorkbook.Close
'  Set DestinWB = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)
 
'Save Changes
'  DestinWB.Save
'Create Instance of Outlook
  On Error Resume Next
    Set OutlookApp = GetObject(class:="Outlook.Application") 'Handles if Outlook is already open
  Err.Clear
    If OutlookApp Is Nothing Then Set OutlookApp = CreateObject(class:="Outlook.Application") 'If not, open Outlook
  
    If Err.Number = 429 Then
      MsgBox "Outlook could not be found, aborting.", 16, "Outlook Not Found"
      GoTo ExitSub
    End If
  On Error GoTo 0

'Create a new email message
  Set OutlookMessage = OutlookApp.CreateItem(0)

'Create Outlook email with attachment
  On Error Resume Next
    With OutlookMessage
     .To = ""
     .CC = ""
     .BCC = ""
     .Subject = TempFileName
     .htmlBody = "<p style='font-family:cambria maths;font-size:18'<font color=""blue"">Hi Team," & "<br><br>" _
     & "Please see attached spreadheet for you to complete when on site." & "<br><br>" _
     & "Kind regards,"
     .Attachments.Add TempFilePath & TempFileName & FileExtStr
     .Display
    End With
  On Error GoTo 0

'Close & Delete the temporary file
  'DestinWB.Close SaveChanges:=False
  Kill TempFilePath & TempFileName & FileExtStr

'Clear Memory
  Set OutlookMessage = Nothing
  Set OutlookApp = Nothing

'Optimize Code
ExitSub:
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.DisplayAlerts = True

End Sub
Click to expand...
this is working in a sense of sending just one sheet rather than the whole workbook. Thank you. However, i still didn;t get it done without password :(
 
Upvote 0
DanteAmor said:
I'm glad to help you. Thanks for the feedback.
Click to expand...
hi, quick question: is it possible to amend the code so the attached sheet in an email has some columns passworded? For example, can I apply a password to the attached sheet so the column A:D are password protected?
 
Upvote 0
The cells lock and protect the sheet.

After this line:
VBA Code: 
'Save Temporary Workbook
  ActiveSheet.Copy

add these lines:
VBA Code: 
    Cells.Locked = False
    Columns("A:D").Locked = True
    ActiveSheet.Protect "abc"

The sheet will be protected with the password "abc" change it by the one you want.
 
Upvote 0
DanteAmor said:
The cells lock and protect the sheet.

After this line:
VBA Code: 
'Save Temporary Workbook
  ActiveSheet.Copy

add these lines:
VBA Code: 
    Cells.Locked = False
    Columns("A:D").Locked = True
    ActiveSheet.Protect "abc"

The sheet will be protected with the password "abc" change it by the one you want.
Click to expand...
thank you for this. Unfortunately, I am not getting a result I wanted. Despite the sheet is protected, but individual cells can still be amended. I think its because of the copy of the sheet is in .xlsx format rather than .xlsm.... by changing the format I am receiving an error at ActiveWorkbook.SaveAs TempFilePath & TempFileName & FileExtStr :(
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question
Creating and emailing Excel sheet with only visible data
Replies
0
Views
166
mecerrato
M
H
  • Question
Macro to attached sheets without formulas
Replies
2
Views
376
howard
H
S
  • Question
Excel VBA to email multiple ranges as a PDF
Replies
0
Views
660
shophoney
S
catscantuseexcel
  • Solved
VBA to send sheets based on column values
Replies
3
Views
644
DanteAmor
DanteAmor
P
  • Question
Signature is being removed when I run the rest of my VBA
Replies
3
Views
160
rollis13
rollis13

Forum statistics

Threads
1,214,784
Messages
6,121,536
Members
449,037
Latest member
tmmotairi

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top