Excel: электронная книга в виде приложения без кода VBA - PullRequest
Новая
       21

Excel: электронная книга в виде приложения без кода VBA

0 голосов
/ 13 февраля 2020

Я использую следующий код, назначенный для CommandButton, чтобы автоматически прикреплять книгу к электронному письму, чтобы пользователи могли отправлять ее. Есть ли способ прикрепить книгу без кода, чтобы у людей, получающих электронную почту, не было полного кода, а у отправителя есть его копия? (Получатели должны видеть только данные, они не взаимодействуют с формой, но отправитель взаимодействует с ней несколько раз в день.) Когда я сохраняю рабочую книгу как .xlsx, она дает мне MsgBox yes / no / help, который Я хотел бы избежать во время отправки - сохранить его как операцию «одним щелчком». 

Source_File = ThisWorkbook.FullName
myMail.Attachments.Add Source_File

1 Ответ

0 голосов
/ 16 февраля 2020 
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
...