Consulting

Results 1 to 2 of 2

Thread: inputbox with obligatory text

  1. #1
    VBAX Regular
    Joined
    Feb 2018
    Posts
    10
    Location

    inputbox with obligatory text

    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

  2. #2
    VBAX Master
    Joined
    Feb 2007
    Posts
    1,687
    Location
    Maybe

    Sub YourName()
        username = ""
        Do
            username = InputBox("Scrivi il tuo Nome e Cognome")
        Loop While username = ""
    End Sub
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

Posting Permissions

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