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

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

结束子

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