Excel VBA automatic Outlook email creation

I have the macro working exactly as I want, almost.  The only pain left is the message below.

  A program is trying to automatically send e-mail  on your behalf... then it gives you the option to click yes or no....
  Is it possible to overcome... this option....?
  And not have it show up?  The other part I would like to do is create a mail message with more text than the one line.

Below is the macro I have written:

Sub SUPV_EMAIL_Macro()
'
' SUPV_EMAIL_Macro Macro
' Macro written 3/28/2003 by OHSTANG
'
' Keyboard Shortcut: Ctrl+z
'
   Workbooks.Open Filename:="C:\DATA\SUPV_RPT.xls"
    Cells.Select
    Selection.ClearContents
    Range("A1").Select
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    Sheets("DATA").Select
    Range("A1").Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    Sheets("DATA").Select
'
' This section copies the template tab over to the printed report to clear it out
'
    Sheets("TEMPLATE").Select
    Range("A1:G50").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("A1").Select
    Sheets("PRINTED REPORT").Select
    Range("A1").Select
    ActiveSheet.Paste
'
'This section verifies if the supervisor name is different than the first one
'
    Range("A1").Select
    Sheets("DATA").Select
    ActiveCell.Offset(0, 0).Range("A1").Select
'
    Dim EMPLOYEE As String
    Dim SUPERVISOR As String
    Dim Supervisor_Email As String
    Dim Management_Unit As String
    Dim MU_Description As String
    Dim Employee_number As String
    Dim BAAN_CC As String
'
    Do While ActiveCell.Value <> ""
'
' This section copies the template tab over to the printed report to clear it out
'
    Sheets("TEMPLATE").Select
    Range("A1:IF1000").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("A1").Select
    Sheets("PRINTED REPORT").Select
    Range("A1").Select
    ActiveSheet.Paste
    Sheets("DATA").Select
'
    SUPERVISOR = ActiveCell.Value
    Sheets("Printed Report").Select
    Application.Goto reference:="SUPV_NAME"
    ActiveCell.Value = SUPERVISOR
    Sheets("DATA").Select
'
    Supervisor_Email = ActiveCell.Offset(0, 1).Value
    Sheets("Printed Report").Select
    Application.Goto reference:="SUPV_EMAIL"
    ActiveCell.Value = Supervisor_Email
    ActiveCell.Offset(3, 1).Select
    Sheets("DATA").Select
   
'
    Do While ActiveCell.Value = SUPERVISOR
    EMPLOYEE = ActiveCell.Offset(0, 5).Value
    Sheets("Printed Report").Select
    ActiveCell.Value = EMPLOYEE
    ActiveCell.Offset(0, -2).Select
    Sheets("DATA").Select
'
    Management_Unit = ActiveCell.Offset(0, 2).Value
    Sheets("Printed Report").Select
    ActiveCell.Value = Management_Unit
    ActiveCell.Offset(0, -1).Select
    Sheets("DATA").Select
'
    BAAN_CC = ActiveCell.Offset(0, 3).Value
    Sheets("Printed Report").Select
    ActiveCell.Value = BAAN_CC
    ActiveCell.Offset(0, 2).Select
    Sheets("DATA").Select
'
    MU_Description = ActiveCell.Offset(0, 4).Value
    Sheets("Printed Report").Select
    ActiveCell.Value = MU_Description
    ActiveCell.Offset(0, 2).Select
    Sheets("DATA").Select
'
    Employee_number = ActiveCell.Offset(0, 6).Value
    Sheets("Printed Report").Select
    ActiveCell.Value = Employee_number
'
'   Move down one row to process next Associate Record
    ActiveCell.Offset(1, -1).Select
    Sheets("DATA").Select
    ActiveCell.Offset(1, 0).Select
    Loop
    Application.Goto reference:="PRTRPT"
    Selection.Copy
    Workbooks.Open Filename:="C:\data\SUPV_RPT.xls"
    ActiveSheet.Paste
    Range("A1").Select
    Application.CutCopyMode = False
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    Range("A1").Select
    Set MyolApp = CreateObject("Outlook.Application")
    Set myitem = MyolApp.CreateItem(OlMailItem)
    Application.Goto reference:="SUPV_EMAIL"
    myitem.To = ActiveCell
    myitem.Subject = "Associate Listing Report - " & Now()
    myitem.body = "      Click the icon to open the Headcount Report. " & Chr(13)
    Set MyAttachments = myitem.Attachments
    MyAttachments.Add "C:\DATA\SUPV_RPT.xls"
    myitem.SEND
    Sheets("DATA").Select
    Loop
    End Sub

Start Free Trial