inputbox with obligatory text

[bg66]

Hi,
I need your help.

In this macro, I would like the compilation of the inputbox to be binding (the field must be always completed):


Dim numCorrect As Integer
Dim numIncorrect As Integer
Dim userName As String
Dim qAnswered As Boolean

Sub SaveToExcel() 'ADDED
Dim oXLApp As Object
Dim oWb As Object
Dim row As Long
Dim strTitle As String
Dim strdate As String


With ActivePresentation.Slides(1).Shapes("Title")
strTitle = .TextFrame.TextRange
If strTitle = "" Then strTitle = "Not Found"
End With
strdate = Format(Date, "dd/mm/yyyy")
Set oXLApp = CreateObject("Excel.Application")
'On a Mac change \ to : in the following line
Set oWb = oXLApp.Workbooks.Open(ActivePresentation.Path & "\" & "AvvioCorso.xlsm")
If oWb.Worksheets(1).Range("A1") = "" Then
oWb.Worksheets(1).Range("A1") = "Title"
oWb.Worksheets(1).Range("B1") = "Date"
oWb.Worksheets(1).Range("C1") = "Name"
oWb.Worksheets(1).Range("D1") = "Number Correct"
oWb.Worksheets(1).Range("E1") = "Number Incorrect"
oWb.Worksheets(1).Range("F1") = "Percentage"
End If
row = 2
While oWb.Worksheets(1).Range("A" & row) <> ""
row = row + 1
Wend
oWb.Worksheets(1).Range("A" & row) = strTitle
oWb.Worksheets(1).Range("B" & row) = strdate
oWb.Worksheets(1).Range("C" & row) = userName
oWb.Worksheets(1).Range("D" & row) = numCorrect
oWb.Worksheets(1).Range("E" & row) = numIncorrect
oWb.Worksheets(1).Range("F" & row) = Format(100 * (numCorrect / (numCorrect + numIncorrect)), "##.#") & "%"
oWb.Save
oWb.Close
End Sub

Sub GetStarted()
Initialize
YourName
ActivePresentation.SlideShowWindow.View.Next
End Sub

Sub Initialize()
numCorrect = 0
numIncorrect = 0
qAnswered = False
End Sub

Sub YourName()
userName = InputBox("Scrivi il tuo Nome e Cognome")
End Sub

Sub RightAnswer()
YourName
If qAnswered = False Then
numCorrect = numCorrect + 1
End If
qAnswered = False
MsgBox "Complimenti " & userName & ". Richiedi al docente il test di apprendimento"
Feedback
End Sub

Sub WrongAnswer()
YourName
If qAnswered = False Then
numIncorrect = numIncorrect + 1
End If
qAnswered = True
MsgBox "Attendere prego"
gotoSlide 'vai a slide specifica
SaveToExcel 'ADDED
End Sub


Sub Feedback()
MsgBox "Aggiornamento in corso"
SaveToExcel 'ADDED
End Sub

Sub NameIt()
Dim sResponse As String

With ActiveWindow.Selection.ShapeRange(1)
sResponse = InputBox("Rename this shape to ...", "Rename Shape", .Name)
Select Case sResponse
' blank names not allowed
Case Is = ""
Exit Sub
' no change?
Case Is = .Name
Exit Sub
Case Else
On Error Resume Next
.Name = sResponse
If Err.Number <> 0 Then
MsgBox "Unable to rename this shape"
End If
End Select
End With

End Sub

Sub gotoSlide()
Application.SlideShowWindows(1).View.gotoSlide Index:=4
End Sub

Where and what to change?

Thanks in advance.
bg66

[John Wilson]

Maybe


Sub YourName()
username = ""
Do
username = InputBox("Scrivi il tuo Nome e Cognome")
Loop While username = ""
End Sub