Email VBA Code/Break Link

[~Scorpion~]

I currently am using this VBA code below to email a single sheet from my workbook, however when the end user opens the attachment it keeps asking to edit links. What can I add to this code so that it breaks the link upon emailing so they don't get the prompt?



Sub Mail_ActiveSheet()
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, Outlook 2010
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

' Next, copy the sheet to a new workbook.
' You can also use the following line, instead of using the ActiveSheet object,
' if you know the name of the sheet you want to mail :
' Sheets("Sheet5").Copy
ActiveSheet.Copy
Set Destwb = ActiveWorkbook

' Determine the Excel version, and file extension and format.
With Destwb
If Val(Application.Version) < 12 Then
' For Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
' For Excel 2007-2010, exit the subroutine if you answer
' NO in the security dialog that is displayed when you copy
' a sheet from an .xlsm file with macros disabled.
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "You answered NO in the security dialog."
Exit Sub
Else
FileExtStr = ".xlsm": FileFormatNum = 52
End If
End If
End With

' You can use the following statements to change all cells in the
' worksheet to values.
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False

' Save the new workbook, mail, and then delete it.
TempFilePath = Environ$("temp") & "\"
TempFileName = ""

Set OutApp = CreateObject("Outlook.Application")

Set OutMail = OutApp.CreateItem(0)

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, _
FileFormat:=FileFormatNum
On Error Resume Next
' Change the mail address and subject in the macro before
' running the procedure.
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = ""
.Body = ""
.Attachments.Add Destwb.FullName
' You can add other files by uncommenting the following statement.
'.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
.Close SaveChanges:=False
End With

' Delete the file after sending.
Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True

End With
End Sub

 

[AlphaFrog]

I forgot to say the other macros I have assign to a object and that object no longer has the macro assigned to it after emailing

It's probably easiest to copy the whole workbook instead of just the one worksheet. Then in the workbook copy, delete the sheets you don't want included. That should retain the macros.

 

[~Scorpion~]

Yeah I would prefer not do that because the sheet I will be emailing has to be emailed out several times throughout the day and I would have to delete about 15 sheets everytime

 

[AlphaFrog]

This copies the workbook and deletes the unwanted sheets.

[color=darkblue]Sub[/color] Mail_ActiveSheet()
    [color=green]' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, Outlook 2010[/color]
    [color=darkblue]Dim[/color] FileExtStr [color=darkblue]As[/color] [color=darkblue]String[/color]
    [color=darkblue]Dim[/color] FileFormatNum [color=darkblue]As[/color] [color=darkblue]Long[/color]
    [color=darkblue]Dim[/color] Sourcewb [color=darkblue]As[/color] Workbook
    [color=darkblue]Dim[/color] Destwb [color=darkblue]As[/color] Workbook
    [color=darkblue]Dim[/color] TempFilePath [color=darkblue]As[/color] [color=darkblue]String[/color]
    [color=darkblue]Dim[/color] TempFileName [color=darkblue]As[/color] [color=darkblue]String[/color]
    [color=darkblue]Dim[/color] OutApp [color=darkblue]As[/color] [color=darkblue]Object[/color]
    [color=darkblue]Dim[/color] OutMail [color=darkblue]As[/color] [color=darkblue]Object[/color]
    [color=darkblue]Dim[/color] ws [color=darkblue]As[/color] Worksheet
    [color=darkblue]Dim[/color] strMySheet [color=darkblue]As[/color] [color=darkblue]String[/color]
    [color=darkblue]Dim[/color] Link [color=darkblue]As[/color] [color=darkblue]Variant[/color]
    [color=darkblue]Dim[/color] vType [color=darkblue]As[/color] [color=darkblue]Variant[/color]
    
    [color=darkblue]With[/color] Application
        .ScreenUpdating = [color=darkblue]False[/color]
        .EnableEvents = [color=darkblue]False[/color]
    [color=darkblue]End[/color] [color=darkblue]With[/color]
    
    [color=darkblue]Set[/color] Sourcewb = ActiveWorkbook
    
    [color=green]' Determine the Excel version, and file extension and format.[/color]
    [color=darkblue]With[/color] Destwb
        [color=darkblue]If[/color] Val(Application.Version) < 12 [color=darkblue]Then[/color]
            [color=green]' For Excel 2000-2003[/color]
            FileExtStr = ".xls": FileFormatNum = -4143
        [color=darkblue]Else[/color]
            [color=green]' For Excel 2007-2010, exit the subroutine if you answer[/color]
            [color=green]' NO in the security dialog that is displayed when you copy[/color]
            [color=green]' a sheet from an .xlsm file with macros disabled.[/color]
            [color=darkblue]If[/color] Sourcewb.Name = .Name [color=darkblue]Then[/color]
                [color=darkblue]With[/color] Application
                    .ScreenUpdating = [color=darkblue]True[/color]
                    .EnableEvents = [color=darkblue]True[/color]
                [color=darkblue]End[/color] [color=darkblue]With[/color]
                MsgBox "You answered NO in the security dialog."
                [color=darkblue]Exit[/color] [color=darkblue]Sub[/color]
            [color=darkblue]Else[/color]
                FileExtStr = ".xlsm": FileFormatNum = 52
            [color=darkblue]End[/color] [color=darkblue]If[/color]
        [color=darkblue]End[/color] [color=darkblue]If[/color]
    [color=darkblue]End[/color] [color=darkblue]With[/color]
    
    [color=green]' Save the new workbook, mail, and then delete it.[/color]
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Copy of " & ActiveSheet.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
    
    [color=green]' Next, copy the sheet to a new workbook.[/color]
    [color=green]' You can also use the following line, instead of using the ActiveSheet object,[/color]
    [color=green]' if you know the name of the sheet you want to mail :[/color]
    strMySheet = ActiveSheet.Name
    Sourcewb.SaveCopyAs TempFilePath & TempFileName & FileExtStr
    [color=darkblue]Set[/color] Destwb = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)
    
    Application.DisplayAlerts = [color=darkblue]False[/color]
    [color=darkblue]For[/color] [color=darkblue]Each[/color] ws [color=darkblue]In[/color] Destwb.Worksheets
        [color=darkblue]If[/color] ws.Name <> strMySheet [color=darkblue]Then[/color] ws.Delete
    [color=darkblue]Next[/color]
    Application.DisplayAlerts = [color=darkblue]True[/color]
    
    Destwb.Sheets(strMySheet).Unprotect Password:="Secret"
    [color=darkblue]For[/color] [color=darkblue]Each[/color] vType [color=darkblue]In[/color] Array(xlLinkTypeExcelLinks, xlOLELinks, xlPublishers, xlSubscribers)
        [color=darkblue]If[/color] [color=darkblue]Not[/color] IsEmpty(Destwb.LinkSources(Type:=vType)) [color=darkblue]Then[/color]
            [color=darkblue]For[/color] [color=darkblue]Each[/color] Link [color=darkblue]In[/color] Destwb.LinkSources(Type:=vType)
                Destwb.BreakLink Name:=Link, Type:=vType
            [color=darkblue]Next[/color] Link
        [color=darkblue]End[/color] [color=darkblue]If[/color]
    [color=darkblue]Next[/color] vType
    Destwb.UpdateLinks = xlUpdateLinksNever
    Destwb.Sheets(strMySheet).Protect Password:="Secret"
    
    [color=green]' You can use the following statements to change all cells in the[/color]
    [color=green]' worksheet to values.[/color]
    [color=green]' With Destwb.Sheets(1).UsedRange[/color]
    [color=green]' .Cells.Copy[/color]
    [color=green]' .Cells.PasteSpecial xlPasteValues[/color]
    [color=green]' .Cells(1).Select[/color]
    [color=green]' End With[/color]
    [color=green]' Application.CutCopyMode = False[/color]
    
    Destwb.Save
    
    [color=darkblue]Set[/color] OutApp = CreateObject("Outlook.Application")
    [color=darkblue]Set[/color] OutMail = OutApp.CreateItem(0)
                
    [color=darkblue]On[/color] [color=darkblue]Error[/color] [color=darkblue]Resume[/color] [color=darkblue]Next[/color]
    [color=green]' Change the mail address and subject in the macro before[/color]
    [color=green]' running the procedure.[/color]
    [color=darkblue]With[/color] OutMail
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = ""
        .Body = ""
        .Attachments.Add Destwb.FullName
        [color=green]' You can add other files by uncommenting the following statement.[/color]
        [color=green]'.Attachments.Add ("C:\test.txt")[/color]
        [color=green]' In place of the following statement, you can use ".Display" to[/color]
        [color=green]' display the mail.[/color]
        .Display
    [color=darkblue]End[/color] [color=darkblue]With[/color]
    [color=darkblue]On[/color] [color=darkblue]Error[/color] [color=darkblue]GoTo[/color] 0
    Destwb.Close SaveChanges:=[color=darkblue]False[/color]
    
    [color=green]' Delete the file after sending.[/color]
    Kill TempFilePath & TempFileName & FileExtStr
    
    [color=darkblue]Set[/color] OutMail = [color=darkblue]Nothing[/color]
    [color=darkblue]Set[/color] OutApp = [color=darkblue]Nothing[/color]
    
    [color=darkblue]With[/color] Application
        .ScreenUpdating = [color=darkblue]True[/color]
        .EnableEvents = [color=darkblue]True[/color]
    [color=darkblue]End[/color] [color=darkblue]With[/color]
    
[color=darkblue]End[/color] [color=darkblue]Sub[/color]