Question

我正在开发一个用户将填写信息的项目，当点击发送按钮时，确切的文件将邮寄给其他具有新名字的人

这是我的代码可以正常发送电子邮件

    Sub send_email_via_Gmail()
Dim myMail As CDO.Message

Set myMail = New CDO.Message

myMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True

myMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1

myMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"

myMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465

myMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2

myMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "example@gmail.com"

myMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"

myMail.Configuration.Fields.Update

With myMail
.Subject = "Test Email from Dr. Takyar"
.From = "example@gmail.com"
.To = "example1@gmail.com"

.TextBody = "Good morning!"

End With

myMail.Send
MsgBox ("Mail has been sent")
Set myMail = Nothing

End Sub

这是代码，它将完全复制现有的工作表

   Sub Add_Sheet()
    ActiveSheet.Copy After:=Worksheets(Worksheets.Count)
    Worksheets(Worksheets.Count).Name = InputBox("New Name:")
End Sub

现在我的问题是我如何制作新的工作簿而不是工作表并通过电子邮件发送它们

这是我的代码

Sub Add_Sheet()

Dim wb As Workbook
    Set wb = Workbooks.add
        ThisWorkbook.Sheets("Sheet1").Copy before:=wb.Sheets(1)
      ActiveWorkbook.SaveAs Filename:="C:\Data\SalesData1.xlsx"
       Workbooks("SalesData1.xlsx").Close

End Sub

Answer 1

经过一整天的麻烦后，我终于找到了解决方案这是克隆工作表并通过gmail和它发送的代码完全致力于excel -2007 - 2010 - 2013

      Sub Copy_Every_Sheet_To_New_Workbook()
     'Working in 97-2013
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String
    Dim Mail As New Message
    Dim name As String
    Dim Config As Configuration
    Dim fileName As String
Set Config = Mail.Configuration

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

    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ThisWorkbook

    'Create new folder to save the new files in
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = Sourcewb.Path & "\" & Sourcewb.name & " " & DateString
    fileName = Sourcewb.name & " " & DateString
    MkDir FolderName

    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets

        'If the sheet is visible then copy it to a new workbook
        If sh.Visible = -1 Then
            sh.Copy

            'Set Destwb to the new workbook
            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-2013
                    If Sourcewb.name = .name Then
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    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 the worksheet to values if you want
            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    .Cells(1).Select
                End With
                Application.CutCopyMode = False
            End If


            'Save the new workbook and close it
            With Destwb
                .SaveAs FolderName _
                      & "\" & fileName & FileExtStr, _
                        FileFormat:=FileFormatNum
                .Close False
            End With



        End If
GoToNextSheet:
    Next sh
    MsgBox "You can find the files in " & FolderName
MsgBox FolderName & "\" & ActiveSheet.name & ".xlsm"
Config(cdoSendUsingMethod) = cdoSendUsingPort
Config(cdoSMTPServer) = "smtp.gmail.com"
Config(cdoSMTPServerPort) = 465
Config(cdoSMTPAuthenticate) = cdoBasic
Config(cdoSMTPUseSSL) = True
Config(cdoSendUserName) = "example@gmail.com"

Config(cdoSendPassword) = "password"
Config.Fields.Update

Mail.To = "example1@gmail.com"
Mail.From = Config(cdoSendUserName)
Mail.Subject = "hhhhhhhhhhhhh"
Mail.AddAttachment FolderName & "\" & fileName & ".xlsm"
Mail.HTMLBody = "fffff"
Mail.Send

MsgBox "sent "

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With  
End Sub

如何将Excel工作表复制到另一个工作表并通过电子邮件发送

1 个答案: