randomize numbers. help me defeat plagiarism!

physicsphilosopher · #1 03-21-2017, 06:26 PM

Hey guys, this is my first post here! I'm a high school physics teacher in my 2nd year and i'm getting tired of the amount of copying that is happening in my Honors Physics class. I'd like to make a VBA macro that will randomize numbers on every copy i print for tests/worksheets. I use word 2016 at home and work.

Something where i could type a problem like this
"Billy dropped a rock off a X meter high cliff. The rock has a mass of Y kilograms"

And then when i print it i could print up 130 copies and word would automatically insert a random number within a designated range on each copy for the X and Y above. Below is what i have so far in code but i don't think it'll do the trick. Any advice? Thanks!!!

Option Explicit

Public Function RandomNumber(Lowest As Long, Highest As Long, _
Optional Decimals As Integer)

If IsMissing(Decimals) Or Decimals = 0 Then
Randomize
RandomNumber = Int((Highest + 1 - Lowest) * Rnd + Lowest)
Else
Randomize
RandomNumber = Round((Highest - Lowest) * Rnd + Lowest, Decimals)
End If
End Function

Sub RNG1to10()

Dim rn1 As Double
Dim text As Double

rn1 = RandomNumber(1, 10, 0)

Selection.TypeText text:=rn1

End Sub

gmayor · #2 03-21-2017, 10:19 PM

This looks fun, but it will take some thought how to record who has which version, but something along the lines of the following may help get you started.

Code:

Option Explicit
Private Const sName As String = "Billy|Bobby|John|Susan|Ted"
Private Const sPlace As String = "Cliff|Tower|Bridge"
Private Const sItem As String = "Stone|Rock|Wrench"
Private vName As Variant, vPlace As Variant, vItem As Variant
Private iPlace As Integer, iName As Integer, iItem As Integer
Private iHeight As Integer, iMass As Integer
Private sText As String

Private Function RandomNumber(Lowest As Long, Highest As Long, _
                              Optional Decimals As Integer) As Integer
    If IsMissing(Decimals) Or Decimals = 0 Then
        Randomize
        RandomNumber = Int((Highest + 1 - Lowest) * Rnd + Lowest)
    Else
        Randomize
        RandomNumber = Round((Highest - Lowest) * Rnd + Lowest, Decimals)
    End If
End Function

Sub Macro1()
    vName = Split(sName, "|")
    vPlace = Split(sPlace, "|")
    vItem = Split(sItem, "|")
    iHeight = RandomNumber(1, 50, 0)
    iMass = RandomNumber(1, 5, 0)
    iPlace = RandomNumber(0, UBound(vPlace))
    iName = RandomNumber(0, UBound(vName))
    iItem = RandomNumber(0, UBound(vItem))
    sText = vName(iName) & " dropped a " & vItem(iItem) & " off a " & iHeight & " meter-high " & _
            vPlace(iPlace) & ". The " & vItem(iItem) & " has a mass of " & iMass & " kilograms."
    Selection.TypeText sText
End Sub

physicsphilosopher · #3 03-22-2017, 04:49 AM

Quote:

Originally Posted by gmayor

This looks fun, but it will take some thought how to record who has which version, but something along the lines of the following may help get you started.

Code:

Option Explicit
Private Const sName As String = "Billy|Bobby|John|Susan|Ted"
Private Const sPlace As String = "Cliff|Tower|Bridge"
Private Const sItem As String = "Stone|Rock|Wrench"
Private vName As Variant, vPlace As Variant, vItem As Variant
Private iPlace As Integer, iName As Integer, iItem As Integer
Private iHeight As Integer, iMass As Integer
Private sText As String

Private Function RandomNumber(Lowest As Long, Highest As Long, _
                              Optional Decimals As Integer) As Integer
    If IsMissing(Decimals) Or Decimals = 0 Then
        Randomize
        RandomNumber = Int((Highest + 1 - Lowest) * Rnd + Lowest)
    Else
        Randomize
        RandomNumber = Round((Highest - Lowest) * Rnd + Lowest, Decimals)
    End If
End Function

Sub Macro1()
    vName = Split(sName, "|")
    vPlace = Split(sPlace, "|")
    vItem = Split(sItem, "|")
    iHeight = RandomNumber(1, 50, 0)
    iMass = RandomNumber(1, 5, 0)
    iPlace = RandomNumber(0, UBound(vPlace))
    iName = RandomNumber(0, UBound(vName))
    iItem = RandomNumber(0, UBound(vItem))
    sText = vName(iName) & " dropped a " & vItem(iItem) & " off a " & iHeight & " meter-high " & _
            vPlace(iPlace) & ". The " & vItem(iItem) & " has a mass of " & iMass & " kilograms."
    Selection.TypeText sText
End Sub

Thank you!!! This looks amazing and is way better than what i could of come up with on my own! Was thinking about which version and decided to try adding in code to duplicate the process x times and put it on a new page each time, and number it each time. This way i could have one document that has 130 different versions of the same quiz and just print the document once to get all i'll need for the day. Once i get that working i'm going to get it to add the answers by version number to either the end of the same document or another, whichever i figure out how to do faster.

I'll update again once i make progress. Thanks again for giving me such a solid foundation!!!

gmayor · #4 03-22-2017, 06:45 AM

Another possibility is to put the variations in a worksheet (where you can also calculate the answers in a second complementary worksheet) and associate each variation with a student and use mail merge to create a custom version of the question paper for each student. That would also make it easier to add mutiple questions. You can then compare the student's answers with the question sheet and more easily identify where the plagiarism comes from.

You could mix a few fixed questions with the random questions (especially the first questions so the plagiarists may not immediately notice)

physicsphilosopher · #5 03-22-2017, 07:20 AM

Do you mean that instead of including each question in the code, just have the questions written out in a word doc and then do a search and replace to add in random numbers? That does sound easier as i wouldn't have to format each question in code format and could type them out in an easier manner.

gmayor · #6 03-22-2017, 09:43 AM

Not quite. I'll throw together an example tomorrow. I've had enough for today.

physicsphilosopher · #7 03-22-2017, 12:49 PM

Ok Cool dude. Thanks again for your help, hope you have a good evening! I've worked on it some today and this is what it looks like right now. Its working and outputting the answers properly. Good progress!!!

Code:

Option Explicit
Private Const sName As String = "Billy|Melanie|John|Susan|Ted|Christine|Bobby"
Private Const sPlace As String = "Cliff|Tower|Bridge|Skyscraper"
Private Const sItem As String = "Stone|Rock|Wrench|Box|Crate|Suitcase"
Private vName As Variant, vPlace As Variant, vItem As Variant
Private iPlace As Integer, iName As Integer, iItem As Integer
Private iHeight As Double, iMass As Double
Private sText As String

Private Function RandomNumber(Lowest As Long, Highest As Long, _
Optional Decimals As Integer) As Integer
If IsMissing(Decimals) Or Decimals = 0 Then
Randomize
RandomNumber = Int((Highest + 1 - Lowest) * Rnd + Lowest)
Else
Randomize
RandomNumber = Round((Highest - Lowest) * Rnd + Lowest, Decimals)
End If
End Function

Function FileExists(FName As String) As Boolean
' Returns True if the file FName exists, else False
Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
FileExists = fs.FileExists(FName)
Set fs = Nothing
End Function

Sub anticopy()
Dim oxlApp As Object ' Used for the Excel App
Dim oxlWbk As Object ' Used for the Workbook
Dim FN As String

Dim AnswerA As Single ' Part A solution
Dim AnswerB As Single ' Part B solution
Dim AnswerC As Single ' Part C solution

FN = "C:\users\proctor.david\documents\vba\testanswers. xlsx" ' Spreadsheet Name

vName = Split(sName, "|")
vPlace = Split(sPlace, "|")
vItem = Split(sItem, "|")
iHeight = RandomNumber(20, 80, 1)
iMass = RandomNumber(2, 25, 0)
iPlace = RandomNumber(0, UBound(vPlace))
iName = RandomNumber(0, UBound(vName))
iItem = RandomNumber(0, UBound(vItem))

AnswerA = iMass * 9.8
AnswerB = ((2 * iHeight) / 9.8) ^ 0.5
AnswerC = 9.8 * AnswerB
sText = vName(iName) & " dropped a " & vItem(iItem) & " off a " & iHeight & " meter-high " & _
vPlace(iPlace) & ". The " & vItem(iItem) & " has a mass of " & iMass & " kilograms." & _
Chr(11) & Chr(9) & "A. Calculate the force of gravity on the " & vItem(iItem) & "." & Chr(11) & _
Chr(9) & "B. Calculate the time it will take to hit the ground. Ignore air resistance." & _
Chr(11) & Chr(9) & "C. How fast will the " & vItem(iItem) & " be falling when it hits the ground?" & _
Chr(11)
Selection.TypeText sText
Set oxlApp = CreateObject("Excel.Application")

If FileExists(FN) Then ' Check to see if the spreadsheet exists.
Set oxlWbk = oxlApp.Workbooks.Open(FileName:=FN) ' Open the Workbook
oxlWbk.ActiveSheet.Cells(1, 1).Value = AnswerA
oxlWbk.ActiveSheet.Cells(1, 2).Value = AnswerB
oxlWbk.ActiveSheet.Cells(1, 3).Value = AnswerC
oxlWbk.Close SaveChanges:=True ' Close the spreadsheet, saving the changes.
Set oxlWbk = Nothing
Else ' It does not exist so tell the user.
MsgBox "Excel File " & FN & " not found"
End If ' Close the Excel App cleanly

oxlApp.Quit
Set oxlApp = Nothing

End Sub

gmayor · #8 03-22-2017, 10:16 PM

I think you are on top of this, though if I may suggest a couple of modifications, the following will create the workbook and record all the required answers. The code creates 10 pages, but you can make that any number you like.

Code:

Option Explicit

Private Const sName As String = "Billy|Melanie|John|Susan|Ted|Christine|Bobby"
Private Const sPlace As String = "cliff|tower|bridge|building"
Private Const sItem As String = "stone|rock|wrench|box|crate|suitcase"

Private Const iPages As Integer = 10 'the number of pages to create

Private vName As Variant, vPlace As Variant, vItem As Variant
Private iPlace As Integer, iName As Integer, iItem As Integer
Private iHeight As Double, iMass As Double
Private i As Integer
Private oxlApp As Object    ' Used for the Excel App
Private oxlWbk As Object    ' Used for the Workbook
Private FN As String
Private oDoc As Document
Private oRng As Range
Private sText As String
Private NextRow As Long
Private AnswerA As Single    ' Part A solution
Private AnswerB As Single    ' Part B solution
Private AnswerC As Single    ' Part C solution

Sub anticopy()

    Set oDoc = Documents.Add
    Set oRng = oDoc.Range

    FN = Environ("USERPROFILE") & "\documents\vba"    ' Spreadsheet Folder
    CreateFolders FN
    FN = FN & "testanswers.xlsx"
    Set oxlApp = CreateObject("Excel.Application")
    If FileExists(FN) Then    ' Check to see if the spreadsheet exists.
        Set oxlWbk = oxlApp.Workbooks.Open(FileName:=FN)    ' Open the Workbook
    Else    ' It does not exist so tell the user.
        Set oxlWbk = oxlApp.Workbooks.Add
        With oxlWbk
            .Sheets(1).Cells(1, 1).Value = "Student"
            .Sheets(1).Cells(1, 2).Value = "AnswerA"
            .Sheets(1).Cells(1, 3).Value = "AnswerB"
            .Sheets(1).Cells(1, 4).Value = "AnswerC"

            .SaveAs FN
        End With
    End If

    vName = Split(sName, "|")
    vPlace = Split(sPlace, "|")
    vItem = Split(sItem, "|")

    For i = 1 To iPages    'create the question documents
        iHeight = RandomNumber(20, 80, 1)
        iMass = RandomNumber(2, 25, 0)
        iPlace = RandomNumber(0, UBound(vPlace))
        iName = RandomNumber(0, UBound(vName))
        iItem = RandomNumber(0, UBound(vItem))

        AnswerA = iMass * 9.8
        AnswerB = ((2 * iHeight) / 9.8) ^ 0.5
        AnswerC = 9.8 * AnswerB
        sText = "Student " & i & vbCr & vName(iName) & " dropped a " & vItem(iItem) & " off a " & iHeight & " meter-high " & _
                vPlace(iPlace) & ". The " & vItem(iItem) & " has a mass of " & iMass & " kilograms." & _
                Chr(11) & Chr(9) & "A. Calculate the force of gravity on the " & vItem(iItem) & "." & Chr(11) & _
                Chr(9) & "B. Calculate the time it will take to hit the ground. Ignore air resistance." & _
                Chr(11) & Chr(9) & "C. How fast will the " & vItem(iItem) & " be falling when it hits the ground?" & _
                Chr(11)
        oRng.Text = sText
        oRng.Collapse 0
        If i < iPages Then
            oRng.InsertBreak Type:=0
            oRng.Collapse 0
        End If

        NextRow = oxlWbk.Sheets(1).Range("A" & oxlWbk.Sheets(1).Rows.Count).End(-4162).Row + 1

        With oxlWbk
            .Sheets(1).Cells(NextRow, 1).Value = "Student " & i
            .Sheets(1).Cells(NextRow, 2).Value = AnswerA
            .Sheets(1).Cells(NextRow, 3).Value = AnswerB
            .Sheets(1).Cells(NextRow, 4).Value = AnswerC
        End With
    Next i

    oxlWbk.Close SaveChanges:=True    ' Close the spreadsheet, saving the changes.
    Set oxlWbk = Nothing
    ' Close the Excel App cleanly
    oxlApp.Quit
    Set oxlApp = Nothing
End Sub

Private Function RandomNumber(Lowest As Long, Highest As Long, _
                              Optional Decimals As Integer) As Integer
    If IsMissing(Decimals) Or Decimals = 0 Then
        Randomize
        RandomNumber = Int((Highest + 1 - Lowest) * Rnd + Lowest)
    Else
        Randomize
        RandomNumber = Round((Highest - Lowest) * Rnd + Lowest, Decimals)
    End If
End Function

Private Function FileExists(FName As String) As Boolean
' Returns True if the file FName exists, else False
Dim fs
    Set fs = CreateObject("Scripting.FileSystemObject")
    FileExists = fs.FileExists(FName)
    Set fs = Nothing
End Function

Private Sub CreateFolders(strPath As String)
'A Graham Mayor/Greg Maxey AddIn Utility Macro
Dim oFSO As Object
Dim lngPathSep As Long
Dim lngPS As Long
  If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
  lngPathSep = InStr(3, strPath, "\")
  If lngPathSep = 0 Then GoTo lbl_Exit
  Set oFSO = CreateObject("Scripting.FileSystemObject")
  Do
    lngPS = lngPathSep
    lngPathSep = InStr(lngPS + 1, strPath, "\")
    If lngPathSep = 0 Then Exit Do
    If Len(Dir(Left(strPath, lngPathSep), vbDirectory)) = 0 Then Exit Do
  Loop
  Do Until lngPathSep = 0
    If Not oFSO.FolderExists(Left(strPath, lngPathSep)) Then
      oFSO.CreateFolder Left(strPath, lngPathSep)
    End If
    lngPS = lngPathSep
    lngPathSep = InStr(lngPS + 1, strPath, "\")
  Loop
lbl_Exit:
  Set oFSO = Nothing
  Exit Sub
End Sub

physicsphilosopher · #9 03-23-2017, 08:38 AM

I love you.

gmayor · #10 03-23-2017, 10:08 PM

Steady.