title image


Smiley Re: Worte in Tabelle ausrichten


So,

Viel Spaß damit.



Gruß, Chrisir















Option Explicit





Sub Kreuzwortraetsel1()

    

    Const strLoesung = "Wetter"  ' Lösungswort

    Const Mitte = 9              ' Mitte der Tabelle

    

    Dim s(6) As String           ' Array mit zu suchenden Worten

    Dim i1                       ' Schleife durch die Zeilen

    Dim i2                       ' Schleife durch das Wort einer Zeile

    Dim i_Spalte_vor             ' Schleife vor dem Wort

    Dim i_Spalte_nach            ' Schleife nach dem Wort

    Dim Pos                      ' Position des Buchstabens des Lösungswort

    Dim spalte                   ' Spalte, in der der Buchstabe eingetragen wird

    Dim Tbl1 As Table            ' Tabelle

    

    s(1) = "Weib"

    s(2) = "Gesang"

    s(3) = "Tanz"

    s(4) = "Matte"

    s(5) = "Wissen"

    s(6) = "Horn"

    

    ' Dokument mit Tabelle erstellen

    Documents.Add

    Selection.TypeParagraph

    Selection.TypeParagraph

    Set Tbl1 = ActiveDocument.Tables.Add(Selection.Range, Len(strLoesung), 17)

    

    For i1 = 1 To Len(strLoesung)

        ' Position des Buchstabens des Lösungswort in dem Wort

        ' dieser Zeile ermitteln

        Pos = InStr(1, UCase(s(i1)), UCase(Mid(strLoesung, i1, 1)))

        ' Wenn der Buchstabe existiert

        If Pos > 0 Then

            ' Test

            ' MsgBox s(i1) & "   " & Mid(strLoesung, i1, 1) & "  " & Pos

            ' Wort für diese Zelle eintragen, Buchstabenweise

            For i2 = 1 To Len(s(i1))

                spalte = Mitte - Pos + i2

                Tbl1.Cell(i1, spalte).Range.Text = UCase(Mid(s(i1), i2, 1))

            Next

            ' Zellen vor dem Wort schwarz setzen

            For i_Spalte_vor = 1 To Mitte - Pos

                Tbl1.Cell(i1, i_Spalte_vor).Range.Shading.Texture = wdTextureNone

                Tbl1.Cell(i1, i_Spalte_vor).Range.Shading.ForegroundPatternColor = wdColorAutomatic

                Tbl1.Cell(i1, i_Spalte_vor).Range.Shading.BackgroundPatternColor = wdColorBlack

            Next

            ' Zellen nach dem Wort schwarz setzen

            For i_Spalte_nach = Mitte - Pos + Len(s(i1)) + 1 To 17

                Tbl1.Cell(i1, i_Spalte_nach).Range.Shading.Texture = wdTextureNone

                Tbl1.Cell(i1, i_Spalte_nach).Range.Shading.ForegroundPatternColor = wdColorAutomatic

                Tbl1.Cell(i1, i_Spalte_nach).Range.Shading.BackgroundPatternColor = wdColorBlack

            Next

        Else

            ' Buchstabe existiert nicht; Fehler

            MsgBox "Wortfehler mit " & s(i1), vbExclamation

        End If

    Next

    

End Sub







Code eingefügt mit Syntaxhighlighter 2.5





geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: