VBA - Sending Active Sheet by email

[YannDV]

Hi everyone! 

I am struggling with my VBA code, I dont understand why it doesn't work. You have to know that I am not very good with VBA coding, just trying to implement small things for my company. 

My goal is to send an active sheet by email to our concerned customer by clicking on a button. On the sheet you can find the customer email address in D5, the object in A2, the filename in G7 and cc in H1. 
Once the button is triggered, a pop up ask if I want to send the sheet or all the workbook. When I select "workbook" the code works fine. The problem is when I select the active sheet, it creates a new workbook with only the active sheet (which is what I want), but struggle to save it and give it the write filename (which should be G7). Actually, excel creates a new workbook called "book" and a number instead of the filename I would want, and doesn't save it. Excel Debug mode says the problem come from this line : 

WB.SaveAs FileName:="e:\" & FileName which I highlighted in red in the code bellow. 

This is the code (I haven't made it myself, found it from the internet, but doesn't work for me. I tried quite a few things but I really dont understand what's not going on) 

This is my error message :

When I launch the macro, as it create and open the new workbook with the active sheet, it is open (but with the name book 1)

Can someone please help me ? 

Thanks a lot, whish you a nice day!

Sub Button2()
'Variable declaration
'Outlook application
Dim oApp As Object
'Outlook MailItem
Dim oMail As Object
Dim WB As Workbook
Dim WS As Worksheet
Dim FileName As String
Dim SendSheetOnly As Boolean
'Turn off screen updating
Application.ScreenUpdating = False
'Ask the user what to send
Select Case MsgBox( _
Prompt:="Do you want to send the active sheet only ?", _
Buttons:=vbYesNoCancel)
Case vbYes
'Yes, make a copy of the active sheet.
SendSheetOnly = True
ActiveSheet.Copy
Set WB = ActiveWorkbook
'Save without formulas ?
Cells.Copy
Cells.PasteSpecial Paste:=xlPasteValues
'Clear the clipboard
Application.CutCopyMode = False
FileName = Cells(7, "G").Value & ".xls"

'Continue when error occurs
On Error Resume Next
Kill "e:\" & FileName
On Error GoTo 0
WB.SaveAs FileName:="e:\" & FileName
Case vbNo
If Len(ActiveWorkbook.Path) = 0 Then
'File hasn't been saved before
MsgBox "Can't send an unsaved workbook", vbCritical
GoTo exiting
End If
SendSheetOnly = False
Set WB = ActiveWorkbook
Case vbCancel
'olDiscard = 1
oMail.Close SaveMode:=1
GoTo exiting
End Select

Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0) 'olMailItem = 0
With oMail
'User input To property
.To = Range("D5").Value
'User input CC property
.CC = Range("H1").Value
'Hard code Read Receipt Requested property
'.ReadReceiptRequested = True
'User input Read Receipt Requested property
'.ReadReceiptRequested = Range("B3").Value
'User input Subject property
.Subject = Range("A2").Value
'User input Body property
.Body = Range("e5").Value
'Hard code Sensitivity property
.Sensitivity = 3 'olConfidential = 3
'Set attachment
.Attachments.Add WB.FullName
'Hard code importance
''olImportanceHigh = 2
.Importance = 2
'Send directly (remove apostrophe on line below to activate)
'.Send
'Display it
.Display
End With
If SendSheetOnly Then
WB.ChangeFileAccess Mode:=xlReadOnly
Kill WB.FullName
WB.Close SaveChanges:=False
End If
exiting:
'Restore screen updating
Application.ScreenUpdating = True
'destroy variables and restore memory
Set oMail = Nothing
Set oApp = Nothing

End Sub

[#2]

@YannDV 

this might work for you: try moving this line: Set WB = ActiveWorkbook before your error line when debugging. perhaps to the beginning of the code.

[#3]

@YannDV 

Do you really want to save the workbook as an Excel 97-2003 workbook? If so, change the offending line to

WB.SaveAs FileName:="e:\" & FileName, FileFormat:=xlExcel8

[#4]

Hi Josh,

Thanks for your help. Unfortunately, it did not change anything, still get an error at the same line... 😕

[#5]

Thanks I changed it 🙂

Unfortunately, same problem still occurs 😞

I m going to add the error message in my main text, maybe the problem can be point out more easily

[#6]

@YannDV 

What is the error message?

[#7]

I added it in the main question with a screen shot 🙂

[#8 · Accepted solution]

@YannDV 

try replacing your whole code with this

Sub Button2()
'Variable declaration
'Outlook application
Dim oApp As Object
'Outlook MailItem
Dim oMail As Object
Dim WB As Workbook
Dim WS As Worksheet
Dim FileName As String
Dim SendSheetOnly As Boolean
'Turn off screen updating
Application.ScreenUpdating = False
'Ask the user what to send
Select Case MsgBox( _
Prompt:="Do you want to send the active sheet only ?", _
Buttons:=vbYesNoCancel)
Case vbYes
'Yes, make a copy of the active sheet.
SendSheetOnly = True
ActiveSheet.Copy
Set WB = ActiveWorkbook
'Save without formulas ?
Cells.Copy
Cells.PasteSpecial Paste:=xlPasteValues
'Clear the clipboard
Application.CutCopyMode = False
FileName = ".xls"

'Continue when error occurs
On Error Resume Next
Kill "e:\" & FileName
On Error GoTo 0
WB.SaveAs FileName:=Range("G7").value & FileName
Case vbNo
If Len(ActiveWorkbook.Path) = 0 Then
'File hasn't been saved before
MsgBox "Can't send an unsaved workbook", vbCritical
GoTo exiting
End If
SendSheetOnly = False
Set WB = ActiveWorkbook
Case vbCancel
'olDiscard = 1
oMail.Close SaveMode:=1
GoTo exiting
End Select

Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0) 'olMailItem = 0
With oMail
'User input To property
.To = Range("D5").value
'User input CC property
.CC = Range("H1").value
'Hard code Read Receipt Requested property
'.ReadReceiptRequested = True
'User input Read Receipt Requested property
'.ReadReceiptRequested = Range("B3").Value
'User input Subject property
.Subject = Range("A2").value
'User input Body property
.Body = Range("e5").value
'Hard code Sensitivity property
.Sensitivity = 3 'olConfidential = 3
'Set attachment
.Attachments.Add WB.FullName
'Hard code importance
''olImportanceHigh = 2
.Importance = 2
'Send directly (remove apostrophe on line below to activate)
'.Send
'Display it
.Display
End With
If SendSheetOnly Then
WB.ChangeFileAccess Mode:=xlReadOnly
Kill WB.FullName
WB.Close SaveChanges:=False
End If
exiting:
'Restore screen updating
Application.ScreenUpdating = True
'destroy variables and restore memory
Set oMail = Nothing
Set oApp = Nothing

End Sub

[#9]

Thank you sooooo much, it works! Made my day! 😄
Have a nice one too!