Voting Buttons

Hi.
I have searched the forums, but can't find any information on this.

What I have set up below is:
Open excel > form opens > complete form > select ok and then this triggers an email to one of the cell values

What i would like (if possible), the recipient of the email to have an email that displays voting buttons so they simple select the required voting button (approve/decline) and if approved, triggers that email to a predefined email address.

(i.e. users submits request for account > manager gets email and selects button in email to approve and send email to another team)


Thanks in advance for any help!!

Private Sub Label3_Click()

End Sub

Private Sub UserForm_Activate()
Me.TextBoxExisting.Enabled = False
End Sub

Private Sub CancelButton_Click()
Unload UserForm1
End Sub

Private Sub LMEmain_Click()

End Sub

Private Sub OKButton_Click()

Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim strbody As String 'Required for A. below


If Me.TextName.Value = "" Then
        MsgBox "Please enter your full name.", vbExclamation, "Access"
        Me.TextName.SetFocus
        Exit Sub
    End If
If Me.TextRole.Value = "" Then
        MsgBox "Please enter your role title.", vbExclamation, "Access"
        Me.TextRole.SetFocus
        Exit Sub
    End If
If Me.TextTeam.Value = "" Then
        MsgBox "Please enter your team name.", vbExclamation, "Access"
        Me.TextTeam.SetFocus
        Exit Sub
    End If
If Me.TextLanID.Value = "" Then
        MsgBox "Please enter your LanID.", vbExclamation, "Access"
        Me.TextLanID.SetFocus
        Exit Sub
    End If
If Me.TextEmail.Value = "" Then
        MsgBox "Please enter your email address.", vbExclamation, "Access"
        Me.TextEmail.SetFocus
        Exit Sub
    End If
If Me.TextLM.Value = "" Then
        MsgBox "Please enter your Line Managers name.", vbExclamation, "Access"
        Me.TextLM.SetFocus
        Exit Sub
    End If
If Me.TextLME.Value = "" Then
        MsgBox "Please enter your Line Managers email address.", vbExclamation, "Access"
        Me.TextLME.SetFocus
        Exit Sub
    End If

Dim emptyRow As Long

'Make Sheet1 Active
Sheets(1).Activate

'Determine emptyRow
emptyRow = WorksheetFunction.CountA(Range("A:A")) + 1

'Export Data to worksheet
Cells(emptyRow, 1).Value = "Name: " & TextName.Value
Cells(emptyRow, 5).Value = "Role Title: " & TextRole.Value
Cells(emptyRow, 3).Value = "Team: " & TextTeam.Value
Cells(emptyRow, 4).Value = "Lan ID: " & TextLanID.Value
Cells(emptyRow, 2).Value = TextEmail.Value
Cells(emptyRow, 6).Value = "Line Manager: " & TextLM.Value
Cells(emptyRow, 7).Value = TextLME.Value

If OptionButtonExisting.Value = True Then
    Cells(emptyRow, 8).Value = "Existing Account: " & TextBoxExisting.Value
Else
    Cells(emptyRow, 8).Value = OptionButtonNew.Caption
End If

If OptionSupport.Value = True Then Cells(emptyRow, 9).Value = OptionSupport.Caption

If OptionDev.Value = True Then Cells(emptyRow, 9).Value = Cells(emptyRow, 9).Value & " , " & OptionDev.Caption

If OptionQA.Value = True Then Cells(emptyRow, 9).Value = Cells(emptyRow, 9).Value & " , " & OptionQA.Caption

If OptionOther.Value = True Then Cells(emptyRow, 9).Value = Cells(emptyRow, 9).Value & " , " & TextBoxOther.Value

'#####  This is the email portion ######################################


 Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
 
    On Error GoTo cleanup
    'A. uses the values of cells in a range as the body text
     For Each cell In Range("A1:I1")
        strbody = strbody & cell.Value & vbNewLine
    Next
    
    For Each cell In Columns("G").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" Then 'removed And (replaced with Then)
           'LCase(Cells(cell.Row, "C").Value) = "yes" Then
         
            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = TextLME.Value
                .Cc = TextEmail.Value
                .Subject = "Your Approval Required
                 .Body = "Dear " & TextLM.Value & vbNewLine & vbNewLine _
                 & "The following person has requested an account" _
                 & vbNewLine & vbNewLine & "If you are the line manager, please review the below details. If you Approve, please forward your approval with this email to approvalgroup@email.com" _
                 & vbNewLine & vbNewLine & vbNewLine & strbody
                'You can add files also like this
                '.Attachments.Add ("C:\test.txt")
                .Send  'Or use Display
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    Next cell

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True

End Sub


Private Sub TextBox1_Change()


End Sub

Private Sub OptionButtonExisting_Change()
If Me.OptionButtonExisting = False Then
Me.TextBoxExisting.Value = ""
Me.TextBoxExisting.Enabled = False
Else
Me.TextBoxExisting.Enabled = True
End If

End Sub

Private Sub TextBoxOther_Active()
TextBoxOther.Enabled = False

End Sub