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>

 

[Michael M]

Hmm, that may give you an error.
try this version

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 & "\" & "Week1.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

 

[Javi]

Thanks almost there!!

Can the sheet that it creates on the local computer be deleted I dont need a copy of it on the local computer just in the e-mail.

 

[Michael M]

That's what these 2 lines do !

   ActiveWorkbook.Close False
    Kill ThisWorkbook.Path & "\" & "Week1.xls"

 

[Javi]

Thanks ALL!!!

It's working PERFECTLY!!!

I appreciate your time and effort...

Job well Done

 

[Michael M]

Glad to hear....thanks for the feedback !!