Respondus to Quizmaker macro

Hi, I created a Word VBA Macro to convert Respondus quizzes to a txt file that Quizmaker could import.

It started out as a proof of concept, and only had to run it once, so the code is sloppy.     (Had over 350 questions to import.)

Only works for T/F and Multiple choice now, but if you know a bit of VBA, could modify to include other question types.

Directions:

1)      In Respondus, export to Word your questions as a test with correct answers marked.

2)      Open the exported Word file, go to the Developer tab, Macros button (on left).  Click edit, and  Paste in the attached macro code.

3)      Run the macro, it will create a new file in whatever directory the file was saved in with the questions now formatted in Quizmaker format.

4)      Go to Quizmaker and import the file.

Code:  (also attached)

Sub Respondus_to_Quizmaker()
'
' Respondus_to_Quizmaker Macro
'
' Created by Tim Welch @ The Ohio State University
' Date: 12/12/13
'
' NOTES:
' Only converts True/False and Multiple Choice questions
' Respondus file character size limited by VBA String object max length (which is ~ 2 billion characters)
'

Dim sText As String 'The text from the Respondus file
Dim iStringLength As Long 'The length of the string
Dim iCurrentPosition As Long ' The current location in the string being examined
iCurrentPosition = 1 ' Initialize at the 1st position

' Read in the quiz questions to string sText
' (As VBA strings are immutable, we will remember our position when using this string instead of
' changing it and thus creating a new string.)
sText = ActiveDocument.Content

' Replace all occurences of line feed (aka line wrap), asii code 11 with a space, asii code 32
sText = Replace(sText, Chr(11), Chr(32))

' Delete all text in the Word file (as we do not save, this does not matter to the Respondus output file)
ActiveDocument.Content.Delete

' Print the heading information at the top of the document
Selection.TypeText ("// Created from: " & ActiveDocument.Name & Chr(13))
Selection.TypeText ("// On date: " & Format(Date, "dddd, d MMMM YYYY") & Chr(13) & Chr(13))

' Set iStringLength to the length of the string
iStringLength = Len(sText)

' Move thru the string converting each question to Respondus format and
' printing it to the cleared open Word document being used as a Temp location for the changes
Do While iCurrentPosition <> iStringLength
    Call ConvertToRespondusFormat(iCurrentPosition, iStringLength, sText)
Loop

' Save modified file as text file to allow easy importing to Respondus
Call SaveAsTextFile

' Close the open Word file without saving
Application.Quit SaveChanges:=wdDoNotSaveChanges

End Sub

Private Sub SaveAsTextFile()
' Saves Current Word file to a text file with the same name in the same directory it is saved to.
'
' Modified from code found at:
' http://msdn.microsoft.com/en-us/library/office/aa662158(v=office.10).aspx
'
Dim strDocName As String
Dim intPos As Long

'Find position of extension in file name
strDocName = ActiveDocument.Name
intPos = InStrRev(strDocName, ".")

If intPos = 0 Then

'If the document has not yet been saved
'Ask the user to provide a file name
strDocName = InputBox("Please enter the name " & _
"of your document.")
Else

'Strip off extension and add ".txt" extension
strDocName = Left(strDocName, intPos - 1)
strDocName = strDocName & ".txt"
End If

'Save file with new extension
' ActiveDocument.Path & changes the default save path (My Documents)
' to the current directory
' "\\WordBackupFolder\Error folder" & "\"
ActiveDocument.SaveAs fileName:=ActiveDocument.Path & "\" & strDocName, _
FileFormat:=wdFormatText

End Sub

Private Sub ConvertToRespondusFormat(iCurrentPosition As Long, iStringLength As Long, sText As String)
'
'
'
Dim sQuestionLine As String

' Get just the question text
' Respondus format for questions always starts a question with a # followed by a period as the first items on a line
' So it looks like: ####. This is the question.
' QuizMaker does not have question numbers so it needs to be removed
sQuestionLine = QuestionLine(sText, iCurrentPosition)

' Check if the current question is True False or Multiple Choice and handle appropriately
If IsTrueFalse(sText, iCurrentPosition) Then
    Call QuestionTrueFalse(sQuestionLine, iCurrentPosition, iStringLength, sText)
Else
    Call QuestionMultipleChoice(sQuestionLine, iCurrentPosition, iStringLength, sText)
End If

End Sub

Function IsTrueFalse(sText, iCurrentPosition) As Boolean
' Returns True if the question is a True False question
       
    ' Look for "a. True" on first question line (which is where the iCurrentPosition is at)
    Dim iIsTrue As Long
    Dim sCurrentLine As String
    Dim iEndofLine As Long
       
    ' Find the end of the line
    iEndofLine = InStr(iCurrentPosition, sText, Chr(13))
   
    'Get the current line which will be the first answer line
    sCurrentLine = Mid(sText, iCurrentPosition, (iEndofLine - iCurrentPosition))
   
    iIsTrue = InStr(sCurrentLine, "a. True")
   
    ' Check if T/F, if so, return true
    If iIsTrue Then
        IsTrueFalse = True
    Else
        IsTrueFalse = False
    End If
   
End Function

Function QuestionLine(sText, iCurrentPosition) As String
' Returns a String containing the current question line without the leading "####. "
' Updates the location of iCurrentPosition to the start of the 1st answer line
   
    Dim sCurrentLine As String
    Dim iEndofLine As Long
   
    ' Need to move to the start of the question (aka Need to move past "####. ")
    iCurrentPosition = InStr(iCurrentPosition, sText, ". ") + 2
       
    ' Find the end of the line
    iEndofLine = InStr(iCurrentPosition, sText, Chr(13))
   
    'Get the current line which will be the question line
    sCurrentLine = Mid(sText, iCurrentPosition, (iEndofLine - iCurrentPosition))
   
    ' Update iCurrentPosition to the first answer choice
    iCurrentPosition = iEndofLine + 2
   
    QuestionLine = sCurrentLine
   
End Function

Function AnswerLine(sText, iCurrentPosition) As String
' Returns a String containing the current answer line without the leading "(letter). "
' Updates the location of iCurrentPosition to the start of the next line
   
    Dim sCurrentLine As String
    Dim iEndofLine As Long
   
    ' Need to move to the start of the answer (aka Need to move past "(letter). ")
    iCurrentPosition = InStr(iCurrentPosition, sText, ". ") + 2
       
    ' Find the end of the line
    iEndofLine = InStr(iCurrentPosition, sText, Chr(13))
   
    'Get the current line which will be the answer line
    sCurrentLine = Mid(sText, iCurrentPosition, (iEndofLine - iCurrentPosition))
   
    ' Update iCurrentPosition to the next line
    iCurrentPosition = iEndofLine + 1
   
    AnswerLine = sCurrentLine
   
End Function

Private Sub QuestionTrueFalse(sQuestionLine As String, iCurrentPosition As Long, iStringLength As Long, sText As String)
'
'
'
    Dim sAnswerLine As String
    Dim bAnswerCorrect As Boolean
   
    ' Write that the question if True/False
    Selection.TypeText ("TF" & Chr(13))
   
    ' Assign Point value of question
    Selection.TypeText ("1" & Chr(13))
   
    ' Write the question line
    Selection.TypeText (sQuestionLine & Chr(13))
       
    ' Cycle thru the answers and print them out
    Do While Mid(sText, iCurrentPosition, 1) <> Chr(13)
        ' Check if the answer is correct, write the "*" if it is
        If Mid(sText, iCurrentPosition, 1) = "*" Then
            Selection.TypeText ("*")
            bAnswerCorrect = True
            iCurrentPosition = iCurrentPosition + 1
        Else
            bAnswerCorrect = False
        End If
       
        ' Get the Answer line and update iCurrentPosition
        sAnswerLine = AnswerLine(sText, iCurrentPosition)
       
        ' Write the answer
        Selection.TypeText (sAnswerLine & Chr(13))
    Loop
       
    ' Check to see if within 5 spaces of the end, if so, set to stop
    ' If not, advance to the next Question and put a space between questions
    If (iCurrentPosition + 5) >= iStringLength Then
        iCurrentPosition = iStringLength
    Else
        iCurrentPosition = iCurrentPosition + 2
        Selection.TypeText (Chr(13))
    End If

End Sub

Private Sub QuestionMultipleChoice(sQuestionLine As String, iCurrentPosition As Long, iStringLength As Long, sText As String)
'
'
'
    Dim sAnswerLine As String
    Dim bAnswerCorrect As Boolean
   
    ' Write that the question is Multiple Choice
    Selection.TypeText ("MC" & Chr(13))
   
    ' Assign Point value of question
    Selection.TypeText ("1" & Chr(13))
   
    ' Write the question line
    Selection.TypeText (sQuestionLine & Chr(13))
       
    ' Cycle thru the answers and print them out
    Do While Mid(sText, iCurrentPosition, 1) <> Chr(13)
        ' Check if the answer is correct, write the "*" if it is
        If Mid(sText, iCurrentPosition, 1) = "*" Then
            Selection.TypeText ("*")
            bAnswerCorrect = True
            iCurrentPosition = iCurrentPosition + 1
        Else
            bAnswerCorrect = False
        End If
       
        ' Get the Answer line and update iCurrentPosition
        sAnswerLine = AnswerLine(sText, iCurrentPosition)
       
        ' Write the answer
        Selection.TypeText (sAnswerLine & " | ")
       
        ' Write the correct comment
        If bAnswerCorrect Then
            Selection.TypeText ("That's correct!" & Chr(13))
        Else
            Selection.TypeText ("That's incorrect." & Chr(13))
        End If
    Loop
       
    ' Check to see if within 5 spaces of the end, if so, set to stop
    ' If not, advance to the next Question and put a space between questions
    If (iCurrentPosition + 5) >= iStringLength Then
        iCurrentPosition = iStringLength
    Else
        iCurrentPosition = iCurrentPosition + 2
        Selection.TypeText (Chr(13))
    End If

End Sub