title image


Smiley Neue Version
Hallo!



Neue etwas aufgebohrte Version.

Sie kann nun u.a. Worte mit mehrfach dem gleichen Lösungsbuchstaben (t in Tastsinn)

besser waagerecht zentrieren.



Gruß Chrisir













Option Explicit





Sub Kreuzwortraetsel1()

    

    Const boolMakeItBlack = False  ' Gibt die Art der Ausgabe an

    Const strLoesung = "Wetter"    ' Lösungswort

    Const AnzSpalten = 17          ' Anzahl der Spalten

    Const Mitte = 17 \ 2 + 1       ' Mitte der Tabelle

    

    Dim strRateworte(6)     As String          ' Array mit zu ratenden Worten (Lösungsworte)

    Dim intZeile_i          As Integer         ' Schleife durch die Zeilen

    Dim intSpalte_i         As Integer         ' Schleife durch das Wort einer Zeile

    Dim intPos              As Integer         ' Position des Buchstabens des Lösungswort

    Dim intSpalte           As Integer         ' Spalte, in der der Buchstabe eingetragen wird

    Dim tblTable            As Table           ' Tabelle

    Dim boolWorteZeigen     As Boolean         ' Buchstaben eintragen Ja / Nein

    Dim intAntwort          As Integer         ' Antwort aus der MsgBox

    

    

    intAntwort = MsgBox("Wollen Sie die Worte eintragen lassen?", _

                        vbQuestion + vbYesNoCancel, _

                        "Kreuzworträtsel generieren")

    Select Case intAntwort

        Case vbYes

            boolWorteZeigen = True  ' Buchstaben Ja

        Case vbNo

            boolWorteZeigen = False ' Buchstaben Nein

        Case vbCancel

            End                     ' Abbruch

        Case Else

            MsgBox "Fehler bei case else", _

                   vbCritical, _

                   "Kreuzworträtsel generieren"     ' Fehler

            End

    End Select

    

    ' Rateworte definieren

    strRateworte(1) = "Weib"

    strRateworte(2) = "Gesang"

    strRateworte(3) = "Tanz"

    strRateworte(4) = "Tastsinn"

    strRateworte(5) = "Wissen"

    strRateworte(6) = "Rösterei"

    

    ' Dokument mit Tabelle erstellen und formatieren

    ErstelleDokumentMitTabelle1 tblTable, strLoesung, AnzSpalten, boolMakeItBlack

    

    ' In einer Schleife die Zeilen der Tabelle durchgehen:

    ' intZeile_i ist dabei die Nummer der Zeile (tblTable.Cell(intZeile_i, intSpalte).Range.Text),

    ' gleichzeitig der Buchstabe im senkrechten Lösungswort in dieser Zeile

    ' (Mid(strLoesung, intZeile_i, 1)) und

    ' der Index für das array strRateworte, also die Rateworte (strRateworte(intZeile_i)).

    For intZeile_i = 1 To Len(strLoesung)

        ' Position des Buchstabens des Lösungswort in dem Wort

        ' dieser Zeile ermitteln;

        ' InStrMitte ist gegenüber InStr so, dass der Buchstabe gewählt wird,

        ' der am nächsten an der Mitte des Wortes steht.

        intPos = InStrMitte(1, UCase(strRateworte(intZeile_i)), UCase(Mid(strLoesung, intZeile_i, 1)))

        ' Wenn der Buchstabe des Lösungswort Mid(strLoesung, intZeile_i, 1) in dem Wort

        ' der Zeile strRateworte(intZeile_i) vorkommt

        If intPos > 0 Then

            ' Test

            ' MsgBox strRateworte(intZeile_i) & "   " & Mid(strLoesung, intZeile_i, 1) & "  " & intPos

            ' Nummer für die Frage vor die Zeile setzen

            With tblTable.Cell(intZeile_i, Mitte - intPos).Range

                .Text = intZeile_i

                .Font.Size = 8

                .ParagraphFormat.Alignment = wdAlignParagraphRight

                .Cells.VerticalAlignment = wdCellAlignVerticalBottom

            End With

            ' Wort für diese Zelle buchstabenweise eintragen

            For intSpalte_i = 1 To Len(strRateworte(intZeile_i))

                ' intSpalte für diesen Buchstaben des Rateworts bestimmen

                intSpalte = Mitte - intPos + intSpalte_i

                If boolWorteZeigen Then

                    ' Buchstabe eintragen

                    tblTable.Cell(intZeile_i, intSpalte).Range.Text = UCase(Mid(strRateworte(intZeile_i), intSpalte_i, 1))

                End If

                ' Zelle formatieren je nach boolMakeItBlack

                ZelleFormatieren tblTable, intZeile_i, intSpalte, boolMakeItBlack

            Next ' nächsten Buchstaben

        Else

            ' Buchstabe kommt nicht vor; Fehler

            MsgBox "Wortfehler mit " & strRateworte(intZeile_i), vbExclamation

        End If

    Next ' nächste Zeile

    

    ' Setze dicken Rand um das Lösungswort

    With tblTable.Columns(Mitte).Borders

        .OutsideLineStyle = wdLineStyleSingle

        .OutsideLineWidth = wdLineWidth225pt

        .OutsideColor = wdColorAutomatic

    End With



    ' Worte ausgeben, die dann durch Fragen ersetzt werden müssen

    Selection.EndKey unit:=wdStory, Extend:=wdMove

    Selection.TypeText vbNewLine

    For intZeile_i = 1 To Len(strLoesung)

        Selection.TypeText intZeile_i & ". " & strRateworte(intZeile_i) & vbNewLine

    Next



End Sub



Sub ErstelleDokumentMitTabelle1(tblTable As Table, _

                                strLoesung As String, _

                                AnzSpalten As Integer, _

                                boolMakeItBlack As Boolean)

    

    ' Dokument mit Tabelle erstellen

    

    Documents.Add

    Selection.TypeParagraph

    Selection.TypeParagraph

    Set tblTable = ActiveDocument.Tables.Add(Selection.Range, Len(strLoesung), AnzSpalten)

    ' Je nach boolMakeItBlack

    If boolMakeItBlack Then

        ' Ganze Tabelle schwarz hinterlegen

        With tblTable.Shading

            .Texture = wdTextureNone

            .ForegroundPatternColor = wdColorAutomatic

            .BackgroundPatternColor = wdColorBlack

        End With

    Else

        ' Alle Zellen ohne Ränder

        With tblTable.Range.Cells.Borders

            .OutsideLineStyle = wdLineStyleNone

            .InsideLineStyle = wdLineStyleNone

        End With

    End If

    

    ' Waagerecht und senkrecht zentrieren

    tblTable.Range.Paragraphs.Alignment = wdAlignParagraphCenter

    tblTable.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter



End Sub



Sub TestOn_InStrMitte()

    ' Test für Function InStrMitte

    MsgBox "Tastsinn mit  t:    " & InStrMitte(1, "Tastsinn", "t")

    MsgBox InStrMitte(1, "hstataaaaaaatagggggg", "t")

    MsgBox InStrMitte(1, "sftaaaaaaaaaa", "t")

    MsgBox InStrMitte(1, "stootaaat", "x")

    MsgBox InStrMitte(1, "stootaaat", "")

    MsgBox InStrMitte(1, "stootaaat", "x")

    MsgBox InStrMitte(1, "", "")

End Sub



Function InStrMitte(intStart As Integer, _

                    strWort As String, _

                    strBuchstabe As String) As Integer

    

    ' InStrMitte ist gegenüber InStr so, dass der Buchstabe gewählt wird,

    ' der am nächsten an der Mitte des Wortes steht.

    

    Dim intMitte    ' Mitte des Wortes

    Dim intPos      ' aktuelle Position

    Dim intBestPos  ' beste Position

    

    

    intMitte = Len(strWort) \ 2

    intBestPos = 1000

    intPos = 0

    If strWort <> "" And strBuchstabe <> "" Then

        intPos = InStr(intStart, strWort, strBuchstabe)

        intBestPos = intPos

        While intPos > 0

            ' Abstand bestimmen

            If intPos <> 0 And _

               Abs(intMitte - intPos) <= Abs(intMitte - intBestPos) Then

                 intBestPos = intPos

            End If

            intPos = InStr(intPos + 1, strWort, strBuchstabe)

        Wend

    End If

    

    If intBestPos = 1000 Or intBestPos = 0 Then intBestPos = 0

    InStrMitte = intBestPos



End Function



Sub ZelleFormatieren(tblTable As Table, _

                     intZeile_i As Integer, _

                     intSpalte As Integer, _

                     boolMakeItBlack As Boolean)

    

    ' Hier werden die Zellen formatiert, die Buchstaben

    ' enthalten. Je nach boolMakeItBlack werden die Zellen

    ' weiß statt schwarz oder bekommen eine Rahmen statt

    ' keinen Rahmen zu haben.

    

    ' je nach boolMakeItBlack

    If boolMakeItBlack Then

        ' Zelle nicht schwarz

        With tblTable.Cell(intZeile_i, intSpalte).Shading

            .Texture = wdTextureNone

            .ForegroundPatternColor = wdColorAutomatic

            .BackgroundPatternColor = wdColorWhite

        End With

    Else

        ' Zelle mit Rahmen

        With tblTable.Cell(intZeile_i, intSpalte).Borders

            .OutsideLineStyle = wdLineStyleSingle

        End With

    End If

    

End Sub







Code eingefügt mit Syntaxhighlighter 2.5





geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: