Excel：没有 VBA 代码的电子邮件工作簿作为附件

Question

我使用分配给命令按钮的以下代码自动将工作簿附加到电子邮件，以便用户可以将其发送出去。有没有办法在没有代码的情况下附加工作簿，所以接收电子邮件的人没有完整的代码，但发件人将其保留在他们的副本中？ （收件人只需要查看数据，他们不与表单交互，但发件人每天与其交互数次。）当我将工作簿保存为 .xlsx 时，它给了我一个是/否/帮助 MsgBox我想在发送过程中避免 - 将其保留为“一键式”操作。

Source_File = ThisWorkbook.FullName
myMail.Attachments.Add Source_File

Answer 1

Option Explicit

Sub CDO_Mail_Workbook()
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim iMsg As Object
    Dim iConf As Object
    Dim Flds As Variant
    Dim MyDate
    MyDate = Format(Now(), "dd-mmm-yy")

    Set wb = ActiveWorkbook

    If Val(Application.Version) >= 12 Then
        If wb.FileFormat = 51 And wb.HasVBProject = True Then
            MsgBox "There is VBA code in this xlsx file, there will be no VBA code in the file you send." & vbNewLine & _
                   "Save the file first as xlsm and then try the macro again.", vbInformation
            Exit Sub
        End If
    End If

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Make a copy of the file/Mail it/Delete it
    'If you want to change the file name then change only TempFileName
    TempFilePath = Environ$("temp") & "\"
    'TempFileName = wb.Name & " " & Format(Now, "yyyy-mmm-dd")
    TempFileName = "Test" & "-" & Format(Now, "yyyy-mmm-dd")


    'FileExtStr = "." & LCase(Right(wb.Name, Len(wb.Name) - InStrRev(wb.Name, ".", , 1)))
    FileExtStr = ".xlsm"


    Application.DisplayAlerts = False
    ' wb.SaveAs Filename:=TempFilePath & TempFileName & FileExtStr, FileFormat:=51, AccessMode:=xlExclusive, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges

    ActiveWorkbook.SaveCopyAs Filename:=TempFilePath & TempFileName & "Copy" & FileExtStr

    Workbooks.Open (TempFilePath & TempFileName & "Copy" & FileExtStr)
    ActiveWorkbook.SaveAs Filename:=TempFilePath & TempFileName & "-email" & ".xlsx", FileFormat:=51, AccessMode:=xlExclusive, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
    ActiveWorkbook.Close False

    'wb.SaveCopyAs TempFilePath & TempFileName & FileExtStr

    Application.DisplayAlerts = True

    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")

    iConf.Load -1    ' CDO Source Defaults
    Set Flds = iConf.Fields
    With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.office365.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "noone@noone.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = "1"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        .Update
    End With

    With iMsg
        Set .Configuration = iConf
        '.To = "noone@noone.com"
        '.CC = ""
        .BCC = ""
        .From = "noone@noone.com"
        .Subject = "Test - " & MyDate
        .TextBody = ""
        .AddAttachment TempFilePath & TempFileName & "-email" & ".xlsx"
        .Send
    End With

    'If you not want to delete the file you send delete this line
    Kill TempFilePath & TempFileName & "-email" & ".xlsx"

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

     Application.DisplayAlerts = False
    Set wb = Nothing

    For Each wb In Application.Workbooks
        wb.Save
    Next wb

    Application.Quit

End Sub


To send a single worksheet with the vba code removed, I've used this:


Option Explicit

'This procedure will send the ActiveSheet in a new workbook
'For more sheets use : Sourcewb.Sheets(Array("Sheet1", "Sheet3")).Copy

Sub CDO_Mail_ActiveSheet_Or_Sheets()
'Working in 97-2007
    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 iMsg As Object
    Dim iConf As Object
    Dim sh As Worksheet
    Dim Flds As Variant
    Dim MyDate
    MyDate = Format(Now(), "dd-mmm-yy")
    Dim wb As Workbook

    Set wb = ActiveWorkbook

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set Sourcewb = ActiveWorkbook

    'Copy the ActiveSheet to a new workbook
    ActiveSheet.Copy

    'Or if you want to copy more then one sheet use:
    'Sourcewb.Sheets(Array("Sheet1", "Sheet3")).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
            'We exit the sub when your answer is NO in the security dialog that you only
            'see  when you copy a sheet from a xlsm file with macro's disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            Else
                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 If
    End With

    'Change all cells in Destwb to values if you want
    For Each sh In Destwb.Worksheets
        sh.Select
        With sh.UsedRange
            .Cells.Copy
            .Cells.PasteSpecial xlPasteValues
            .Cells(1).Select
        End With
        Application.CutCopyMode = False
    Next sh
    Destwb.Worksheets(1).Select


    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Test" & "-" & Format(Now, "yyyy-mmm-dd")

    Application.DisplayAlerts = False

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        .Close savechanges:=False
    End With

    Application.DisplayAlerts = True

    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")

    iConf.Load -1    ' CDO Source Defaults
    Set Flds = iConf.Fields
    With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.office365.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "noone@noone.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = "1"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        .Update
    End With

    With iMsg
        Set .Configuration = iConf
        .To = "noone@noone.com"
'.CC = ""
        '.BCC = ""
        .From = "noone@noone.com"
        .Subject = "Test-" & MyDate
        .TextBody = ""
        .AddAttachment TempFilePath & TempFileName & FileExtStr
        .Send
    End With

    'If you not want to delete the file you send delete this line
    Kill TempFilePath & TempFileName & FileExtStr

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

     Application.DisplayAlerts = False
    Set wb = Nothing

    For Each wb In Application.Workbooks
        wb.Save
    Next wb

    Application.Quit

End Sub