Saving and Email file as macro is ran

[drozek]

I found some code online that will automatically Open outlook and email the file that I name, but I am getting an error

Run-time error '1004':
Sorry, Excel can't open two workbooks with the same name at the same time.

It is stopping at the Break External Links code:
'Break External Links
ActiveWorkbook.BreakLink Name:= _
"C:\Program Files (x86)\Common Files\SAP Shared\BW\BExAnalyzer.xla", Type:= _
xlExcelLinks



Can anyone help? The name of the file should be 20190614_Forward Order.xlsm

Sub SaveForward()'
'  Names, Saves, and Closes Forward Order Report
'


      ActiveWorkbook.SaveAs "C:\Users\RozekD\Documents\XXXXX\Non-Customer\Reports\Forward Order Reports\" & _
                        Format(Now(), "YYYYMMDD") & "_Forward Order" & ".xlsm"


    Call EmailWorkbook
    
End Sub


Sub EmailWorkbook()
'PURPOSE: Create email message with ActiveWorkbook attached




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("What would you like to name your attachment? (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)


'Break External Links
    ActiveWorkbook.BreakLink Name:= _
        "C:\Program Files (x86)\Common Files\SAP Shared\BW\BExAnalyzer.xla", Type:= _
        xlExcelLinks


    'Loop Through each External Link in ActiveWorkbook and Break it
      On Error Resume Next
        For x = 1 To UBound(ExternalLinks)
          DestinWB.BreakLink Name:=ExternalLinks(x), Type:=xlLinkTypeExcelLinks
        Next x
      On Error GoTo 0
      
'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 = "Forecast Request"
     .CC = ""
     .BCC = ""
     .Subject = TempFileName
     .Body = ""
     .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


End Sub

 

[SpillerBD]

That already exist as a command through the File menu. Share, Email.
Those that are truely "lazy" add the command to their QAT from Commands not in the ribbon.

 

[SpillerBD]

For sending just Worksheets from a Workbook, I have the following. A rondebruin VBA.

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 = ""
            .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")
            .Display   'or use .Display or .Save
        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

 

[drozek]

That already exist as a command through the File menu. Share, Email.
Those that are truely "lazy" add the command to their QAT from Commands not in the ribbon.

Well **** I didn't know it was there! Thanks!