Attribute VB_Name = "QuizMaker" Sub MultipleChoice() 'Převeď seznam do pole Dim polickaAJ(1000) As String Dim polickaCZ(1000) As String Dim pracovnipoleAJ(1000) As String Dim stabilnipoleAJ(1000) As String Dim spravneodpovedi(1000) As String Dim poleNabidek(4) As String Dim slovoOtazka As String Dim cislotabulky As Integer Randomize 'zkontroluje, zde je dost slovicek If ActiveDocument.Paragraphs.Count < 15 Then MsgBox "Not enough words" Exit Sub End If pocetSlov = ActiveDocument.Paragraphs.Count i = 0 Do i = i + 1 If Len(ActiveDocument.Paragraphs(i).Range.Text) < 3 Then ActiveDocument.Paragraphs(i).Range.Delete pocetSlov = ActiveDocument.Paragraphs.Count i = i - 1 End If Loop While pocetSlov > i + 1 pocetSlov = ActiveDocument.Paragraphs.Count pocetSlovorg = pocetSlov 'zkontroluje, zde je dost slovicek If ActiveDocument.Paragraphs.Count < 15 Then MsgBox "Not enough words" Exit Sub End If With ActiveDocument.Range.Find .ClearFormatting .Replacement.ClearFormatting .Text = "+" .Replacement.Text = "^p" .Execute Replace:=wdReplaceAll, Forward:=True, Wrap:=wdFindContinue End With cislo = 0 For i = 1 To pocetSlov Step 2 cislo = cislo + 1 polickaAJ(cislo) = ActiveDocument.Paragraphs(i).Range.Text polickaCZ(cislo) = ActiveDocument.Paragraphs(i + 1).Range.Text polickaAJ(cislo) = Left(polickaAJ(cislo), Len(polickaAJ(cislo)) - 1) polickaCZ(cislo) = Left(polickaCZ(cislo), Len(polickaCZ(cislo)) - 1) 'udelej pracovni pole ktere se bude umazavat pracovnipoleAJ(cislo) = polickaAJ(cislo) stabilnipoleAJ(cislo) = polickaAJ(cislo) Next i soucasnypocetslov = cislo ActiveDocument.Range.Text = "" ActiveDocument.Paragraphs.Add Set myRange = ActiveDocument.Content myRange.Collapse Direction:=wdCollapseEnd ActiveDocument.Tables.Add Range:=myRange, NumRows:=30, NumColumns:=8 ActiveDocument.Paragraphs.Add Set myRange = ActiveDocument.Content myRange.Collapse Direction:=wdCollapseEnd ActiveDocument.Tables.Add Range:=myRange, NumRows:=3, NumColumns:=10 For iii = 1 To 8 Step 2 ActiveDocument.Tables(1).Columns(iii).Width = InchesToPoints(0.2) ActiveDocument.Tables(1).Columns(iii + 1).Width = InchesToPoints(1.5) Next iii For v = 1 To 30 Step 2 With ActiveDocument.Tables(1) .Cell(Row:=v, Column:=1).Merge _ MergeTo:=.Cell(Row:=v, Column:=2) .Borders.Enable = False End With With ActiveDocument.Tables(1) .Cell(Row:=v, Column:=1).Merge _ MergeTo:=.Cell(Row:=v, Column:=2) .Borders.Enable = False End With With ActiveDocument.Tables(1) .Cell(Row:=v, Column:=1).Merge _ MergeTo:=.Cell(Row:=v, Column:=2) .Borders.Enable = False End With ActiveDocument.Tables(1).Rows(v).HeightRule = wdRowHeightExactly ActiveDocument.Tables(1).Rows(v).Height = Application.CentimetersToPoints(0.45) ActiveDocument.Tables(1).Rows(v + 1).Height = 10 Next v 'vezmi náhodné slovíčko a správnou odpověď, Vytvoř pole kam dáš odpovědi For i = 1 To 15 slovoOtazka = 1 + Int(Rnd * soucasnypocetslov) 'nachystej moznosti odpoved = 1 + Int(Rnd * 4) poleNabidek(odpoved) = polickaAJ(slovoOtazka) 'vymaze polozku z pracovniho pole For xx = slovoOtazka To UBound(pracovnipoleAJ) - 1 pracovnipoleAJ(xx) = pracovnipoleAJ(xx + 1) Next xx 'sniz pocet moznosti, ze kterych vybira cislo = soucasnypocetslov - 1 For j = 1 To 4 moznost = 1 + Int(Rnd * cislo) If odpoved = j Then j = j + 1 If j > 4 Then Exit For poleNabidek(j) = pracovnipoleAJ(moznost) For xx = moznost To UBound(pracovnipoleAJ) - 1 pracovnipoleAJ(xx) = pracovnipoleAJ(xx + 1) Next xx cislo = cislo - 1 Next j 'cislo rady kam dat slovicka Rada = i * 2 - 1 textotazky = Str(i) + ". " + polickaCZ(slovoOtazka) ActiveDocument.Tables(1).Cell(Rada, 1).Range.Text = textotazky ActiveDocument.Tables(1).Cell(Rada, 1).Range.Font.Bold = True spravneodpovedi(i) = odpoved ActiveDocument.Tables(1).Cell(Rada + 1, 2).Range.Text = poleNabidek(1) ActiveDocument.Tables(1).Cell(Rada + 1, 4).Range.Text = poleNabidek(2) ActiveDocument.Tables(1).Cell(Rada + 1, 6).Range.Text = poleNabidek(3) ActiveDocument.Tables(1).Cell(Rada + 1, 8).Range.Text = poleNabidek(4) ActiveDocument.Tables(1).Cell(Rada + 1, 1).Range.Text = "a" ActiveDocument.Tables(1).Cell(Rada + 1, 3).Range.Text = "b" ActiveDocument.Tables(1).Cell(Rada + 1, 5).Range.Text = "c" ActiveDocument.Tables(1).Cell(Rada + 1, 7).Range.Text = "d" 'zbav se uz daneho slovicka For xxx = slovoOtazka To UBound(polickaCZ) - 1 polickaCZ(xxx) = polickaCZ(xxx + 1) polickaAJ(xxx) = polickaAJ(xxx + 1) Next xxx soucasnypocetslov = soucasnypocetslov - 1 'dej do pracovniho pole aj zpet vsechna slovicka For xxy = 1 To UBound(polickaAJ) pracovnipoleAJ(xxy) = stabilnipoleAJ(xxy) Next xxy Next i 'udelej dalsi tabulku a do ni dej reseni. myRange.Collapse Direction:=wdCollapseEnd ActiveDocument.Paragraphs.Add For i = 1 To 5 If spravneodpovedi(i) = 1 Then spravne = Str(i) + ". a" If spravneodpovedi(i) = 2 Then spravne = Str(i) + ". b" If spravneodpovedi(i) = 3 Then spravne = Str(i) + ". c" If spravneodpovedi(i) = 4 Then spravne = Str(i) + ". d" ActiveDocument.Tables(2).Cell(1, i).Range.Text = spravne If spravneodpovedi(i + 10) = 1 Then spravne = Str(i + 10) + ". a" If spravneodpovedi(i + 10) = 2 Then spravne = Str(i + 10) + ". b" If spravneodpovedi(i + 10) = 3 Then spravne = Str(i + 10) + ". c" If spravneodpovedi(i + 10) = 4 Then spravne = Str(i + 10) + ". d" ActiveDocument.Tables(2).Cell(3, i).Range.Text = spravne If spravneodpovedi(i + 5) = 1 Then spravne = Str(i + 5) + ". a" If spravneodpovedi(i + 5) = 2 Then spravne = Str(i + 5) + ". b" If spravneodpovedi(i + 5) = 3 Then spravne = Str(i + 5) + ". c" If spravneodpovedi(i + 5) = 4 Then spravne = Str(i + 5) + ". d" ActiveDocument.Tables(2).Cell(2, i).Range.Text = spravne Next i 'zkontroluj jestli se nabídka neopakuje 'udělej tabulku 2x5 Slovíčko,abcd a odpovědi 'opakuj podle počtu slov End Sub