Sent email form excel

[WillemS]

Hi there, I need help to please to automate a small process. I have an excel spreadsheet called “email request” that users complete by random an email address on it in cell A1. Once completed I need VBA code to send a pre-generated email that I saved on my desktop as a .oft file to the email address entered in the excel sheet via outlook. Once sent the VBA code must then move the email address entered into cell A1 to a “backup sheet so that the next user can use the process again. Any help, please? Thanks

 

[ranman256]

paste the code into a module.
add a button on the sheet to run macro: SendEmail

Note: you must add the VBE REFERENCE to outlook, OUTLOOK x.x Object Library REFERENCE CHECKED IN VBE; ctl-G, menu,tools, references, Microsoft Outlook XX Object library

it assumes a sheet called 'backup' to put sent emails.

Option Explicit
Public Sub SendEmail()
Dim vTo, vFile, vDocName
ActiveWorkbook.Save
vTo = Range("A1").Value
If vTo = "" Then Exit Sub
vDocName = ActiveWorkbook.Name
vFile = "c:\temp\" & vDocName
KillFile vFile
Copy1File ActiveWorkbook.FullName, vFile
  'send email
Send1Email vTo, "My Subject", "heres the data", vFile
'put email addr in backup sheet
Range("A1").Value = ""
Sheets("backup").Activate
Range("A1").Select
Select Case True
   Case ActiveCell.Value = ""
     ActiveCell.Value = vTo
   Case ActiveCell.Offset(1, 0).Value = ""
      ActiveCell.Offset(1, 0).Value = vTo
   Case Else
      Selection.End(xlDown).Select   'goto the bottom item
     ActiveCell.Offset(1, 0).Select  'next row
     ActiveCell.Value = vTo
End Select
End Sub


Public Function Send1Email(ByVal pvTo, ByVal pvSubj, ByVal pvBody, Optional ByVal pvFile) As Boolean
Dim oMail As Outlook.MailItem
Dim oApp As Outlook.Application
On Error GoTo ErrMail
'NOTE : YOU MUST HAVE THE OUTLOOK x.x Object Library    REFERENCE CHECKED IN VBE; ctl-G, menu,tools, references, Microsoft Outlook XX Object library
Set oApp = GetApplication("Outlook.Application")  'it may be open already so use this
'Set oApp = CreateObject("Outlook.Application")  'not this
Set oMail = oApp.CreateItem(olMailItem)
With oMail
    .To = pvTo
    .Subject = pvSubj
    If Not IsMissing(pvFile) Then .Attachments.Add pvFile, olByValue, 1
   
    .HTMLBody = pvBody
    'If Not IsNull(pvBody) Then .Body = pvBody
   
    .Display True
    '.Send
End With
Send1Email = True
endit:
Set oMail = Nothing
Set oApp = Nothing
Exit Function
ErrMail:
MsgBox Err.Description, vbCritical, Err
Resume endit
End Function


Function GetApplication(className As String) As Object
' function to encapsulate the instantiation of an application object
Dim theApp As Object
On Error Resume Next
Set theApp = GetObject(, className)
If Err.Number <> 0 Then
    MsgBox "Unable to Get" & className & ", attempting to CreateObject"
    Set theApp = CreateObject(className)
End If
If theApp Is Nothing Then
    Err.Raise Err.Number, Err.Source, "Unable to Get or Create the " & className & "!"
    Set GetApplication = Nothing
End If
'MsgBox "Successfully got a handle on Outlook Application, returning to caller"
Set GetApplication = theApp
End Function


Public Sub KillFile(ByVal pvFile)
Dim fso
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
'FileReadOnly pvFile, False
fso.DeleteFile pvFile
Set fso = Nothing
End Sub

Public Sub Copy1File(ByVal pvSrc, ByVal pvTarg)
Dim fso
On Error GoTo errMake
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CopyFile pvSrc, pvTarg
Set fso = Nothing
Exit Sub
errMake:
MsgBox Err.Description & vbCrLf & pvSrc, , "Copy1File(): " & Err
Set fso = Nothing
End Sub

 

[WillemS]

Hi there.Thank you so much for the prompt reply I really appreciate it. Can I please call you in the morning as I have a few questions, please?