Excel Coding to send email

I have a spreadsheet that I want to send email from depending upon the date.  I have it doing everything I want except it's not putting in who the email should go to.  This is the code I have been using.  My email recipient goes in Cell AK6.  Can you tell me how to fix it?  Thank you.

Sub Macro1()

Dim rngCell As Range

Dim rngMyDataSet As Range

Dim Rng As Range

Dim OutApp As Object

Dim OutMail As Object

Dim EmailSubject As String

Dim EmailSendTo As String

Dim MailBody As String

Dim EmailRecipient As String

Dim Signature As String

Application.ScreenUpdating = False

With ActiveSheet

If .FilterMode Then .ShowAllData

Set Rng = .Range("AK6", .Cells(.Rows.Count, 1).End(xlUp))

End With

For Each rngCell In Rng

If rngCell.Offset(0, 6) > 0 Then

ElseIf rngCell.Offset(0, 5) > Evaluate("Today() +7") And _

rngCell.Offset(0, 5).Value <= Evaluate("Today() +30") Then

rngCell.Offset(0, 6).Value = Date

Set OutApp = CreateObject("Outlook.Application")

Set OutMail = OutApp.CreateItem(0)

strbody = "According to my records, your contract " & Range("A1").Value & " is due for review on " & rngCell.Offset(0, 5).Value & vbNewLine & _

"Please review this contract prior to the pertinent date and email me with any changes you make to this contract.  If it is renewed, please fill out the Contract Cover Sheet which can be found in the Everyone folder and send me the new original contract."

EmailSendTo = rngCell.Offset(0, 0).Value

EmailSubject = Sheets("sheet1").Range("A6").Value

EmailRecipient = rngCell.Offset(0, 1).Value

Signature = "C:\Documents and Settings\" & Environ("rmm") & _

"\Application Data\Microsoft\Signatures\rm.htm"

On Error Resume Next

With OutMail

.to = EmailSendTo

.CC = "email address removed for privacy reasons"

.BCC = ""

.Subject = EmailSubject

.Body = strbody

.Display

End With

On Error GoTo 0

Set OutMail = Nothing

Set OutApp = Nothing

End If

Next rngCell

Application.ScreenUpdating = True

End Sub