VB Code not sending e-mail of results or workbook to admin

Riaz3001

New member
Joined
Mar 19, 2014
Messages
4
Reaction score
0
Points
0
Hello,

The problem I am having at the moment is that I have a survey which is filled in by a user a VB Form, and at the end I want a summary sheet of the filled in fields sent to the user which works fine, but I also want the filled in excel workbook which the user saves on their machine to also be sent as an e-mail to me, so I can produce results, now at the moment I am receiving a blank version and I think it’s the original saved version of the workbook which I do not want.
Have I overdone something simple or missing anything out, I cannot seem to work out why it doesn't work. The code is attached to this post.
Will also comment the code below.
Appreciate all the help.
Thanks
 

Riaz3001

New member
Joined
Mar 19, 2014
Messages
4
Reaction score
0
Points
0
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
 
Top