Attribute VB_Name = "CrosswordsTest"
Sub CrosswordsTests()

'definice promennych
Dim polickaAJ(1000) As String
Dim polickaCZ(1000) As String
Dim polickaAJ2(1000) As String
Dim polickaCZ2(1000) As String
Dim polickaAJ3(1000) As String
Dim polickaCZ3(1000) As String
Dim polickaAJ4(1000) As String
Dim polickaCZ4(1000) As String
Dim polickaAJ5(1000) As String
Dim polickaCZ5(1000) As String
Dim badmark As Integer
Dim slovaDoTajenek(10) As String
Dim virKrizovka(20, 2) As String
Dim virKrizovkaCislo(20) As Integer
Dim posledniRadek As Integer
Dim tajenka(30) As String
Dim nejPred As Integer
Dim nejZa As Integer
Dim pred As Integer
Dim za As Integer
Dim myRange As Range
Dim pocetSlov As Integer
Dim numberofWords As Integer
Dim constPocetSlov As Integer
Dim pocetPokusu As Long
Dim krizovkaCislo As Integer

badmark = 0
slovaDoTajenek(1) = "eatbetterfoodyo"
slovaDoTajenek(2) = "unitedarabemira"
slovaDoTajenek(3) = "doesshelikeithe"
slovaDoTajenek(4) = "whatdoeshelikes"

' Nacti slovicka do poli


'zkontroluje, zde je dost slovicek
If ActiveDocument.Paragraphs.Count < 13 Then
MsgBox "Not enough words"
Exit Sub
End If



'vymaze prazdne radky
Do
If Len(ActiveDocument.Paragraphs.Last.Range.Text) < 3 Then ActiveDocument.Paragraphs.Last.Range.Delete
Loop Until Len(ActiveDocument.Paragraphs.Last.Range.Text) > 3

'zkontroluje, zde je dost slovicek
If ActiveDocument.Paragraphs.Count < 13 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

'zkontroluje, zde je dost slovicek
If ActiveDocument.Paragraphs.Count < 15 Then
MsgBox "Not enough words"
Exit Sub
End If

'spocita pocet slov
pocetSlov = ActiveDocument.Paragraphs.Count
constPocetSlov = pocetSlov

'nastav tvar dokumentu a velikost pisma
With ActiveDocument
    .PageSetup.Orientation = wdOrientationPortrait
    .Range.Font.Size = 9
    .Range.ParagraphFormat.SpaceAfter = 0
End With

With ActiveDocument.Range.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "+"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll, Forward:=True, Wrap:=wdFindContinue
End With
a = 1
For i = 1 To pocetSlov

    polickaAJ(i) = Application.CleanString(ActiveDocument.Paragraphs(a).Range.Text)
    polickaAJ(i) = Left(polickaAJ(i), Len(polickaAJ(i)) - 1)
    polickaAJ(i) = Replace(polickaAJ(i), " ", "")
    polickaAJ(i) = Replace(polickaAJ(i), "^p", "")
    polickaAJ(i) = Replace(polickaAJ(i), "?", "")
    polickaAJ(i) = Replace(polickaAJ(i), ".", "")
    polickaAJ2(i) = polickaAJ(i)
    polickaAJ3(i) = polickaAJ(i)
    polickaAJ4(i) = polickaAJ(i)
     polickaAJ5(i) = polickaAJ(i)
    a = a + 1
    polickaCZ(i) = Application.CleanString(ActiveDocument.Paragraphs(a).Range.Text)
    polickaCZ(i) = Left(polickaCZ(i), Len(polickaCZ(i)) - 1)
    polickaCZ2(i) = polickaCZ(i)
    polickaCZ3(i) = polickaCZ(i)
    polickaCZ4(i) = polickaCZ(i)
    polickaCZ5(i) = polickaCZ(i)
        a = a + 1
    
Next i
ActiveDocument.Content = ""

'tady zacina tvorba krizovek
For krizovkaCislo = 1 To 4

'zamichej pole 15x
Randomize
Dim tempCZ As String
Dim tempAJ As String
Dim tempDva As String
Dim nahoda As Integer

pocetPokusu = 0
Do
slovoDoTajenky = slovaDoTajenek(krizovkaCislo)
posledniRadek = Len(slovoDoTajenky)
For i = 1 To posledniRadek
    tajenka(i) = Mid(slovoDoTajenky, i, 1)
Next i
For i = 1 To 15
    nahoda = 1 + (Rnd * constPocetSlov)
    tempAJ = polickaAJ(nahoda)
    tempDva = polickaAJ(1)
    polickaAJ(nahoda) = tempDva
    polickaAJ(1) = tempAJ
    tempAJ = polickaCZ(nahoda)
    tempDva = polickaCZ(1)
    polickaCZ(nahoda) = tempDva
    polickaCZ(1) = tempAJ
            
Next i

'vytvoř virtuální křížovku


badmark = 0
For j = 1 To posledniRadek

    For i = 1 To pocetSlov
        virKrizovkaCislo(j) = InStr(polickaAJ(i), tajenka(j))
        If virKrizovkaCislo(j) > 0 Then
        virKrizovka(j, 1) = polickaAJ(i)
        virKrizovka(j, 2) = polickaCZ(i)
        
            'vymaz pouzite slovicka
            'pocetSlov = pocetSlov - 1
            For x = i To pocetSlov
                polickaAJ(x) = polickaAJ(x + 1)
                polickaCZ(x) = polickaCZ(x + 1)
            Next x
            
            j = j + 1
            i = 0
            If j > posledniRadek Then
                j = 999
                i = 999
                End If
          
          End If
        Next i
              
          If j < posledniRadek Then
          badmark = badmark + 1
            For b = j To posledniRadek
                tajenka(b) = tajenka(b + 1)
            Next b
            posledniRadek = posledniRadek - 1
            j = j - 1
          End If
          
    Next j
    pocetPokusu = pocetPokusu + 1
    kondition = False
    
  If pocetPokusu > 1000 And badmark < 4 Then kondition = True
'nastav pole slovicek do puvodnich hodnot
For iii = 1 To pocetSlov
    polickaAJ(iii) = polickaAJ5(iii)
    polickaCZ(iii) = polickaCZ5(iii)
Next iii
  
Loop Until badmark < 2 Or kondition = True

'odecti prazdne radky a vyhod je
For i = 1 To posledniRadek
If virKrizovka(i, 1) = "" Then
   For x = i To posledniRadek
              virKrizovka(x, 1) = virKrizovka(x + 1, 1)
             virKrizovka(x, 2) = virKrizovka(x + 1, 2)
       Next x
'nenechej posledni radek plny
            virKrizovka(x + 1, 2) = ""
           virKrizovka(x + 1, 1) = ""
End If
Next i

'ocisluj ceska slova
For i = 1 To posledniRadek
    virKrizovka(i, 2) = Str(i) + ". " + virKrizovka(i, 2)
Next i

'Najdi nejvyssi pocet pismen pred tajenkou a za tajenkou
nejPred = 0
nejZa = 0
For i = 1 To posledniRadek
    If virKrizovkaCislo(i) > nejPred Then nejPred = virKrizovkaCislo(i)
    za = Len(virKrizovka(i, 1)) - virKrizovkaCislo(i)
    If za > nejZa Then nejZa = za
Next i
    
pocetSloupcu = 1 + nejPred + nejZa
posledniRadek = posledniRadek - badmark

'Vytvor sit na krizovku a dej prvni sloupec volny
ActiveDocument.Paragraphs.Add
Set myRange = ActiveDocument.Content
myRange.Collapse Direction:=wdCollapseEnd

'vytvori tabulku
ActiveDocument.Tables.Add Range:=myRange, NumRows:=posledniRadek, NumColumns:=pocetSloupcu
ActiveDocument.Tables(krizovkaCislo).Columns.Width = Application.CentimetersToPoints(0.7)
ActiveDocument.Tables(krizovkaCislo).Rows.Height = Application.CentimetersToPoints(0.7)
'dej slovicka do tabulky a vykresli ji

For i = 1 To posledniRadek
    ActiveDocument.Tables(krizovkaCislo).Cell(i, 1).SetWidth ColumnWidth:=80, RulerStyle:=wdAdjustNone
        
          prvnipismeno = 2 + nejPred - virKrizovkaCislo(i) 'najdi prvni pismeno
          PosledniPismeno = prvnipismeno + Len(virKrizovka(i, 1)) - 1
          
          
        ActiveDocument.Tables(krizovkaCislo).Cell(i, 1).Range.Text = virKrizovka(i, 2) 'napise napovedu cesky
        ActiveDocument.Tables(krizovkaCislo).Cell(i, 1).Borders.OutsideLineStyle = wdLineStyleNone
      
    
      
        a = 1
    
        
        For j = prvnipismeno To PosledniPismeno
            ActiveDocument.Tables(krizovkaCislo).Cell(i, j).Borders.OutsideLineStyle = wdLineStyleSingle
            
            a = a + 1
            
            
                    Next j
                    
       With ActiveDocument.Tables(krizovkaCislo).Cell(i, prvnipismeno - 1 + virKrizovkaCislo(i)).Borders
   .OutsideLineStyle = wdLineStyleSingle
   .OutsideLineWidth = wdLineWidth225pt
  
   
End With
'spoj prazdna policka s prvni
prvniSloupec = prvnipismeno - 1
If prvniSloupec > 1 Then

 With ActiveDocument.Tables(krizovkaCislo)
  .Cell(Row:=i, Column:=1).Merge _
 MergeTo:=.Cell(Row:=i, Column:=prvniSloupec)
   ActiveDocument.Tables(krizovkaCislo).Cell(i, 1).Select
            Selection.ParagraphFormat.Alignment = wdAlignParagraphRight
 End With
 
 End If
 
 

    
Next i
Next krizovkaCislo

        
End Sub