Adjust VBA Code to email open excel file with change in name.

[horees]

Gents,
I'm using the below famous code to attach the currently open excel file by email. Everything works fine, but I want the macro to rename the excel file before attaching it to be "original file name_range(A1)".

I did alot of search, but I need the code not to offer Save As dialog, and I don't where the user will be saving his file (file location is unknown).

Appreciate your support!

Thanks

Sub Mail_Workbook_1()
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, Outlook 2010.' This example sends the last saved version of the Activeworkbook object .

Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next

' Change the mail address and subject in the macro before you run it.
With OutMail .To = "myself@abc.com"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hello World!"

.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line. '.Attachments.Add ("C:\test.txt") ' In place of the following statement, you can use ".Display" to ' display the mail.

.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing

End Sub

 

[Meesam]

Use this code:

Option Explicit
Sub Mail_Workbook_1()

Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'On Error Resume Next

' Change the mail address and subject in the macro before you run it.
ActiveWorkbook.SaveAs (Left(ActiveWorkbook.FullName, Len(ActiveWorkbook.FullName) - 5) & "_" & _
    ActiveWorkbook.ActiveSheet.Range("A1").Value & ".xlsm")

With OutMail
.To = "abc@xyz.com"
.CC = ""
.BCC = ""
.Subject = "Subject Line"
.Body = "Hello"
.Attachments.Add ActiveWorkbook.FullName
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing

End Sub

However one thing is obvious that if you are using a file with 4 digits in extension i.e. xls etc, then use "4" instead of "5" in the Len expression above. I'm saving file as ".xlsm" but you can choose whatever way you like.

Regards

 

[horees]

I updated my code, but the file name doesn't change
I'm using .xlsm
Please advise

 

[horees]

I figured out the problem. now it is working perfect! I had to put part of your code in different part of the code. Thanks alot.

My little problem now is with multiple "Send" Button, each time the file is saved as a new file, and it duplicates the added part to the name.

Example: if the file name is Test, and value in A1 is Plan, then first send the file name will be Test-Plan, second send it will be Test-Plan-Plan, and so on.

Is there anyway to set something like a condition for renaming/save as? may be a condition such as if the file name has the text in A1, don't save as...
or any other solution/workaround?
Knowing that it's part of the code that it saves the file after clicking the send button.

Appreciate your help!

 

[Meesam]

There is a very simple work around that I often use when I have to check certain condition from worksheet and I'm working on some sort of FORM. Put a value in any other cell and check for it's condition (1 or greater than 1) and then based on that you can process your data. Relevant code is as below and I hope it solves the problem.

'You can use any cell in place of B1.
ActiveWorkbook.ActiveSheet.Range("B1").Font.Color = vbWhite
'White so that you won't see it as it's not required.
ActiveWorkbook.ActiveSheet.Range("B1").Value = ActiveWorkbook.ActiveSheet.Range("B1").Value + 1

If ActiveWorkbook.ActiveSheet.Range("B1") < 2 Then
ActiveWorkbook.SaveAs (Left(ActiveWorkbook.FullName, Len(ActiveWorkbook.FullName) - 5) & "_" & _
    ActiveWorkbook.ActiveSheet.Range("A1").Value & ".xlsm")
Else
ActiveWorkbook.SaveAs (ActiveWorkbook.FullName)
End If

 

[horees]

It works great, but I got another problem
The second time to run the macro, it says the file name already exists, do you want to replace. if the user click yes, no problem
if he clicked no or cancel, it will crash "cannot access file name" and stops at this line "ActiveWorkbook.SaveAs (ActiveWorkbook.FullName)"

or if the user open the original file before rename, he will get the same msg for existing report, if he clicked no or cancel (not to replace), he will get the crash "method saveas of object workbook failed". and stops at "ActiveWorkbook.SaveAs (Left(ActiveWorkbook.FullName, Len(ActiveWorkbook.FullName) - 5) & "_" & _
ActiveWorkbook.ActiveSheet.Range("B2").Value & ".xlsm"

Any workaround this?
I would say something like a custom msg with Yes to overwrite, No to rename and save, cancel to go back to the sheet without crashes?

Thank you in advance

getting closer

 

[horees]

Or easier solution may be automatically replace the file without prompting the user (because actually he is saving to overwrite the unsaved version).

Thank you

 

[Meesam]

That was simple I guess.

Application.DisplayAlerts = False
ActiveWorkbook.ActiveSheet.Range("B1").Font.Color = vbWhite
ActiveWorkbook.ActiveSheet.Range("B1").Value = ActiveWorkbook.ActiveSheet.Range("B1").Value + 1
' Change the mail address and subject in the macro before you run it.
If ActiveWorkbook.ActiveSheet.Range("B1") < 2 Then
ActiveWorkbook.SaveAs (Left(ActiveWorkbook.FullName, Len(ActiveWorkbook.FullName) - 5) & "_" & _
    ActiveWorkbook.ActiveSheet.Range("A1").Value & ".xlsm")
Else
ActiveWorkbook.SaveAs (ActiveWorkbook.FullName)
End If
Application.DisplayAlerts = True

 

[horees]

That is great.

You are the man!