VBA - Command Button - Save file and reset information

[Nadine1988]

Hello all,

so I do have a command button in my excel which first checks a few fields (they're not supposed to be empty and if there are an automated message box is created) and secondly sends the file attached to an email

I now would like to extend the function of this message box - so after the fields are checked BUT BEFORE it get's sent per email I would like the file to be saved automatically with a new file name.

Below you can see the current code. Any ideas?

Private Sub CommandButton1_Click()
Dim xOutlookObj As Object
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    On Error Resume Next
   
    If IsEmpty(Range("A7")) Then
    MsgBox "Enter date"
    GoTo ends
   
    Else
    If IsEmpty(Range("D7")) Then
    MsgBox "Enter Vizrt sales peson"
    GoTo ends
       
    Else
    If IsEmpty(Range("C9")) Then
    MsgBox "Enter the start date of your rental"
    GoTo ends
 
    Else
    If IsEmpty(Range("C11")) Then
    MsgBox "Enter the end date of your rental"
    GoTo ends
   

End If
End If
End If
End If

   
   
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    xMailBody = "Please add any special requirements here. For FOC rentals - please attach Vanessa's approval to your email." & vbNewLine & vbNewLine & _
              "" & vbNewLine & _
              ""
                  On Error Resume Next
    With xOutMail
        .To = "logisticaustria@vizrt.com"
        .CC = ""
        .BCC = ""
        .Subject = "Demopool Request_"
        .Body = xMailBody
        .Attachments.Add ActiveWorkbook.FullName
        .Display   'or use .Send
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
   
ends:
     
     
End Sub

thanks for your help!
best
nadine

 

[Bosquedeguate]

Try something like the followiing:

Private Sub CommandButton1_Click()
Dim xOutlookObj As Object
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    Dim rng As Range
    Dim strmsg As String
    Dim arrymsg()
    Dim i As Long
    On Error Resume Next
   
    Set rng = Range("A7,D7,C9,C11")
    strmsg = ""
    arrymsg = Array("Enter date", "Enter Vizrt sales person", "Enter the start date of your rental", "Enter the end date of your rental")
    For i = 1 To 4
      If IsEmpty(rng(1, i)) Then strmsg = strmsg & vbLf & arrymsg(i - 1)
    Next i
    If Len(strmsg) > 1 Then
      strmsg = Mid(strmsg, 2, Len(strmsg))
      MsgBox strmsg
      GoTo ends
    End If

    'change the path and filename below.
    ActiveWorkbook.SaveAs Filename:= _
        "C:\path\......\filename.xlsm", FileFormat:= _
        xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
        
    'code to send emails goes here
    '   ...
    
ends:
End Sub

 

[Nadine1988]

Guten Morgen,

das funktioniert leider nicht. Wenn in den Code kopiere bekomme ich in den Felden A7, D7,... eine Fehlermeldung obwohl ich etwas eingetrage habe. Ich weiß sowieso nicht, warum der Code oben geändert werden muss, dieser funktioniert ja. Es geht lediglich um das zusätzliche Speichern.

Danke
Lg
Nadine

 

[Fluff]

@Nadine1988 please post to this forum in English only. If you wish to post in your own language then you need to post in the Questions in Other Languages section.
Thanks

 

[Nadine1988]

Oh i'm so sorry - totally forgot about writing in English.
Soo the solution suggested is not working. I receive an error message saying the the fields are empty when I copy the code into my file for the fields A7, D7, C9, and C11.
I actually don't know why the previous code was changed that much as it actually did work - I only need an additional code for saving the file.

Thank you for your help - really appreciated!

@Nadine1988 please post to this forum in English only. If you wish to post in your own language then you need to post in the Questions in Other Languages section.
Thanks

Private Sub CommandButton1_Click()
Dim xOutlookObj As Object
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    Dim rng As Range
    Dim strmsg As String
    Dim arrymsg()
    Dim i As Long
    On Error Resume Next
  
    Set rng = Range("A7,D7,C9,C11")
    strmsg = ""
    arrymsg = Array("Enter date", "Enter Vizrt sales person", "Enter the start date of your rental", "Enter the end date of your rental")
    For i = 1 To 4
      If IsEmpty(rng(1, i)) Then strmsg = strmsg & vbLf & arrymsg(i - 1)
    Next i
    If Len(strmsg) > 1 Then
      strmsg = Mid(strmsg, 2, Len(strmsg))
      MsgBox strmsg
      GoTo ends
    End If

    'change the path and filename below.
    ActiveWorkbook.SaveAs Filename:= _
        "C:\path\......\filename.xlsm", FileFormat:= _
        xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
       
    'code to send emails goes here
    '   ...
   
ends:
End Sub

 

[Nadine1988]

Hello everyone - any other suggestions on how to fix this?
Thanks
Nadine