vba - ワークシートのセルから .from フィールドに入力する Excel の VBA スクリプト

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

サブ終了