COde I am having issues with
Private Sub Yes_Button_Click()
Projects_Submitted_in_Session = Projects_Submitted_in_Session + 1
Response = MsgBox("You will now be asked to save this Survey for Project: " & HPC_Main.PROJECT.Value, vbInformation)
ForceSave = True 'Used to prevent user cancelling save at last opportunity (see Save Survey module)
Call Save_Survey(ForceSave)
ForceSave = False
'Send-email
Application.DisplayAlerts = False
On Error GoTo Email_Error
without_summary_message:
Response = MsgBox("You may receive several warnings as the program tries to send the e-mail containing your survey." & Chr(13) & Chr(13) & "You must accept these warnings to receive the summary.", vbOKOnly, "Please Note:")
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim OutApp As Object
Dim OutMail As Object
Set wb1 = ActiveWorkbook
If Val(Application.Version) >= 12 Then
If wb1.FileFormat = 51 And wb1.HasVBProject = True Then
MsgBox "There is VBA code in this xlsx file, there will" & vbNewLine & "be no VBA code in the file you send. Save the" & vbNewLine & "file first as xlsm and then try the macro again.", vbInformation
End If
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Make a copy of the file/Open it/Mail it/Delete it
'If you want to change the file name then change only TempFileName
TempFilePath = Environ$("temp") & "\"
TempFileName = "Copy of " & wb1.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
FileExtStr = "." & LCase(Right(wb1.Name, Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))
wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Set wb2 = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = UserName
.CC =
.BCC = ""
.Subject = "Site: " & HPC_Main.SITE.Value & " SUBJECT OF E-MAIL: " & HPC_Main.PROJECT.Value
.Body = "Stuff."
.Attachments.Add wb2.FullName
Application.EnableEvents = False
.Send 'or use .Display
End With
On Error GoTo 0
wb2.Close SaveChanges:=False
'Delete the file
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Application.DisplayAlerts = False
On Error GoTo Email_Error
AppActivate "High Performance Computing Survey" 'Reset Focus to Excel
Email_Error:
If Err.Number = 287 Then MsgBox ("No email has been sent!")
On Error GoTo 0
Application.DisplayAlerts = True
Dim count As Integer
'For count = 0 To Post_Processing.TestComboBox.ListCount - 1
If Len(Dir(ThisWorkbook.Path & "\Charts")) = 0 Then
On Error Resume Next
Kill ThisWorkbook.Path & "\Charts\*.*"
RmDir ThisWorkbook.Path & "\Charts\"
On Error GoTo 0
End If
'Next count
Application.ScreenUpdating = True
'Another Project Required?
msg = "Thankyou! All data submitted OK for Project: " & HPC_Main.PROJECT.Value & Chr(13) & Chr(13) & "Do you want to submit another Project?" ' Define message.
Style = vbYesNo + vbInformation
Title = "Submit Confirmation..." ' Define title.
Application.ScreenUpdating = False
Response2 = MsgBox(msg, Style, Title, Help, Ctxt)
If Response2 = vbYes Then
Application.ScreenUpdating = True
Application.StatusBar = "Saving data for Project: " & HPC_Main.PROJECT.Value & ", Please Wait..."
Unload Post_Processing
Unload HPC_Main
'Save Workbook & Remain Open
Next_Clicks = 0
Valid_Save = True
'Workbooks(MyWorkbook).Save
Valid_Save = False
Load HPC_Main
HPC_Main.Show
Application.StatusBar = False
Unload Me
Else
Application.StatusBar = "Saving data for Project: " & HPC_Main.PROJECT.Value & ", Please Wait..."
Unload HPC_Main
'Save and Close Workbook
Valid_Save = True
'Workbooks(MyWorkbook).Save
Application.StatusBar = False
Unload Me
Workbooks(MyWorkbook).Close
End If
End Sub
