D
DawnTreader
Hello
i need a little help with this code. it works fine except the second
spreadsheet isnt being attached to the email that is created. why?
Sub SaveWorkbook()
Dim USRNM As String
Dim SunDT As String
Dim strFName As String
Dim wsh As Object
Dim fs As Object
Dim DocPath As String
Dim DirString As String
Dim OutApp As Object
Dim OutMail As Object
Set wsh = CreateObject("WScript.Shell")
Set fs = CreateObject("Scripting.FileSystemObject")
DocPath = wsh.SpecialFolders.Item("mydocuments")
DirString = DocPath & "\TimeCards"
With ActiveSheet
USRNM = .Range("EmployeeName").Value
SunDT = Format(.Range("SundayDate").Value, "yy-dd-mmm")
If Trim(USRNM) = "" Or Trim(SunDT) = "" Then
MsgBox "Please add Employee Name and Sunday's Date" & vbLf &
"File not saved!"
TimeCardInfo.Show
Exit Sub
End If
'create a new workbook to email
With ActiveSheet
Sheets("Weekly Time Record").Select
Sheets("Weekly Time Record").Copy
'remove button and 2nd row in email version
ActiveSheet.Unprotect Password:="service"
ActiveSheet.DrawingObjects.Select
Selection.Delete
ActiveSheet.Rows(2).Delete
ActiveSheet.Protect Password:="service"
If Not fs.FolderExists(DirString) Then
fs.CreateFolder DirString
End If
strFName = "Time Card " & SunDT & " " & USRNM & ".xls"
.Parent.SaveAs DirString & "\" & strFName
'email the non VBA copy to the address using outlook 2003
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "(e-mail address removed)"
.CC = ""
.BCC = ""
.Subject = strFName
.Body = "Here is the time card for the period starting " &
SunDT
.Attachments.Add ActiveWorkbook.FullName
.Display
Application.Wait (Now + TimeValue("0:00:01"))
'use send button to cause the email to be sent
Application.SendKeys ("%(s)")
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End With
Application.Wait (Now + TimeValue("0:00:03"))
Application.Quit
End With
End Sub
i had originally had the code working a different way but it wouldnt remove
the button and 2nd row. this is the original code:
Sub SaveWorkbook()
Dim USRNM As String
Dim SunDT As String
Dim strFName As String
Dim wsh As Object
Dim fs As Object
Dim DocPath As String
Dim DirString As String
Dim OutApp As Object
Dim OutMail As Object
Set wsh = CreateObject("WScript.Shell")
Set fs = CreateObject("Scripting.FileSystemObject")
DocPath = wsh.SpecialFolders.Item("mydocuments")
DirString = DocPath & "\TimeCards"
With ActiveSheet
USRNM = .Range("EmployeeName").Value
SunDT = Format(.Range("SundayDate").Value, "yy-dd-mmm")
If Trim(USRNM) = "" Or Trim(SunDT) = "" Then
MsgBox "Please add Employee Name and Sunday's Date" & vbLf &
"File not saved!"
TimeCardInfo.Show
Exit Sub
Else
'create a new workbook to email
Sheets("Weekly Time Record").Select
Sheets("Weekly Time Record").Copy
'remove button and 2nd row in email version
ActiveSheet.Unprotect Password:="service"
ActiveSheet.DrawingObjects.Select
Selection.Delete
ActiveSheet.Rows(2).Delete
ActiveSheet.Protect Password:="service"
If Not fs.FolderExists(DirString) Then
fs.CreateFolder DirString
End If
strFName = "Time Card " & SunDT & " " & USRNM & ".xls"
ActiveWorkbook.Parent.SaveAs DirString & "\" & strFName
End If
'email the non VBA copy to the address using outlook 2003
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "(e-mail address removed)"
.CC = ""
.BCC = ""
.Subject = strFName
.Body = "Here is the time card for the period starting " & SunDT
.Attachments.Add ActiveWorkbook.FullName
.Display
Application.Wait (Now + TimeValue("0:00:01"))
'use send button to cause the email to be sent
Application.SendKeys ("%(s)")
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Application.Wait (Now + TimeValue("0:00:03"))
Application.Quit
End With
End Sub
i figured that the else part of the if wasnt really necessary so i moved it
out. but now it seems to create a new workbook then save another copy of the
original workbook then it goes to close the application and it asks me to
save the workbook which i copied the sheet to and removed the button and 2nd
row from, which wasnt attached to the email.
just typing this i think that i just need to check the timing of things, but
any help is still appreciated.
i need a little help with this code. it works fine except the second
spreadsheet isnt being attached to the email that is created. why?
Sub SaveWorkbook()
Dim USRNM As String
Dim SunDT As String
Dim strFName As String
Dim wsh As Object
Dim fs As Object
Dim DocPath As String
Dim DirString As String
Dim OutApp As Object
Dim OutMail As Object
Set wsh = CreateObject("WScript.Shell")
Set fs = CreateObject("Scripting.FileSystemObject")
DocPath = wsh.SpecialFolders.Item("mydocuments")
DirString = DocPath & "\TimeCards"
With ActiveSheet
USRNM = .Range("EmployeeName").Value
SunDT = Format(.Range("SundayDate").Value, "yy-dd-mmm")
If Trim(USRNM) = "" Or Trim(SunDT) = "" Then
MsgBox "Please add Employee Name and Sunday's Date" & vbLf &
"File not saved!"
TimeCardInfo.Show
Exit Sub
End If
'create a new workbook to email
With ActiveSheet
Sheets("Weekly Time Record").Select
Sheets("Weekly Time Record").Copy
'remove button and 2nd row in email version
ActiveSheet.Unprotect Password:="service"
ActiveSheet.DrawingObjects.Select
Selection.Delete
ActiveSheet.Rows(2).Delete
ActiveSheet.Protect Password:="service"
If Not fs.FolderExists(DirString) Then
fs.CreateFolder DirString
End If
strFName = "Time Card " & SunDT & " " & USRNM & ".xls"
.Parent.SaveAs DirString & "\" & strFName
'email the non VBA copy to the address using outlook 2003
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "(e-mail address removed)"
.CC = ""
.BCC = ""
.Subject = strFName
.Body = "Here is the time card for the period starting " &
SunDT
.Attachments.Add ActiveWorkbook.FullName
.Display
Application.Wait (Now + TimeValue("0:00:01"))
'use send button to cause the email to be sent
Application.SendKeys ("%(s)")
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End With
Application.Wait (Now + TimeValue("0:00:03"))
Application.Quit
End With
End Sub
i had originally had the code working a different way but it wouldnt remove
the button and 2nd row. this is the original code:
Sub SaveWorkbook()
Dim USRNM As String
Dim SunDT As String
Dim strFName As String
Dim wsh As Object
Dim fs As Object
Dim DocPath As String
Dim DirString As String
Dim OutApp As Object
Dim OutMail As Object
Set wsh = CreateObject("WScript.Shell")
Set fs = CreateObject("Scripting.FileSystemObject")
DocPath = wsh.SpecialFolders.Item("mydocuments")
DirString = DocPath & "\TimeCards"
With ActiveSheet
USRNM = .Range("EmployeeName").Value
SunDT = Format(.Range("SundayDate").Value, "yy-dd-mmm")
If Trim(USRNM) = "" Or Trim(SunDT) = "" Then
MsgBox "Please add Employee Name and Sunday's Date" & vbLf &
"File not saved!"
TimeCardInfo.Show
Exit Sub
Else
'create a new workbook to email
Sheets("Weekly Time Record").Select
Sheets("Weekly Time Record").Copy
'remove button and 2nd row in email version
ActiveSheet.Unprotect Password:="service"
ActiveSheet.DrawingObjects.Select
Selection.Delete
ActiveSheet.Rows(2).Delete
ActiveSheet.Protect Password:="service"
If Not fs.FolderExists(DirString) Then
fs.CreateFolder DirString
End If
strFName = "Time Card " & SunDT & " " & USRNM & ".xls"
ActiveWorkbook.Parent.SaveAs DirString & "\" & strFName
End If
'email the non VBA copy to the address using outlook 2003
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "(e-mail address removed)"
.CC = ""
.BCC = ""
.Subject = strFName
.Body = "Here is the time card for the period starting " & SunDT
.Attachments.Add ActiveWorkbook.FullName
.Display
Application.Wait (Now + TimeValue("0:00:01"))
'use send button to cause the email to be sent
Application.SendKeys ("%(s)")
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Application.Wait (Now + TimeValue("0:00:03"))
Application.Quit
End With
End Sub
i figured that the else part of the if wasnt really necessary so i moved it
out. but now it seems to create a new workbook then save another copy of the
original workbook then it goes to close the application and it asks me to
save the workbook which i copied the sheet to and removed the button and 2nd
row from, which wasnt attached to the email.
just typing this i think that i just need to check the timing of things, but
any help is still appreciated.