Public Test As Collection ' Of Theme(s) Public OneWay As Collection 'Of Question(s) Sub Charge() Dim t As New Theme Dim q As New Question Dim bl, bl1 As BLine Dim p As Paragraph Dim s As String Dim Blank As Boolean Dim Source, Res As Document Dim r, r1, rTot As Range Dim o As Object Set Test = New Collection Set OneWay = New Collection Set Source = ActiveDocument Subject = Source.Name Source.VBProject.VBComponents("Module1").Export ("Module1.sys") ' building a TREE For Each p In Source.Paragraphs s = Trim(p.Range.Text) s = Left(Trim(s), Len(s) - 1) ' cuts LF If Len(s) = 0 Then If q.Answers.Count > 0 Then t.Questions.Add q Set q = New Question End If Blank = True ElseIf Left(s, 1) = "&" Or Left(s, 1) = "@" Then If q.Answers.Count > 0 Then t.Questions.Add q Set q = New Question End If If t.Questions.Count > 0 Then ' t always filled with Theme data - flash it Test.Add t Set t = New Theme End If t.Title = Trim(Mid(s, 2)) ' ommiting leading & Blank = True ' emulate initial Blank(s) to force new question Else If Blank Then ' after Blank - new Question q.Question.Parse (s) Else Set bl = New BLine bl.Parse (s) If q.Answers.Count <= 2 Then q.Answers.Add bl Else q.Answers.Add bl, , Int(q.Answers.Count * Rnd) + 1 End If End If Blank = False ' toggle Blank state to fork in Answers next time End If Next If q.Answers.Count > 0 Then t.Questions.Add q End If If t.Questions.Count > 0 Then Test.Add t End If ' interactive stage 1 ReDim myList(Test.Count - 1, 0 To 1) i = 0 For Each t In Test myList(i, 0) = t.Title myList(i, 1) = Space(5 - Len(Str(t.Questions.Count))) + Str(t.Questions.Count) i = i + 1 Next Thems.LBThems.List() = myList Thems.Show ' execution resumes after form hidding ' incuding to common list in random order i = 0 For Each t In Test If t.Selected Then For Each q In t.Questions If OneWay.Count <= 2 Then OneWay.Add q Else OneWay.Add q, , Int(OneWay.Count * Rnd) + 1 End If Next i = i + 1 End If Next ' limiting number of questions by removing random elements If Thems.Limited.Value Then Do While OneWay.Count > Thems.ScrollBar1.Value OneWay.Remove (Int(OneWay.Count * Rnd) + 1) Loop End If ' CHECK POINT: OneWay Contains exactly we need - - - - - - - - - - - - - - - - - - - - - - If OneWay.Count > 0 Then Dim MaxPoints As Integer MaxPoints = 0 For Each q In OneWay MaxPoints = MaxPoints + q.Question.Weight Next Set Res = Documents.Add Set r = Res.Sentences.First With r .InsertBefore vbNewLine + vbNewLine + vbNewLine .Collapse wdCollapseEnd .InsertAfter "Протокол тестування від " + Str(Day(Now())) + "/" + Str(Month(Now())) + "/" + Str(Year(Now())) + vbNewLine + vbNewLine .Paragraphs(1).Alignment = wdAlignParagraphCenter .Collapse wdCollapseEnd .Paragraphs(1).Alignment = wdAlignParagraphLeft .InsertAfter "Особа, що тестується: " + Trim(Thems.TextBox1.Text) + vbNewLine .InsertAfter vbNewLine + "Факультет, курс, група: " + Trim(Thems.TextBox2.Text) + vbNewLine .InsertAfter vbNewLine + "Банк даних: " + Subject + ", вибрано " + Str(OneWay.Count) + " питань за темами:" + vbNewLine For Each t In Test If t.Selected Then .InsertAfter vbTab + "- " + t.Title + vbNewLine End If Next .InsertAfter vbNewLine + "Загальна можлива кількість балів:" + Str(MaxPoints) + vbNewLine .InsertAfter vbNewLine + "Результат тестування:" Set rTot = r.Duplicate .InsertAfter vbNewLine + vbNewLine + vbNewLine + vbNewLine + vbTab + "Викладач: _ _ _ _ _ _ _ _ _ _ _ _ _ " + Trim(Thems.TextBox3.Text) + vbNewLine + vbFormFeed .Collapse wdCollapseEnd End With i = 1 For Each q In OneWay r.InsertAfter Str(i) + "/" + Str(OneWay.Count) + " [" + Trim(Str(q.Question.Weight)) + "] " + q.Question.Value + vbNewLine r.Font.Bold = True Set q.Question.loc = r.Duplicate r.Collapse wbCollapseEnd For Each bl In q.Answers r.InsertAfter bl.Value + vbNewLine Set bl.loc = r.Duplicate Set r1 = r.Duplicate r1.Collapse wdCollapseStart Set bl.ff = Res.InlineShapes.AddOLEControl("Forms.CheckBox.1", r1) With bl.ff.OLEFormat.Object .Width = 12 .Height = 12 .Alignment = 0 .Caption = "" End With r.Collapse wbCollapseEnd Next r.InsertAfter vbNewLine + vbNewLine i = i + 1 Next Selection.End = 1 Selection.Start = 1 Res.Protect Type:=wdAllowOnlyFormFields, NoReset:=True ' CHECK POINT: all objects are in the place ' disable any grammar and spelling check either With Options .VirusProtection = False .CheckGrammarWithSpelling = False .CheckSpellingAsYouType = False .CheckGrammarAsYouType = False End With Res.ShowGrammaticalErrors = False ' code charging, yeh Res.VBProject.VBComponents.Import ("Module1.sys") Set o = Res.VBProject.VBComponents("ThisDocument").CodeModule i = 1 k = 1 For Each q In OneWay j = 1 For Each bl In q.Answers pos = o.CreateEventProc("Change", bl.ff.OLEFormat.Object.Name) o.InsertLines pos + 1, vbTab + "Call IfFinished" For Each bl1 In q.Answers o.InsertLines pos + 1, vbTab + "ActiveDocument.InlineShapes(" + Mid(bl1.ff.OLEFormat.Object.Name, 9) + ").OLEFormat.Object.Enabled = False" Next o.InsertLines pos + 1, vbTab + "ActiveDocument.Protect wdAllowOnlyFormFields, False" Select Case bl.Weight Case 100 o.InsertLines pos + 1, vbTab + "r.Font.Color = wdColorGreen" Case 0 o.InsertLines pos + 1, vbTab + "r.Font.Color = wdColorRed" Case Else o.InsertLines pos + 1, vbTab + "r.Font.Color = wdColorLightOrange" End Select o.InsertLines pos + 1, vbTab + "ActiveDocument.UnProtect" o.InsertLines pos + 1, vbTab + "Set r = ActiveDocument.Range(" + Str(q.Question.loc.Start) + ", " + Str(q.Question.loc.End) + ")" o.InsertLines pos + 1, vbTab + "Dim r As Range" Gain = Int(bl.Weight * q.Question.Weight / 100) o.InsertLines pos + 1, vbTab + "Points = Points + " + Str(Gain) o.InsertLines pos + 1, vbTab + "Finish =" + Str(rTot.End) o.InsertLines pos + 1, vbTab + "Start =" + Str(rTot.Start) o.InsertLines pos + 1, vbTab + "MPoints =" + Str(MaxPoints) j = j + 1 k = k + 1 Next i = i + 1 Next End If End Sub