Need help with E-Mail code “Please” Almost got it!!

[Javi]

Hi All, Thanks for looking into my issue.
What I trying to do is e-mail range "T1:X35" from worksheet "Main Sheet" in the body of the e-mail. The code needs to get the e-mail address from Cell "D37" and an ok to send from cell "C37" if it's value is "Yes". No error message is needed if no.
The below code works just cant get it to check the cell C37 of authorization to send. I tryed whats in red with no lucK at all.
Thanks Javi!!

Function RangetoHTML(rng As Range)
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:office:office" /><o:p> </o:p>
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 
    ' Copy the range and create a workbook to receive the data.
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
 
    ' Publish the sheet to an .htm file.
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
 
    ' Read all data from the .htm file into the RangetoHTML subroutine.
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
 
    ' Close TempWB.
    TempWB.Close savechanges:=False
 
    ' Delete the htm file.
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
<o:p> </o:p>
<o:p> </o:p>
Sub Mail_Selection_Range_Outlook_Body()
' You need to use this module with the RangetoHTML subroutine.
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
<o:p> </o:p>
ActiveSheet.Unprotect
<o:p> </o:p>
<o:p> </o:p>
    Set rng = Nothing
    On Error Resume Next
    ' Only send the visible cells in the selection.
     ' Set rng = Selection.SpecialCells(xlCellTypeVisible)
    ' You can also use a range with the following statement.
    Set rng = Sheets("Main Sheet").Range("T1:X35").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
<o:p> </o:p>
    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected. " & _
               vbNewLine & "Please correct and try again.", vbOKOnly
        Exit Sub
    End If
<o:p> </o:p>
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    
[COLOR=red]    'For Each cell In ThisWorkbook.Sheets("Main Sheet").Range("D37")<o:p></o:p>[/COLOR]
[COLOR=red]     'If cell.Value Like "?*@?*.?*" And _<o:p></o:p>[/COLOR]
[COLOR=red]      '  LCase(Cells(cell.Row, "C37").Value) = "yes" Then<o:p></o:p>[/COLOR]
 
<o:p> </o:p>
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
<o:p> </o:p>
    On Error Resume Next
    With OutMail
        
[COLOR=red]        '.To = cell.Value<o:p></o:p>[/COLOR]
        
        .To = ThisWorkbook.Sheets("Main Sheet").Range("D37").Value
        '.To = "ron@debruin.nl"
        .CC = ""
        .BCC = ""
        .Subject = "NFL Pick Your Loser Status"
        .HTMLBody = RangetoHTML(rng)
        ' In place of the following statement, you can use ".Display" to
         .display 'the e-mail message.
        '.Send
    End With
    On Error GoTo 0
<o:p> </o:p>
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
<o:p> </o:p>
    Set OutMail = Nothing
    Set OutApp = Nothing
   ' ActiveSheet.Unprotect
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowSorting:=True, AllowFiltering:=True
<o:p> </o:p>
       
<o:p> </o:p>
End Sub
<o:p> </o:p>
<o:p> </o:p>
<o:p> </o:p>

<o> </o>
<o> </o>

 

[AlphaFrog]

Sub Mail_Selection_Range_Outlook_Body()
' You need to use this module with the RangetoHTML subroutine.
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    
[COLOR="Red"]    If Sheets("Main Sheet").Range("D37").Value Like "?*@?*.?*" And _
       LCase(Sheets("Main Sheet").Range("C37").Value) = "yes" Then
 
       Sheets("Main Sheet")[/COLOR].Unprotect
    
       Set rng = Nothing
       On Error Resume Next
       ' Only send the visible cells in the selection.
        ' Set rng = Selection.SpecialCells(xlCellTypeVisible)
       ' You can also use a range with the following statement.
       Set rng = Sheets("Main Sheet").Range("T1:X35").SpecialCells(xlCellTypeVisible)
       On Error GoTo 0
    
       If rng Is Nothing Then
           MsgBox "The selection is not a range or the sheet is protected. " & _
                  vbNewLine & "Please correct and try again.", vbOKOnly
           Exit Sub
       End If
    
       With Application
           .EnableEvents = False
           .ScreenUpdating = False
       End With

 
       Set OutApp = CreateObject("Outlook.Application")
       Set OutMail = OutApp.CreateItem(0)
    
       On Error Resume Next
       With OutMail
           
           .To = ThisWorkbook.Sheets("Main Sheet").Range("D37").Value
           .CC = ""
           .BCC = ""
           .Subject = "NFL Pick Your Loser Status"
           .HTMLBody = RangetoHTML(rng)
           ' In place of the following statement, you can use ".Display" to
            .display 'the e-mail message.
           '.Send
       End With
       On Error GoTo 0
    
       With Application
           .EnableEvents = True
           .ScreenUpdating = True
       End With
    
       Set OutMail = Nothing
       Set OutApp = Nothing
      ' ActiveSheet.Unprotect
       [COLOR="Red"]Sheets("Main Sheet")[/COLOR].Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
           , AllowSorting:=True, AllowFiltering:=True
 
[COLOR="Red"]    Else[/COLOR]
       [COLOR="Green"] 'MsgBox "No in C37"[/COLOR]
[COLOR="Red"]    End If[/COLOR]
 
End Sub

 

[Javi]

Thank you so much!!! Worked great!!!

I do have a question for you if you don't mind..

What code would I need if I wanted to add a sheet to the e-mail as an attachment. The sheet name is "week1"

 

[Javi]

Forgot to say the sheet is in the same workbook!

 

[AlphaFrog]

You're welcome.

Example Code for sending mail from Excel

 

[Javi]

Thank you for this resorce. I have been trying to apply some of these codes to what I'm using now with no luck for a number of days.

I have been able to e-mail a sheet as an attachment however I can't seem to add a sheet as a attachment to the email the code you help me with created.


Any guidance or assistance you could give would be greatly appreciated basically i'm at a lost.

Thanks Javi,

 

[Michael M]

Javi
Insert this line before the send line

 .Attachments.Add "path and filename here"

 

[Javi]

Thanks for the reply.

I'm just wanting to send one of the sheets "week1" from the file I'm ruming the code in as an attachment. I do not want to sent the workbook. Is there a veriation of this that would work for that?

 .Attachments.Add "path and filename here"

 

[Biz]

Try

http://www.rondebruin.nl/mail/folder1/mail2.htm

I believe you need code below to copy sheet to new workbook

'Copy the sheet to a new workbook
    ActiveSheet.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-2010, we exit the sub when your answer is
            'NO in the security dialog that you only see  when you copy
            'an 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

 'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Part of " & Sourcewb.Name & " " _
                 & Format(Now, "dd-mmm-yy h-mm-ss")
TempFilePath = Environ$("temp") & "\"
    TempFileName = aVariable & "s' Part of " & FileNameNoExt(Sourcewb.Name) _
                 & " " & "as at " & Format(Now, "dd-mmm-yy h-mm-ss")
    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, _
                FileFormat:=FileFormatNum
        On Error Resume Next
        
       Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
       Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = rcells.Value
                '.cc = cell.Offset(0, 1).Value
                .Subject = "Special Projects"
                '.Body = "Dear " & cell.Offset(0, -1).Value
                .Display  'Or use Send
                .Attachments.Add TempFilePath & TempFileName & FileExtStr
         End With
        On Error GoTo 0
        .Close SaveChanges:=False
    End With
    Kill TempFilePath & TempFileName & FileExtStr

Biz

 

[Michael M]

Biz is correct you need to make a copy of the sheet to a new workbook
Try

Sub Mail_Selection_Range_Outlook_Body()
' You need to use this module with the RangetoHTML subroutine.
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    
    If Sheets("Main Sheet").Range("D37").Value Like "?*@?*.?*" And _
       LCase(Sheets("Main Sheet").Range("C37").Value) = "yes" Then
 
       Sheets("Main Sheet").Unprotect
    
       Set rng = Nothing
       On Error Resume Next
       ' Only send the visible cells in the selection.
        ' Set rng = Selection.SpecialCells(xlCellTypeVisible)
       ' You can also use a range with the following statement.
       Set rng = Sheets("Main Sheet").Range("T1:X35").SpecialCells(xlCellTypeVisible)
       On Error GoTo 0
    
       If rng Is Nothing Then
           MsgBox "The selection is not a range or the sheet is protected. " & _
                  vbNewLine & "Please correct and try again.", vbOKOnly
           Exit Sub
       End If
    
       With Application
           .EnableEvents = False
           .ScreenUpdating = False
       End With
    ThisWorkbook.Sheets("Week1").Copy

    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & _
        "Week1.xls"

 
       Set OutApp = CreateObject("Outlook.Application")
       Set OutMail = OutApp.CreateItem(0)
    
       On Error Resume Next
       With OutMail
           
           .To = ThisWorkbook.Sheets("Main Sheet").Range("D37").Value
           .CC = ""
           .BCC = ""
           .Subject = "NFL Pick Your Loser Status"
           .HTMLBody = RangetoHTML(rng)
           ' In place of the following statement, you can use ".Display" to
            .display 'the e-mail message.
          .Attachments.Add ActiveWorkbook.FullName
'.Send
       End With
       On Error GoTo 0
    
       With Application
           .EnableEvents = True
           .ScreenUpdating = True
       End With
    
    ActiveWorkbook.Close False
    Kill ThisWorkbook.Path & "\" & "Sheet2.xls"

       Set OutMail = Nothing
       Set OutApp = Nothing
      ' ActiveSheet.Unprotect
       Sheets("Main Sheet").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
           , AllowSorting:=True, AllowFiltering:=True
 
    Else
        'MsgBox "No in C37"
    End If
 
End Sub