Results 1 to 2 of 2

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

  1. #1

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

    Register for a FREE account, and/
    or Log in to avoid these ads!


    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.

  2. #2

    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
    Application.DisplayAlerts = False
    On Error GoTo Email_Error
    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
    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
    Valid_Save = False

    Load HPC_Main
    Application.StatusBar = False
    Unload Me
    Application.StatusBar = "Saving data for Project: " & HPC_Main.PROJECT.Value & ", Please Wait..."
    Unload HPC_Main

    'Save and Close Workbook
    Valid_Save = True
    Application.StatusBar = False

    Unload Me

    End If

    End Sub

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts