Send email in a different way

[HammerJoe]

Hi,

I would like to be able to send a sheet by email.

I dont like the idea of having to copy a new sheet and then save it on
disk (due to space constraints) to be able to call the .sendmail, I
decided to go in a simpler way that gives the user the task of
emailing the sheet using the file-send to-mail recipient menu options.

To do this I hide all the sheets except the one that needs to be
emailed so the user cannot do anything else on the workbook and add
(show, it stays hidden all the time) a button that the user clicks to
confirm that they have emailed the sheet and once clicked shows all
the sheets again and proceeds with the code.

To do this I have a "do while loop" with DoEvent waiting for a cell
range to change value which it does when the button is clicked.

Afterwards the button is hidden again.

It works great, but theres one problem.
It works if the sheet is unprotected.
If it is protected then using "mail recipient" doesnt work and I want
that to work and to keep the sheet protected.

I thought of borrowing the .sendmail idea, create a new workbook, copy
the sheet to the new workbook, add the button and wait for it be
clicked and then close it.

How can I add a button (and a label) to the new created workbook and
wait for it to be clicked and then close the newly opened workbook
without confirmation and resume the code?

Thanks for all the help.

 

[HammerJoe]

Here is what I come up with, need opinions on how to improve it:

Public Sub SendEmail()
Dim Msg As String
Dim Ws As Worksheet
Dim NewWs As Worksheet
ThisWorkbook.Sheets("Week_to_date").Unprotect ("XXX")
ThisWorkbook.Sheets("MonthlyTrack").Unprotect ("XXX")
If ThisWorkbook.Sheets("MonthlyTrack").Range("L20").Value = True Then
'Hide all sheets
For Each Ws In Worksheets
If Ws.Name <> "Week_to_date" Then
Ws.Visible = xlSheetHidden
End If
Next Ws
'///
Dim TmpWb As String
Dim btn As Button, Lbl As msforms.Label
Worksheets.Add
ThisWorkbook.ActiveSheet.Name = "Weekly Report"
ThisWorkbook.Sheets("Week_to_date").Select
Range("A1:C18").Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Weekly Report").Activate
Sheets("Weekly Report").Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths,
Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

Sheets("Week_to_date").Select
ActiveSheet.ChartObjects("Chart 1026").Activate
ActiveChart.ChartArea.Select
Application.CutCopyMode = False
ActiveChart.ChartArea.Copy
'ActiveWindow.Visible = False
Sheets("Weekly Report").Activate
Range("A3").Select
ActiveSheet.Paste
ActiveSheet.ChartObjects("Chart 1").Activate

Range("A3").Select
Set NewWs = ActiveSheet

With NewWs

NewWs.Range("B23") = "Select 'File'-'Send To'-'Mail Recipient' in
the Excel Menu."
NewWs.Range("B24") = "*Warning* Once this file is saved, all
previous week results will be lost!"
NewWs.Range("B26") = "Press the button below after you have sent
the email..."
Range("B21:B26").Select
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With

Set btn = NewWs.Buttons.Add(65.25, 462.75, 296.25, 32.25)
btn.Select
Selection.Characters.Text = "Yes, I understand!"
With Selection
.Font.Name = "Arial"
.Font.FontStyle = "Bold"
.Font.Size = 10
.Font.ColorIndex = xlAutomatic
.Locked = True
.LockedText = True
End With
btn.OnAction = "CommandButtonSendEmail"
End With

ThisWorkbook.Sheets("Week_to_date").Visible = xlSheetHidden

'Wait for user to send email
ThisWorkbook.Sheets("MonthlyTrack").Range("L21").Value = False
NewWs.Activate
NewWs.Range("A1").Select
Do While ThisWorkbook.Sheets("MonthlyTrack").Range("L21").Value =
False
DoEvents
Loop
ThisWorkbook.Sheets("Week_to_date").Visible = xlSheetVisible
Application.DisplayAlerts = False
NewWs.Delete
Application.DisplayAlerts = True
End If


'Show all sheets again
For Each Ws In Worksheets
Ws.Visible = xlSheetVisible
Next Ws
ThisWorkbook.Sheets("Week_to_date").Protect ("xxx")
Sheets("main").Activate
Sheets("main").Range("A1").Select
End Sub

Public Sub CommandButtonSendEmail()
ThisWorkbook.Sheets("MonthlyTrack").Range("L21").Value = True
End Sub

 

[HammerJoe]

No comments on this?