Question

我已根据http://www.rondebruin.nl中的示例成功配置了一个VBA脚本，以使用gmail帐户和CDO将excel中的活动电子表格副本作为附件发送。

我想要修改的是能够使用填写电子表格的用户的电子邮件地址更改.From字段。电子邮件地址将作为流程的一部分填入电子表格中。现在，我只能在.From字段中填入硬编码的电子邮件地址或用于发送附件的SMTP帐户的电子邮件地址。

我的想法可能吗？

这是我现在的代码。

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 Flds As Variant

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 = "FRAT 135 Helo" & Format(Now, "dd-mmm-yy h-mm-ss")
'TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

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

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/smtpusessl") = True
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "xxx@testsite.net"
    .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"

    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
    .Update
End With


With iMsg
    Set .Configuration = iConf
    .To = "safety@xxxx.net"
    .CC = ""
    .BCC = ""
    'I tried this but it doesn't work
    '.From = ThisWorkbook.Sheets("Sheet2").Range("D5").Value

    .From = """Insert Name Here"" <test@yahoo.com>"
    .Subject = "FRAT 135 Helo Submission"
    .TextBody = "Hi There"
    .HTMLBody = "<H3><B>Dear Safety Advisor</B></H3>" & _
                 "The attached spreadsheet has been submitted by a member of your team.<BR>" & _
                "Please view this and respond as needed"
                '"<A HREF=""http://www.companywebsite.com"">Corporate Website</A>"
    .AddAttachment TempFilePath & TempFileName & FileExtStr
    .Send
End With


'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr

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

End Sub

Answer 1

这绝对有可能。您可以硬编码的任何内容都可以替换为变量值。

您只需确保从工作表中读取的数据格式正确。

您可以使用以下内容确保从表格中获得有效值：

Sub EmailFrom()
    Dim hardCodedFrom As String
    Dim fromField As String

    hardCodedFrom = """Insesrt Name Here"" <test@yahoo.com>"
    fromField = ThisWorkbook.Sheets("Sheet2").Range("D5").Value
    MsgBox "The hard-coded .From email is " & hardCodedFrom & vbCrLf & _
            "The variable .From email is " & fromField
End Sub

Excel中的VBA脚本用于填充工作表中单元格的.from字段

1 个答案: