N
Neil Holden
hi all gurus, below is the code to attach the excel file in an email, it is
only attaching one sheet within the document.
How do i get it to attach the entire workbook?
Option Explicit
Sub Button66_Click()
Dim sh As Worksheet
Dim wb As Workbook
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim TempFilePath As String
Dim TempFileName As String
Dim Response As String
Dim DefaultFolder As String, DefaultFileName As String
Dim FileToSave
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Response = MsgBox("Are you sure you want to submit this to Procurement?", _
vbYesNo + vbInformation + vbDefaultButton2)
If Response = vbNo Then
Exit Sub
End If
TempFilePath = Environ$("temp") & "\"
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
FileExtStr = ".xlsm": FileFormatNum = 52
End If
With Application
..ScreenUpdating = False
.EnableEvents = False
End With
For Each sh In ThisWorkbook.Worksheets
If sh.Range("C21").Value Like "?*@?*.?*" Then
sh.Copy
Set wb = ActiveWorkbook
TempFileName = "Sheet " & sh.Name & " of " _
& ThisWorkbook.Name & " " & Format(Now, "dd-mmm-yy
h-mm-ss")
If Right(DefaultFolder, 1) <> "\" Then
DefaultFolder = DefaultFolder & "\"
End If
DefaultFileName = "Contract Created" & " for " & Sheets("Set Up
Sheet").Range("C12").Value
If Right(UCase(DefaultFileName), 3) <> "XLS" Then
DefaultFileName = DefaultFileName & " " & _
Format(Date, "dd-mm-yyyy") & ".xls"
End If
FileToSave = Application.GetSaveAsFilename _
(DefaultFolder & DefaultFileName, filefilter:="Excel Files (*.xls)," _
& "*.xls", Title:="Save File As...")
If FileToSave = False Then
Exit Sub
Else
ThisWorkbook.SaveAs _
Filename:=FileToSave, _
FileFormat:=ActiveWorkbook.FileFormat
End If
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
strbody = "Set Up Sheet" & " for " & Sheets("Set Up
Sheet").Range("c12").Value & " " & "has been created"
With wb
.SaveAs TempFilePath & TempFileName & FileExtStr,
FileFormat:=FileFormatNum
On Error Resume Next
.SendMail sh.Range("c21").Value, _
"This is the Subject line"
On Error GoTo 0
.Close SaveChanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
End If
Next sh
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
only attaching one sheet within the document.
How do i get it to attach the entire workbook?
Option Explicit
Sub Button66_Click()
Dim sh As Worksheet
Dim wb As Workbook
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim TempFilePath As String
Dim TempFileName As String
Dim Response As String
Dim DefaultFolder As String, DefaultFileName As String
Dim FileToSave
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Response = MsgBox("Are you sure you want to submit this to Procurement?", _
vbYesNo + vbInformation + vbDefaultButton2)
If Response = vbNo Then
Exit Sub
End If
TempFilePath = Environ$("temp") & "\"
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
FileExtStr = ".xlsm": FileFormatNum = 52
End If
With Application
..ScreenUpdating = False
.EnableEvents = False
End With
For Each sh In ThisWorkbook.Worksheets
If sh.Range("C21").Value Like "?*@?*.?*" Then
sh.Copy
Set wb = ActiveWorkbook
TempFileName = "Sheet " & sh.Name & " of " _
& ThisWorkbook.Name & " " & Format(Now, "dd-mmm-yy
h-mm-ss")
If Right(DefaultFolder, 1) <> "\" Then
DefaultFolder = DefaultFolder & "\"
End If
DefaultFileName = "Contract Created" & " for " & Sheets("Set Up
Sheet").Range("C12").Value
If Right(UCase(DefaultFileName), 3) <> "XLS" Then
DefaultFileName = DefaultFileName & " " & _
Format(Date, "dd-mm-yyyy") & ".xls"
End If
FileToSave = Application.GetSaveAsFilename _
(DefaultFolder & DefaultFileName, filefilter:="Excel Files (*.xls)," _
& "*.xls", Title:="Save File As...")
If FileToSave = False Then
Exit Sub
Else
ThisWorkbook.SaveAs _
Filename:=FileToSave, _
FileFormat:=ActiveWorkbook.FileFormat
End If
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
strbody = "Set Up Sheet" & " for " & Sheets("Set Up
Sheet").Range("c12").Value & " " & "has been created"
With wb
.SaveAs TempFilePath & TempFileName & FileExtStr,
FileFormat:=FileFormatNum
On Error Resume Next
.SendMail sh.Range("c21").Value, _
"This is the Subject line"
On Error GoTo 0
.Close SaveChanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
End If
Next sh
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub