Email button in excel

[cannonmkt]

Been a long time since I have been on here. I am using excel 2010. I have a button that when clicked will open outlook and attach the file. However, I want to have it automatically put in the email address that I am sending to, since it always the same. Below is the code I have. Also I forgot what brackets to surround the code, so forgive me. Can someone please assist me.

code
Sub Mail_Range()


'Working in 2000-2010
Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim i As Long


Set Source = Nothing
On Error Resume Next
Set Source = Range("y1:ad40").SpecialCells(xlCellTypeVisible)
On Error GoTo 0


If Source Is Nothing Then
MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
Exit Sub
End If


With Application
.ScreenUpdating = False
.EnableEvents = False
End With


Set wb = ActiveWorkbook
Set Dest = Workbooks.Add(xlWBATWorksheet)


Source.Copy
With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With


TempFilePath = Environ$("temp") & ""
TempFileName = "Ecclesia & " & Format(Now, "dd-mmm-yy h-mm-ss")


If Val(Application.Version) < 12 Then
'You use Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2010
FileExtStr = ".xlsx": FileFormatNum = 51
End If


With Dest
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
For i = 1 To 3
.SendMail "", _
"Ecclesia Order"
If Err.Number = 0 Then Exit For
Next i
On Error GoTo 0
.Close SaveChanges:=False
End With


Kill TempFilePath & TempFileName & FileExtStr


With Application
.ScreenUpdating = True
.EnableEvents = True
End With

End Sub




Sub Mail_Selection()
'Working in 2000-2010
Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim i As Long


Set Source = Nothing
On Error Resume Next
Set Source = Selection.SpecialCells(xlCellTypeVisible)
On Error GoTo 0


If Source Is Nothing Then
MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
Exit Sub
End If


If ActiveWindow.SelectedSheets.Count > 1 Or _
Selection.Cells.Count = 1 Or _
Selection.Areas.Count > 1 Then
MsgBox "An Error occurred :" & vbNewLine & vbNewLine & _
"You have more than one sheet selected." & vbNewLine & _
"You only selected one cell." & vbNewLine & _
"You selected more than one area." & vbNewLine & vbNewLine & _
"Please correct and try again.", vbOKOnly
Exit Sub
End If


With Application
.ScreenUpdating = False
.EnableEvents = False
End With


Set wb = ActiveWorkbook
Set Dest = Workbooks.Add(xlWBATWorksheet)


Source.Copy
With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With


TempFilePath = Environ$("temp") & ""
TempFileName = "Ecclesia Order & " & Format(Now, "dd-mmm-yy h-mm-ss")


If Val(Application.Version) < 12 Then
'You use Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2010
FileExtStr = ".xlsx": FileFormatNum = 51
End If


With Dest
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
For i = 1 To 3

.SendMail "", _
"Ecclesia Order"
If Err.Number = 0 Then Exit For
Next i
On Error GoTo 0
.Close SaveChanges:=False
End With




End Sub

 

[iggydarsa]

maybe this helps

Sub SendEmail ()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    strbody = "Body goes here"
    On Error Resume Next
    With OutMail
        .To = "desired@emailaddress.com"
        .CC = ""
        .BCC = ""
        .Subject = "Subject goes here"
        .Body = strbody
        '.Attachments.Add ("C:\test.txt") 'Attachment address
        .Send   
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

PS: you use [ c o d e ] in the beginning and [ / c o d e ] at the end without the spaces

 

[cannonmkt]

Thank you so much