Сценарий VBA в Excel для заполнения поля.from из ячейки на листе

Question

Я успешно настроил сценарий VBA на основе примера из http://www.rondebruin.nl/ для отправки копии активного блога в Excel в виде вложения с использованием учетной записи gmail и CDO.

Что я хотел бы изменить, так это возможность изменить поле.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") = "[e-mail]"
    .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 = "[e-mail]"
    .CC = ""
    .BCC = ""
    'I tried this but it doesn't work
    '.From = ThisWorkbook.Sheets("Sheet2").Range("D5").Value

    .From = """Insert Name Here"" <[e-mail]>"
    .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"" <[e-mail]>"
    fromField = ThisWorkbook.Sheets("Sheet2").Range("D5").Value
    MsgBox "The hard-coded .From email is " & hardCodedFrom & vbCrLf & _
            "The variable .From email is " & fromField
End Sub