Solved: auto email 2 sheets on workbook close, timing problem

[mperrah]

I'm trying to send 2 sheets automaticaly on workbook close event.
I was sending on a worksheet_change but was sending with every change.
On wb close makes more sense, but I'm having problem with the timing.

To get a pause I was tryin a msgBox with yes or no to send the first sheet, then a yes or no for the second sheet.
Then after sending o, 1, or 2 sheets the book is to save and close.
The autosend for the email is prompting for the To feild to be entered,
then the book closes before allowing an entry....

when I reopen the book is waiting for the to send still, but only one sheet.

This is on a command button.
Sub emailBeforeClose()
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Msg = "Email Inventory Warning?" ' Define message.
Style = vbYesNo + vbCritical + vbDefaultButton2 ' Define buttons.
Title = "Save and Close" ' Define title.
Help = ""
Ctxt = 1000
' if parts below 5 send email on close
Worksheets("Parts").Activate
With Worksheets("Parts")
Dim partsChanged As Range

Set partsChanged = Range("H1")

If Not partsChanged.Value = 0 Then

Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then ' User chose Yes.
MyString = "Yes"
Worksheets("Parts").Activate
Call AutoSend
Application.Wait (Now + TimeValue("0:00:05"))
GoTo testrcvrs
Else ' User chose No.
MyString = "No"
GoTo testrcvrs
End If

Else

GoTo testrcvrs

End If
End With

testrcvrs:

' send email on close if receiver over 15 days old
Worksheets("Receivers").Activate
With Worksheets("Receivers")
Dim rcvrsChanged As Range

Set rcvrsChanged = Range("H1")

If Not rcvrsChanged.Value = 0 Then

If Response = vbYes Then ' User chose Yes.
MyString = "Yes"
Worksheets("Receivers").Activate
Call AutoSend
Application.Wait (Now + TimeValue("0:00:05"))
GoTo subExit
Else ' User chose No.
MyString = "No"
GoTo subExit
End If

Else

GoTo subExit

End If
End With
subExit:
Application.Wait (Now + TimeValue("0:00:05"))
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub


This is in the thisworkbook code section:
Private Sub Workbook_Open()
Dim NewButton As CommandBarButton
'---------------------------------------------------------------------------
'//delete any pre-existing instance of the toolbar & buttons\\
On Error Resume Next
Run ("DeleteToolbar")
Call DeleteAddedButtons
'---------------------------------------------------------------------------
'//add a button as the second-last item on the main menu bar\\
Set NewButton = Application.CommandBars("Worksheet Menu Bar") _
.Controls.Add(Type:=msoControlButton)
With NewButton
.Caption = "&Email Active Sheet"
.OnAction = "SendActiveSheet"
.TooltipText = "Email Active Sheet in Body"
.Style = msoButtonIconAndCaption
.FaceId = 24
End With
Set NewButton = Nothing
'---------------------------------------------------------------------------
'//add a button as the last item on the main menu bar\\
Set NewButton = Application.CommandBars("Worksheet Menu Bar") _
.Controls.Add(Type:=msoControlButton)
With NewButton
.Caption = "Cancel &Email"
.OnAction = "EscapeProcedure"
.TooltipText = "Return to normal window"
.Style = msoButtonIconAndCaption
.FaceId = 51
.Enabled = False
End With
Set NewButton = Nothing
'---------------------------------------------------------------------------
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
' '---------------------------------------------------------------------------
' '//delete any pre-existing instance(s) of the toolbars\\
On Error Resume Next
Run ("DeleteToolbar")
Call DeleteAddedButtons
'---------------------------------------------------------------------------

End Sub
Private Sub DeleteAddedButtons()
' '---------------------------------------------------------------------------
' '//delete the main menu buttons\\
On Error Resume Next
With Application.CommandBars("Worksheet Menu Bar")
.Controls("Email Active Sheet").Delete
.Controls("Cancel &Email").Delete
End With
'---------------------------------------------------------------------------
End Sub



I only send to to one recipient (alwayse the same)
and the sheets I send are the same sheets (with changing values)
I test if the values for cell H1 of each sheet have changed to validate the send.

Tried adding a timer to allow for the to box of the email to be entered.
Thought of a modal user form..
The first email gets intrupted every time...

Not sure what I'm missing.

any ideas are greatly appreciated.
Mark

[Zack Barresse]

There are some things in your code above that you could tidy up, i.e. explicitly referencing your range objects. You do not do this, I recommend you do. For example, you have this snip of code...

With Worksheets("Parts")
Dim partsChanged As Range

Set partsChanged = Range("H1")
When using the With statement, you're not taking advantage of it if you are not putting a period prior to your Range statement. You should be using more like this ...
With Worksheets("Parts")
Dim partsChanged As Range

Set partsChanged = .Range("H1")
Notice the period? Now that range is part of the "Parts" worksheet. If not, it will set partChanged variable as H1 of the ActiveSheet, which could be detrimental.

Also, we don't see AutoSend??? I'm assuming this is the routine called to email the current sheet. I would suggest copying the worksheet to a new file, temporarily saving it, creating an Outlook mail item (assuming you use Outlook) and attaching the mail item.

Now, if you want to send automatically you'll need something besides Outlook. There are third party programs (the one I use is Express ClickYes) which can Send and bypass the Outlook security warnings that a program is trying to send an email on the mail clients behalf. Ken Puls has a good example of manipulating ClickYes via VBA on his site (excelguru.ca) and I've posted a few examples at TSG (http://forums.techguy.org/business-applications/).

HTH

[mperrah]

I have tried 3 different formats to try getting the sheet in the body of an email.
I have outlook, outlook express, and can use either.
I found could using CDO and another using MSO
At one point I think the security warnings stopped me. So I tried another...

The one that worked the best uses a function to copy the active range to html and save a temp file,
then send that file and delete

here is the range to html:
Function RangetoHTML(rng As Range)

Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With

'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With

'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")

'Close TempWB
TempWB.Close savechanges:=False

'Delete the htm file we used in this function
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function


I was using these 2 pieces to set up the email:
one for parts and one for receivers, because they don't always both get sent.
Option Explicit

Sub CDO_Send_PartsLow_Body()
Dim rng As Range
Dim iMsg As Object
Dim iConf As Object
' Dim Flds As Variant

Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")

' iConf.Load -1 ' CDO Source Defaults
' Set Flds = iConf.Fields
' With Flds
' .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
' .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "Fill in your SMTP server here"
' .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
' .Update
' End With


Set rng = Nothing
On Error Resume Next

Set rng = Worksheets("Parts").UsedRange
' Set rng = Selection.SpecialCells(xlCellTypeVisible)

On Error GoTo 0

If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If

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

With iMsg
Set .Configuration = iConf
.To = "mark_perrah@yahoo.com" 'kewbinc@yahoo.com
.CC = ""
.BCC = ""
.From = """Mark"" <mark_perrah@yahoo.com>"
.Subject = "Inventory Low Warning!"
.HTMLBody = RangetoHTML(rng)
.Send
End With

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

End Sub


Sub CDO_Send_Rcvr15_Body()
Dim rng As Range
Dim iMsg As Object
Dim iConf As Object
' Dim Flds As Variant

Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")

' iConf.Load -1 ' CDO Source Defaults
' Set Flds = iConf.Fields
' With Flds
' .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
' .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "Fill in your SMTP server here"
' .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
' .Update
' End With


Set rng = Nothing
On Error Resume Next

Set rng = Worksheets("Receivers").UsedRange
' Set rng = Selection.SpecialCells(xlCellTypeVisible)

On Error GoTo 0

If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If

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

With iMsg
Set .Configuration = iConf
.To = "mark_perrah@yahoo.com"
.CC = ""
.BCC = ""
.From = """Mark"" <mark_perrah@yahoo.com>"
.Subject = "Receiver over 15 days!"
.HTMLBody = RangetoHTML(rng)
.Send
End With

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

End Sub


I altered the code from this to another because I could not control
the sequence the emails were sent.
This was at one point ran when a sheet value (H1) changed
as a result of another sub (many things tied together...)

This method was sending 15 emails an hour, instead only one a day are necessary.
So I was changing the sub to run on workbook close.
The other code asked for the sender to be entered but would
close before I could type it in.
I'm not opn my main pc, so I don't have the most updated here.
I'll get on that one and post what exactly I had..
I was excited to see help..
Mark

[mperrah]

here is the other piece, sorry so big
' '<<--------------------<< MODULE1 CODE >>-------------------->>
Option Explicit

Sub SendActiveSheet()
' '---------------------------------------------------------------------------
' '//no need for toolbar if book's marked "NeverShow" - check\\
With ActiveWorkbook
Select Case .BuiltinDocumentProperties("Comments")
Case "NeverShow"
Call AutoSend
Exit Sub '< end this procedure right here
Case "Initialized"
'//if not already in email mode build the toolbar\\
If Not .EnvelopeVisible Then GoSub BuildToolbar
Case Else
If Not .EnvelopeVisible Then
.BuiltinDocumentProperties("Comments") = "FirstTime"
GoSub BuildToolbar
End If
End Select
Exit Sub
End With
'---------------------------------------------------------------------------
BuildToolbar:
'//the toolbar's needed, create it\\
Dim FloatingBar As CommandBar
Dim NewButton As CommandBarButton
'---------------------------------------------------------------------------
'//delete any pre-existing instance of the toolbar\\
On Error Resume Next '< error = no bar to delete
Call DeleteToolbar
On Error GoTo 0 '< cancel error trapping
'---------------------------------------------------------------------------
'//create floating command bar\\
Set FloatingBar = CommandBars.Add
With FloatingBar
.Name = "Email Activesheet in Body of Email"
.Position = msoBarFloating
.Visible = True
.Top = 200
.Left = 200
End With
'---------------------------------------------------------------------------
'//add buttons to the command bar\\
Set NewButton = FloatingBar.Controls.Add(Type:=msoControlButton)
With NewButton
.Caption = "CANCEL"
.OnAction = "ExitSub"
.TooltipText = "Click to cancel operation"
.Style = msoButtonIconAndWrapCaptionBelow
.FaceId = 463
End With

With ActiveWorkbook
'//----------------------------------------------------------\\
'(this button not needed the very first time the code is executed)
If .BuiltinDocumentProperties("Comments") = "Initialized" Then
Set NewButton = FloatingBar.Controls.Add(Type:=msoControlButton)
With NewButton
.Caption = "Send the active sheet to the same recipients as last time..."
.TooltipText = "Use the same email addresses"
.OnAction = "AutoSend"
.Style = msoButtonIconAndWrapCaptionBelow
.FaceId = 45
End With
End If
'\\----------------------------------------------------------//

Set NewButton = FloatingBar.Controls.Add(Type:=msoControlButton)
With NewButton
.Caption = "Send the active sheet to some new recipients"
.TooltipText = "Don't use the same email addresses"
.OnAction = "ManualSend"
.Style = msoButtonIconAndWrapCaptionBelow
.FaceId = 24
End With

'//----------------------------------------------------------\\
'(this button not needed the very first time the code is executed)
If .BuiltinDocumentProperties("Comments") = "Initialized" Then
Set NewButton = FloatingBar.Controls.Add(Type:=msoControlButton)
With NewButton
.Caption = "I'm not sure who the active sheet was sent to last time. Show me.."
.TooltipText = "Show me the last recipients"
.OnAction = "ManualSend"
.Style = msoButtonIconAndWrapCaptionBelow
.FaceId = 487
End With
End If
'\\----------------------------------------------------------//

Set NewButton = FloatingBar.Controls.Add(Type:=msoControlButton)
With NewButton
.Caption = "ALWAYS send the active sheet to these recipients and NEVER show me this toolbar again!"
.TooltipText = "Automate this operation"
.OnAction = "NeverShowAgain"
.Style = msoButtonIconAndWrapCaptionBelow
.FaceId = 536
End With
End With '< With ActiveWorkbook

Set FloatingBar = Nothing
Set NewButton = Nothing
'---------------------------------------------------------------------------
End Sub


Sub AutoSend()
' '---------------------------------------------------------------------------
' '//delete the toolbar and send\\
Call DeleteToolbar
DoEvents '< allow a repaint
'---------------------------------------------------------------------------
'//send the sheet\\
With Application
.ScreenUpdating = False
On Error Resume Next
With .CommandBars("Send To")
'//IF the control "Send Now" is missing the code will error out, so add it\\
.Controls.Add Type:=msoControlButton, ID:=3708
.Controls("Mail Recipient").Execute
DoEvents
With .Controls("Send Now")
'//sends activesheet in email body\\
.Execute
'//remove the "Send Now" control added for this procedure\\
.Delete
End With
End With
.ScreenUpdating = True
End With
'---------------------------------------------------------------------------
End Sub


Sub ManualSend()
Call DeleteToolbar
DoEvents
'----------------------------------------------------------------------
'//change properties & execute\\
With ActiveWorkbook

If .BuiltinDocumentProperties("Comments") = "FirstTime" Then
.BuiltinDocumentProperties("Comments") = "Initialized"
Application.DisplayAlerts = False
.Save
Application.DisplayAlerts = True
'//show the mail window\\
.EnvelopeVisible = True
'//wait for the mail window to appear\\
Do Until .EnvelopeVisible
Loop
'//(don't enable the 'Cancel' button - it doesn't work for this instance)\\
'//give basic instructions for first timers\\
MsgBox "Enter recipients in the 'To:' field then click" & vbNewLine & _
"the ''Send this Sheet'' button on the left..." & vbNewLine & _
"" & vbNewLine & _
"(Note: For this time only, to cancel email go" & vbNewLine & _
"to 'File' - 'Send To' and click 'Mail Recipient')", , "INSTRUCTIONS..."
Else
'//show the mail window\\
.EnvelopeVisible = True
'//wait for the mail window to appear\\
Do Until .EnvelopeVisible
Loop
'//now enable the 'Cancel' button\\
Application.CommandBars("Worksheet Menu Bar").Controls("Cancel &Email").Enabled = True
End If

End With
'----------------------------------------------------------------------
End Sub


Sub NeverShowAgain()
Call DeleteToolbar
'---------------------------------------------------------------------------
'//Mark workbook so as to never show the toolbar, save and send the sheet\\
With ActiveWorkbook
Select Case .BuiltinDocumentProperties("Comments")
Case "FirstTime"
.BuiltinDocumentProperties("Comments") = "Initialized"
'//save the changed property\\
Application.DisplayAlerts = False
.Save
Application.DisplayAlerts = True
Call AutoSend ' manual send
Case "Initialized"
.BuiltinDocumentProperties("Comments") = "Initialized"
'//save the changed property\\
Application.DisplayAlerts = False
.Save
Application.DisplayAlerts = True
Call AutoSend
End Select
End With
'---------------------------------------------------------------------------
End Sub


Private Sub ExitSub()
' '//Just delete the toolbar\\
Call DeleteToolbar
End Sub


Private Sub DeleteToolbar()
' '---------------------------------------------------------------------------
' '//delete the added toolbar\\
On Error Resume Next
Application.CommandBars("Email Activesheet in body of email").Delete
'---------------------------------------------------------------------------
End Sub


Private Sub EscapeProcedure()
' '---------------------------------------------------------------------------
' '//close the email window if visible\\
ActiveWorkbook.EnvelopeVisible = False
'//disable the cancel email button (visible or not)\\
Application.CommandBars("Worksheet Menu Bar").Controls("Cancel &Email").Enabled = False
'---------------------------------------------------------------------------
End Sub

[mperrah]

Here is the latest
Using Outlook express as the default seems to work ok,
The user liked an attachment rather then sheet in body of email.
Working now on if formulae gets removed from receivers, replace auto maticaly


' this part is not working
Dim formulaFix As Range
Dim lRow As Long
With Worksheets("Receivers")
lRow = .Range("A2:A" & Rows.Count).End(xlUp).Row + 1
Set formulaFix = .Range("E2:E" & lRow)
If Target.Row > 1 And Target.Column = 3 Then
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, formulaFix) Is Nothing Then
.Range("E2").Formula = "=IF(D2="""","""",D2+30)"
.Range("E2:E" & lRow).FillDown
ElseIf Target.Value = "" Then
End If
End If
End With
End Sub
'

' I have this one on another sheet working
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim formulaFix As Range
Set formulaFix = Range("C6:C25")
If Target.Row > 5 And Target.Row < 26 And _
Target.Column = 3 Then
If Target.Cells.Count > 20 Then Exit Sub
If Not Intersect(Target, formulaFix) Is Nothing Then
With Worksheets("Invoice")
.Range("C6").Formula = "=IF(B6="""","""",VLOOKUP(B6, partsOnhand, 4))"
.Range("C6:C25").FillDown
End With
ElseIf Target.Value = "" Then

End If
End If
End Sub