Sub Mail_Picking_Outlook()
'Working in 2000-2010
Dim wb1
As Workbook
Dim wb2
As Workbook
Dim FilePath
As String
Dim FileName
As String
Dim FileExtStr
As String
Dim OutApp
As Object
Dim OutMail
As Object
Set wb1 = ActiveWorkbook
If Val(Application.Version) >= 12
Then
If wb1.FileFormat = 51
And wb1.HasVBProject =
True Then
MsgBox "There is VBA code in this xlsx file, there will" & vbNewLine & _
"be no VBA code in the file you send. Save the" & vbNewLine & _
"file first as xlsm and then try the macro again.", vbInformation
Exit
Sub
End If
End If
With Application
.ScreenUpdating =
False
.EnableEvents =
False
End With
'Make a copy of the file/Open it/Mail it/Delete it
'If you want to change the file name then change only FileName
FilePath = "m:\Picking\Completed Forms\"
FileName = Range("A1") & " Picking " & Range("B34")
FileExtStr = "." & LCase(Right(wb1.Name, _
Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))
wb1.SaveCopyAs FilePath & FileName & FileExtStr
Set wb2 = Workbooks.Open(FilePath & FileName & FileExtStr)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = "email
@email.org"
.CC = ""
.BCC = ""
.Subject = Range("A1") & " Picking " & Range("B34")
.Body = Range("A1") & " Picking " & Range("B34")
.Attachments.Add wb2.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send
'or use .Display
End With
On Error Goto 0
wb2.Close SaveChanges:=
False
Set OutMail =
Nothing
Set OutApp =
Nothing
MsgBox "1. File has been e-mailed to XYZ at " & Format(Now, "[$409]hh:mm:ss AM/PM") & " on " & Format(Now, "mmm-dd-yyyy") & "." & vbNewLine & "2. The file is also saved to the server as: " & vbNewLine & Format(Now, "yyyymmdd-hhmmss ") & Range("A1")
With Application
.ScreenUpdating =
True
.EnableEvents =
True
End With
End Sub