Email code needs tweaking in regards to the " TO: " field. HOW??

[Mister H]

Hi All:

I am trying to tweak a code that I got from Ron DeBruins site. I have played around a bit and searched but I am not having any luck finding or accomplishing what I want. Here is the code I am using:

Sub EmailWorkbook()
'Working in 2000-2007
    Dim wb1 As Workbook
    Dim wb2 As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim OutApp As Object
    Dim OutMail As Object
    Set wb1 = ActiveWorkbook
    If Val(Application.Version) >= 12 Then
        If wb1.FileFormat = 51 And wb1.HasVBProject = True Then
            MsgBox "There is VBA code in this xlsx file, there will" & vbNewLine & _
                   "be no VBA code in the file you send. Save the" & vbNewLine & _
                   "file first as xlsm and then try the macro again.", vbInformation
            Exit Sub
        End If
    End If
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    'Make a copy of the file/Open it/Mail it/Delete it
    'If you want to change the file name then change only TempFileName
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Copy of " & wb1.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
    FileExtStr = "." & LCase(Right(wb1.Name, _
                                   Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))
    wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
    Set wb2 = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .Body = "Hi there"
        .Attachments.Add wb2.FullName
        .Display
    End With
    On Error GoTo 0
    wb2.Close SaveChanges:=False
    'Delete the file
    Kill TempFilePath & TempFileName & FileExtStr
    Set OutMail = Nothing
    Set OutApp = Nothing
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Is there a way that I can change it so that the To field of my email is whatever address the user types into cell B76? <?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
<o></o>
I also hear that the user may have to send to multiple people so I am thinking of making cells B76 to B86 available for typing email addresses. I can name the range if that makes coding any easier.<o></o>
<o></o>
Can the above be accomplished and if so how? <o></o>
<o></o>
As ALWAYS any assistance would be GREATLY Appreciated.<o></o>
<o></o>
THANKS,<o></o>
Mark

 

[VoG]

Hi Mark. Try this - I've highlighted my additions. Change the name of the sheet to suit

Sub EmailWorkbook()
'Working in 2000-2007
    Dim wb1 As Workbook
    Dim wb2 As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim i As Long, ToStr As String
    Set wb1 = ActiveWorkbook
    With Sheets("Sheet1") '<<<<<<<<<<<<<<<<< change to suit
        For i = 76 To 86
            With .Range("B" & i)
                If .Value <> "" Then ToStr = ToStr & .Value & ";"
            End With
        Next i
    End With
    ToStr = Left(ToStr, Len(ToStr) - 1)
    If Val(Application.Version) >= 12 Then
        If wb1.FileFormat = 51 And wb1.HasVBProject = True Then
            MsgBox "There is VBA code in this xlsx file, there will" & vbNewLine & _
                   "be no VBA code in the file you send. Save the" & vbNewLine & _
                   "file first as xlsm and then try the macro again.", vbInformation
            Exit Sub
        End If
    End If
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    'Make a copy of the file/Open it/Mail it/Delete it
    'If you want to change the file name then change only TempFileName
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Copy of " & wb1.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
    FileExtStr = "." & LCase(Right(wb1.Name, _
                                   Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))
    wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
    Set wb2 = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .To = ToStr
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .Body = "Hi there"
        .Attachments.Add wb2.FullName
        .Display
    End With
    On Error GoTo 0
    wb2.Close SaveChanges:=False
    'Delete the file
    Kill TempFilePath & TempFileName & FileExtStr
    Set OutMail = Nothing
    Set OutApp = Nothing
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

 

[Mister H]

THANKS VoG... I will give that a go. Your assistance as ALWAYS is GREATLY Appreciated. If I have any further problems I will report back.

Have an EXCELLENT day,
Mark