pause excel VBA until user saves a copy of a file - excel

What is the correct syntax for pausing a VBA until the user saves an excel attachment? In the VB below the user is prompted upon opening the workbook with a selection, if that selection is yes then another message box appears asking them to fill out a form and save. I am trying to pause the VB until save is clicked. However, I am getting many compile errors currently. The lines with a ** ** were added to try and accomplish thisThank you :).
VB
Private Sub Workbook_Open()
Dim WS As Worksheet, Rng As Range, c As Range
Dim OutApp As Object, OutMail As Object
Dim Msg As String, Addr As String, FName As String, i As Long
Dim obj As Object
**Dim MyDoc As Document**
Dim MyFileCopy As String
Dim intAnswer As Integer
'define path
MyFileCopy = "L:\NGS\HLA LAB\total quality management\QC & QA\DOSE reports\DOSE reporting form Attachment.xlsx"
'open sheet
Sheets("Email").Activate
intAnswer = MsgBox("Are there any issues to report", vbYesNoCancel)
Select Case intAnswer
Case vbYes
Range("D2").Value = "x"
MsgBox ("Please select an issue and save"), vbExclamation
'create a separate sheet2 to mail out and pause VB
Sheets(2).Copy
Set wkb = ActiveWorkbook
With wkb
**Set MyDoc = Documents.Add
MyDoc.SaveAs "MyFileCopy.xlsx"
DoEvents
Do
Loop Until MyDoc.Saved
.Close True**
End With
Case vbCancel
Application.SendKeys "%{F11}", True
Case Else
Range("C2").Value = "x"
End Select
'create connection, check condition, send email
Set OutApp = CreateObject("Outlook.Application")
Set WS = ThisWorkbook.Sheets("Email")
With WS
Set Rng = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
End With
For Each c In Rng
Msg = "For " & WS.Cells(2, 2) & Chr(14) & Chr(14)
For i = 3 To 4
If LCase(WS.Cells(2, i)) = "x" Then
Msg = Msg & " -" & WS.Cells(1, i) & Chr(14)
End If
Next
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = c
.CC = ""
.BCC = ""
.Subject = "Daily Operational Safety Briefing"
.Body = Msg
If Range("D2").Value & Chr(14) = "x" Then .Attachments.Add MyFileCopy, 1
.Send
End With
Next c
Set OutMail = Nothing
Set OutApp = Nothing
'confirm message sent, clear sheet, and delete copy
MsgBox "The data has been emailed sucessfully.", vbInformation
Range("C2:D2").ClearContents
Kill MyFileCopy
'Exit and do not save
Application.Quit
ThisWorkbook.Close SaveChanges:=False
End Sub

Related

How to turn off read only mode when a workbook is opened?

I have a macro attached to a shared file which I scheduled to run every day. It doesn't save the workbook on completion.
I believe this is because the shared document opens in read only mode.
The macro searches cell values and if they meet the relevant conditions, the cell is highlighted red and the text inside the cell is replaced. The macro is set to save at the end.
Public Sub SendEmailReminder2()
Dim lSecurity As Long
lSecurity = Application.AutomationSecurity
'so the workbook doesn't open in protected view
Application.AutomationSecurity = msoAutomationSecurityLow
Dim x As Long
Dim c As Range
Dim OutApp As Object
Dim strbody As String
Dim wb As Workbook
Set wb = Workbooks.Open("insert file path")
Set c = Range("C2")
'loop while cell is not empty
Do While Len(c.Value) > 0
If c.Value <= Date - 45 Then
c.Interior.Color = vbRed
c.Offset(0, -1).Interior.Color = vbRed
c.Offset(0, -2).Interior.Color = vbRed
c.Value = "Email Sent " & Date
'build the message
strbody = strbody & vbCrLf & c.Offset(0, -2) & " - " & _
c.Offset(0, -1) & " needs to be removed from New Releases"
End If
Set c = c.Offset(1, 0) 'next cell
Loop
Set OutApp = CreateObject("Outlook.Application")
On Error Resume Next
With OutApp.CreateItem(0)
.To = ""
.CC = ""
.BCC = ""
.Subject = ""
.Body = strbody
.Send 'or use .Send
End With
On Error GoTo 0
Set OutApp = Nothing
Application.DisplayAlerts = False
wb.Save
Application.DisplayAlerts = True
Application.AutomationSecurity = lSecurity
End Sub
Try accessing the relevant parameters in the .Open method (full list of parameters found here)
Dim fn As String
fn = "insert file path"
Set wb = Workbooks.Open(Filename:=fn, _
ReadOnly:=False, _
IgnoreReadOnlyRecommended:=True)

How to attach an Excel sheet to an Outlook email?

I'm trying to fix one issue which is attaching a file.
I have a TABLE with list of people and their names and a condition(Y/N) column.
Column 1(Name) Column 2(Email) Column 3 (Condition Y/N)
I want to send emails to all people in the TABLE whose name matches with the unique values (name) in one of the columns in Sheet 1.
So I want something that looks up the column in Sheet 1 and maybe changes the Condition to Y in the TABLE for all unique names found in that Column in Sheet 1.(I can FILTER my TABLE in POWER QUERY to show only the rows with Condition "Y").
When the SINGLE email pops up (with the all people in the "To",) I want Sheet 1 or Sheet 2 to be attached to the email.
Option Explicit
Public Sub SendEmail()
' For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
' Working in Office 2000-2016
' Adapted by Ricardo Diaz ricardodiaz.co
Dim OutApp As Object
Dim OutMail As Object
Dim sourceTable As ListObject
Dim evalRow As ListRow
Dim counter As Long
Dim toArray() As Variant
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set sourceTable = Range("Table6").ListObject ' -> Set the table's name
On Error GoTo cleanup
' Loop through each table's rows
For Each evalRow In sourceTable.ListRows
If evalRow.Range.Cells(, 2).Value Like "?*#?*.?*" And _
LCase(evalRow.Range.Cells(, 3).Value) = "yes" Then
ReDim Preserve toArray(counter)
toArray(counter) = evalRow.Range.Cells(, 2).Value
counter = counter + 1
End If
Next evalRow
' Setup the email
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
' Add gathered recipients
For counter = 0 To UBound(toArray)
.Recipients.Add (toArray(counter))
Next counter
.Subject = "Reminder"
.Body = "Dear All" _
& vbNewLine & vbNewLine & _
"Please comply with the transfers in the attached file. " & _
"Look up for your store and process asap."
'You can add files also like this
'.Attachments.Add ("C:\test.txt") ' -> Adjust this path
.Display ' -> Or use Display
End With
On Error GoTo 0
Set OutMail = Nothing
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Code to Attach sheet 1 (doesn't work)
file_name_import = Format(Now, "yyyy-mm-dd hh-mm-ss")
file_name_import = file_name_import & " - File 1.xlsx"
Worksheets("Sheet 1").Copy
ChDir "H:\Folder 1\Folder 2\Folder 3\Folder 4\"
ActiveWorkbook.SaveAs Filename:= _
"H:\Folder 1\Folder 2\Folder 3\Folder 4\File 1" & file_name_import, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
.Attachments.Add "H:\Folder 1\Folder 2\Folder 3\Folder 4\File 1\" & file_name_import
I want to add code so my email pops up (with all required people in "To" and) with the attachment.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
Public Sub AttachFileToEmail()
Dim OutApp As Object
Dim OutMail As Object
Dim sourceTable As ListObject
Dim evalRow As ListRow
Dim counter As Long
Dim toArray() As Variant
Dim strDir As String
Dim file_name_import As String
Dim fName As String
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
' Excel details not recreated, not needed for this question
file_name_import = Format(Now, "yyyy-mm-dd hh-mm-ss")
file_name_import = file_name_import & " - File 1.xlsx"
' Subscript out of range error would be bypassed due to poor error handling
'Worksheets("Sheet 1").Copy
Worksheets("Sheet1").Copy
' Trailing backslash error would be bypassed due to poor error handling
'ChDir "H:\Folder 1\Folder 2\Folder 3\Folder 4\"
strDir = "C:\Folder 1\Folder 2\Folder 3\Folder 4\"
Debug.Print strDir
' Backslash already at end of strDir
fName = strDir & "File 1" & file_name_import
Debug.Print fName
ActiveWorkbook.SaveAs FileName:=fName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
' Setup the email
Set OutMail = OutApp.CreateItem(0)
' Do not use On Error Resume Next without a specific reason for bypassing errors
' Instead fix the errors now that you can see them
With OutMail
' Excel details not recreated, not needed for this question
.Subject = "Reminder"
.Body = "Dear All" _
& vbNewLine & vbNewLine & _
"Please comply with the transfers in the attached file. " & _
"Look up for your store and process asap."
.Attachments.Add fName
.Display
End With
Set OutMail = Nothing
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
The idea here is to copy the sheet to a new file and save it in you temp folder. Then attach it to your email
Option Explicit
Public Sub SendEmail()
' For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
' Working in Office 2000-2016
' Attachment code based on: http://www.vbaexpress.com/kb/getarticle.php?kb_id=326
' Adapted by Ricardo Diaz ricardodiaz.co
Dim OutApp As Object
Dim OutMail As Object
Dim sourceTable As ListObject
Dim evalRow As ListRow
Dim newBook As Workbook
Dim newBookName As String
Dim counter As Long
Dim toArray() As Variant
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set sourceTable = Range("Table1").ListObject
On Error GoTo Cleanup
' Save current file to temp folder (delete first if exists)
ThisWorkbook.Worksheets("Sheet1").Copy
Set newBook = ActiveWorkbook
newBookName = "AttachedSheet.xlsx"
On Error Resume Next
Kill Environ("temp") & newBookName
On Error GoTo 0
Application.DisplayAlerts = False
newBook.SaveAs Environ("temp") & newBookName
Application.DisplayAlerts = True
' Loop through each table's rows
For Each evalRow In sourceTable.ListRows
If evalRow.Range.Cells(, 2).Value Like "?*#?*.?*" And LCase(evalRow.Range.Cells(, 3).Value) = "yes" Then
ReDim Preserve toArray(counter)
toArray(counter) = evalRow.Range.Cells(, 2).Value
counter = counter + 1
End If
Next evalRow
' Setup the email
Set OutMail = OutApp.CreateItem(0)
With OutMail
' Add gathered recipients
For counter = 0 To UBound(toArray)
.Recipients.Add (toArray(counter))
Next counter
.Subject = "Reminder"
.Body = "Dear All" _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
'You can add files also like this
.Attachments.Add newBook.FullName ' -> Adjust this path
.Display ' -> Or use Display
End With
Set OutMail = Nothing
Cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Let me know if it works

Attach files to an email using Excel VBA

I am trying to save two worksheets in a workbook as separate files to company network locations and then attach those files to an email.
Sub Test_Module_Peter()
'
Dim OutApp As Object
Dim OutMail As Object
Dim SPpath As String
Dim SCpath As String
Dim SPfilename As String
Dim SCfilename As String
Dim SPFullFilePath As String
Dim SCFullFilePath As String
Dim wb As Workbook
Dim Cell As Range
Application.ScreenUpdating = False
' export a copy of PER SP Form
Sheets("PER SP").Select
Sheets("PER SP").Copy
' Remove formulas from SP sheet
With ActiveSheet.UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
' Save a copy of the SP PER Form
SPpath = "\\UKRLTD008\Company\...\...\...\2019\"
SPfilename = "TEST - PER SP ABL90_2019 " & Range("M1")
SPFullFilePath = SPpath & SPfilename
ActiveWorkbook.SaveAs filename:=SPpath & SPfilename, FileFormat:=52
ActiveWorkbook.Close SaveChanges = True
' select ABL90 Credit Claim Master Spreadsheet
For Each wb In Application.Workbooks
If wb.Name Like "ABL90 Credit Claim Master*" Then
wb.Activate
End If
Next
' export a copy of PER SC Form
Sheets("PER SC").Select
Sheets("PER SC").Copy
' Remove formulas from SC sheet
With ActiveSheet.UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
' Save a copy of the SC PER Form
SCpath = "\\UKRLTD008\Company\...\...\...\2019\"
SCfilename = "TEST - PER SC ABL90_2019 " & Range("M1")
SCFullFilePath = SCpath & SCfilename
ActiveWorkbook.SaveAs filename:=SCpath & SCfilename, FileFormat:=52
ActiveWorkbook.Close SaveChanges = True
' Send the SP PER Form to RMED
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.SentOnBehalfOfName = "sales#radiometer.co.uk"
.To = "laura.valenti#radiometer.co.uk"
.CC = ""
.BCC = ""
.Subject = "RLTD PER Forms " & Range("M1")
.Body = "Hi " & vbNewLine & vbNewLine & "Please find attached ABL90 PER's" & vbNewLine & vbNewLine & "Thank you"
.Attachments.Add SPFullFilePath
.Attachments.Add SCFullFilePath
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
It saves the files, but when I try to add them as attachments to the email, the following error occurs:
Run-time error '-2147024894(80070002)': Cannot find this file. Verify the path and file name are correct.
I tried to save the path and filename together as FullFilePath for each file but it doesn't seem to work, can anyone tell me why?

How to assign Thisworkbook macro to Form control

I have a workbook to send out email reminders based on the due date. I would like to change it such that the macro will run when I click a button instead of running automatically when it is opened.
ThisWorkbook:
Sub Workbook_Open()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Cells(1, 1).Value = "Feedback Report (FR) Log" Then CheckDates ws:=ws
Next ws
End Sub
Module1:
Option Explicit
Dim Bcell As Range
Dim iTo, iSubject, iBody As String
Dim ImportanceLevel As String
Public Sub CheckDates(ws As Worksheet)
For Each Bcell In Range("a4", Range("a" & Rows.Count).End(xlUp))
' if email column is not empty then command continues
If Bcell.Offset(0, 15) <> Empty Then
' mail will not be sent if current time is within 23.7 hours
' from time of mail last sent.
If Now() - Bcell.Offset(0, 49) > 0.9875 Then
If Bcell.Offset(0, 25) = Empty Then
If DateDiff("d", Now(), Bcell.Offset(0, 13)) = 7 Then
iTo = Bcell.Offset(0, 15)
iSubject = Bcell & " Due"
iBody = "<font face=""Calibri"" size=""3"">" & "Dear all,<br/><br/>" & _
"<u>FR No. " & Bcell & "</u><br/><br/>" & "Please be reminded that " & Bcell & " will be due by <b><FONT COLOR=#ff0000>" & _
Bcell.Offset(0, 13) & "</font></b>." & _
" Kindly ensure that the FR is closed by the due date and provide the draft FR report with preliminary investigation (Section B & D filled) to Quality.<br/><br/>" _
& "Thank you<br/><br/>" & "Best Regards,<br/>" & "Quality Department<br/><br/>" _
& "company Pte Ltd.<br/>" & "</font>"
SendEmail
Bcell.Offset(0, 49) = Now()
End If
End If
End If
End If
iTo = Empty
iSubject = Empty
iBody = Empty
Next Bcell
End Sub
Private Sub SendEmail()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = iTo
.CC = "email#email.com"
.BCC = ""
.Subject = iSubject
.HTMLBody = iBody
.Importance = ImportanceLevel
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
You have two ways to accomplish this depending on the type of button you want to use to run the macro:
a) If the button is a simply Shape (Insert > Shapes), you need to move the contents of Workbook_Open to a new sub within your Module1 (let's call it "trigger") and right-click the shape > Assign macro > "trigger".
Sub trigger()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Cells(1, 1).Value = "Feedback Report (FR) Log" Then CheckDates ws:=ws
End If
Next ws
End Sub
b) If the button is not a shape but a form button, you need to double-click it while on the design view and move the contents of "trigger" to its own click sub (CommandButton1_click()).
c) Finally, remember to remove the contents of Workbook_Open() sub.

vba to automatically email select sheet in spreadsheet if condition is met

I am trying out a couple different ways to automatically email using VBA and having trouble with the 2 items listed below. The VB does run as is but I would like to try to incorporate these two items if possible. Thank you :).
only attach sheet2(attachment). The file is located in bold in the code below.
only send the attachment if comment 2 is checked (cell D2)
VB
Private Sub CommandButton1_Click()
Dim WS As Worksheet, Rng As Range, c As Range
Dim OutApp As Object, OutMail As Object
Dim Msg As String, Addr As String, FName As String, i As Long
Dim obj As Object
Dim MyFile As String
**MyFile = "L:\NGS\HLA LAB\total quality management\QC & QA\DOSE reports\DOSE reporting form.xlsm"**
If Dir(MyFile) = "" Then
MsgBox "The file to attach was not found here:" & vbLf & vbLf & MyFile, vbExclamation, "Exiting"
GoTo Abort
End If
On Error Resume Next
Set obj = GetObject(, "Outlook.Application")
On Error GoTo 0
If obj Is Nothing Then
Set obj = CreateObject("Outlook.Application")
End If
Set OutApp = CreateObject("Outlook.Application")
Set WS = ThisWorkbook.Sheets("Email")
Set Rng = WS.Range("A2", WS.Range("A" & Rows.Count).End(xlUp))
For Each c In Rng
Msg = Msg & "For " & c.Offset(, 1) & Chr(14) & Chr(14)
For i = 3 To 14
If WS.Cells(c.Row, i) = "x" Then
Msg = Msg & " -" & WS.Cells(1, i) & Chr(14)
End If
Next
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = c.Offset(, 0)
.CC = ""
.BCC = ""
.Subject = "Daily Operational Safety Briefing"
.Body = Msg
.Attachments.Add MyFile, 1
.Send
End With
MsgBox "The data has been emailed sucessfully.", vbInformation
Next c
Set OutMail = Nothing
Abort: Application.Quit
Set OutApp = Nothing
End Sub
Update
Dim MyFile As String, MyFileCopy As String
MyFileCopy = "L:\NGS\HLA LAB\total quality management\QC & QA\DOSE reports\DOSE reporting form Sheet2.xlsm"
' no need to look for MyFile because you are working within it ...
'MyFile = "L:\NGS\HLA LAB\total quality management\QC & QA\DOSE reports\DOSE reporting form.xlsm"
' If Dir(MyFile) = "" Then
'
' MsgBox "The file to attach was not found here:" & vbLf & vbLf & MyFile, vbExclamation, "Exiting"
' GoTo Abort
'
' End If
'create a separate sheet2 to mail out
Sheets(2).Copy
Set wkb = ActiveWorkbook
With wkb
.SaveAs MyFileCopy
.Close True
End With
'this is not needed, since you set the outlook app below
' On Error Resume Next
' Set obj = GetObject(, "Outlook.Application")
' On Error GoTo 0
' If obj Is Nothing Then
' Set obj = CreateObject("Outlook.Application")
' End If
Set OutApp = CreateObject("Outlook.Application")
Set WS = ThisWorkbook.Sheets("Email")
Set Rng = WS.Range("A2", WS.Range("A" & Rows.Count).End(xlUp))
For Each c In Rng
If c.Offset(, 3) = "x" Then 'Not sure how you have Comment2 "checked" in column D
Msg = Msg & "For " & c.Offset(, 1) & Chr(14) & Chr(14)
For i = 3 To 14
If WS.Cells(c.Row, i) = "x" Then
Msg = Msg & " -" & WS.Cells(1, i) & Chr(14)
End If
Next
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = c.Offset(, 0)
.CC = ""
.BCC = ""
.Subject = "Daily Operational Safety Briefing"
.Body = Msg
.Attachments.Add MyFileCopy, 1
.Send
End With
End If
Next c
MsgBox "The data has been emailed sucessfully.", vbInformation
Set OutMail = Nothing
Set OutApp = Nothing
Abort:
Application.Quit 'This will kill the Excel application, is this really what you want?
End Sub
See the below code. I placed a section to make a copy workbook with sheet2 to send as an attachment as well as added in the condition for D2 (assume column for each row) to check for the condition. See my comments, as I took some liberties without knowing how your exact data works. I also cleaned up some of the stuff that looked superfluous.
Private Sub CommandButton1_Click()
Dim WS As Worksheet, Rng As Range, c As Range
Dim OutApp As Object, OutMail As Object
Dim Msg As String, Addr As String, FName As String, i As Long
Dim obj As Object
Dim MyFile As String, MyFileCopy As String
MyFileCopy = "L:\NGS\HLA LAB\total quality management\QC & QA\DOSE reports\DOSE reporting form Attachment.xlsm"
' no need to look for MyFile because you are working within it ...
'MyFile = "L:\NGS\HLA LAB\total quality management\QC & QA\DOSE reports\DOSE reporting form.xlsm"
' If Dir(MyFile) = "" Then
'
' MsgBox "The file to attach was not found here:" & vbLf & vbLf & MyFile, vbExclamation, "Exiting"
' GoTo Abort
'
' End If
'create a separate sheet2 to mail out
Sheets(2).Copy
Set wkb = ActiveWorkbook
With wkb
.SaveAs MyFileCopy
.Close True
End With
'this is not needed, since you set the outlook app below
' On Error Resume Next
' Set obj = GetObject(, "Outlook.Application")
' On Error GoTo 0
' If obj Is Nothing Then
' Set obj = CreateObject("Outlook.Application")
' End If
Set OutApp = CreateObject("Outlook.Application")
Set WS = ThisWorkbook.Sheets("Email")
Set Rng = WS.Range("A2", WS.Range("A" & Rows.Count).End(xlUp))
For Each c In Rng
If c.Offset(, 3) = "Checked" Then 'Not sure how you have Comment2 "checked" in column D
Msg = Msg & "For " & c.Offset(, 1) & Chr(14) & Chr(14)
For i = 3 To 14
If WS.Cells(c.Row, i) = "x" Then
Msg = Msg & " -" & WS.Cells(1, i) & Chr(14)
End If
Next
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = c.Offset(, 0)
.CC = ""
.BCC = ""
.Subject = "Daily Operational Safety Briefing"
.Body = Msg
.Attachments.Add MyFileCopy, 1
.Send
End With
End If
Next c
MsgBox "The data has been emailed sucessfully.", vbInformation
Set OutMail = Nothing
Set OutApp = Nothing
Abort:
Application.Quit 'This will kill the Excel application, is this really what you want?
End Sub

Resources