LinkBack URL
About LinkBacksI have some code from Ron's site that WAS working, but now is NOT attaching
a file to the email when I added some code. I am creating the zip file, but
also another file with an "E" attached that I want to use as the attachment
instead of the zip file.
The email is created and sent, but without the file attached. Could someone
review the code and try to determine what the issue is? Thanks much!
Hey Ron...if you get this..flying to Amsterdam today..do you live close...I
might like to take you out for a drink!
Here's my code:
Sub ZipMailWithDeleteOption()
Dim strDate As String, DefPath As String, strbody As String
Dim oApp As Object, OutApp As Object, OutMail As Object
Dim FileNameZip, FileNameXls, FileNameEmail
Dim password As String
'Checks to See If A Directory Exists, If Not, Creates It
MyDirectory = ActiveWorkbook.Path & "\" & "Zipped Reports"
DirTest = Dir$(MyDirectory, vbDirectory)
If DirTest = "" Then
MkDir MyDirectory
DoEvents 'just to make sure it is there
End If
ChDir MyDirectory
DefPath = MyDirectory
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
strDate = Format(Now, " dd-mmm-yy h-mm-ss")
'Create the temporary xls file and zip file name
FileNameZip = DefPath & Left(ActiveWorkbook.Name,
Len(ActiveWorkbook.Name) - 4) & ".zip"
FileNameXls = DefPath & Left(ActiveWorkbook.Name,
Len(ActiveWorkbook.Name) - 4) & "Z" & ".xls"
FileNameEmail = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4)
& "E" & ".xls"
If Dir(FileNameZip) = "" And Dir(FileNameXls) = "" Then
'Make a copy of the activeworkbook
ThisWorkbook.SaveCopyAs FileNameEmail
'ThisWorkbook.Activate
ThisWorkbook.SaveCopyAs FileNameXls
'Create empty Zip File
NewZip (FileNameZip)
'Copy the xls file into the compressed folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameZip).CopyHere FileNameXls
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(FileNameZip).items.Count = 1
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
ChDir MyDirectory
'INSERT EMAIL CODE HERE!
'Create the mail
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "Attached is our Big Picture Report" & vbNewLine &
vbNewLine & _
strDate & vbNewLine & _
"" & vbNewLine & _
"Have a Nice Day!" & vbNewLine & _
""
On Error Resume Next
With OutMail
.To = "[email protected]"
.CC = ""
.BCC = ""
.Subject = FileNameEmail
'.Subject = FileNameXls
.Body = strbody
.Attachments.Add FileNameEmail
.Send 'or use .Display
'.Display
Application.Wait (Now + TimeValue("0:00:02"))
Application.SendKeys "%S"
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Set oApp = Nothing
'Delete the temporary xls file
Kill FileNameXls
Kill FileNameEmail
ThisWorkbook.Activate
MsgBox "Your Zipfile is Stored Here: " & FileNameZip
Call CapturePlumberData
Msg = "Do You Want to Delete This File and Keep Only the Zip File?"
Ans = MsgBox(Msg, vbYesNo)
If Ans = vbYes Then Call DeleteThisFile
Else
MsgBox "A ZipFile With This File Name Already Exist." & Chr(10) _
& "Delete It and Try Again!"
End If
Application.ScreenUpdating = False
Application.ThisWorkbook.Activate
Worksheets("Global Setup").Select
Range("CA3").Select
password = Range("CA3").Value
Range("L5").Select
Worksheets("Team Scorecard").Activate
Application.ThisWorkbook.Unprotect (password)
ActiveSheet.Unprotect (password)
Application.ScreenUpdating = True
ActiveSheet.Shapes("Button 28").Select
Selection.Characters.Text = "File Zipped" & Chr(10) & "& Mailed"
With Selection.Characters(Start:=1, Length:=10).Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 5
End With
Range("A1").Select
ActiveSheet.Protect (password)
Application.ThisWorkbook.Protect (password), structure:=True
End Sub
Thanks!
Register To Reply
Bookmarks