Zeilen zählen in generierten Word-Dolkument
12.03.2019 21:40:08
Daniel
habe im Moment folgendes Problem:
Aus Excel heraus soll ein Word-Dokument geöffnet werden. Anschließend wird der String-Inhalt einer Zelle in die Word-Datei geschrieben. Anschließend soll die Anzahl der Zeilen bestimmt werden, die der String im Word-Dokument benötigt, um später dynamisch die Schriftgröße so lange zu verringern bis der String in eine Zeile passt.
Dies soll mit einer Schleife passieren, in der mit ComputeStatistics(Statistic:=wdStatisticLines) solange die Zeilenzahl ermittelt wird, bis diese 1 beträgt.
Mein Problem ist nun, dass sowohl ComputeStatistics(Statistic:=wdStatisticLines) als auch ComputeStatistics(Statistic:=wdStatisticCharacters) den Wert 1 liefert, obwohl dies nicht der Fall ist.
Der Code dazu sieht so aus:
Sub Tischschilder_erzeugen()
Dim intTNzahl As Integer
Dim n As Integer
Dim i As Integer
Dim intTNnummer As Integer
Dim intTNSlength As Integer
Dim intTNSlines As Integer
Dim intTNSchars As Long
Dim intTNSschriftgrad As Long
Dim strTNname As String
Dim intErstesKomma As Integer
Dim AppWD As Object, objWordDoc As Object
Application.ScreenUpdating = False
'Legt den Unterordner Tischschilder an
If Dir(ThisWorkbook.Path & "\Tischschilder", vbDirectory) = "" Then
MkDir (ThisWorkbook.Path & "\Tischschilder")
Else
End If
'zählt die TN im Tabellenblatt
intTNzahl = Application.WorksheetFunction.CountA(Worksheets("Tabelle1").Range("B2:B40"))
'TN-Namen werden extrahiert
For n = 1 To 1 'intTNzahl
strTNname = Worksheets("Tabelle1").Cells(2 + n, 2).Value
'Tischkärtchen werden erstellt
Set AppWD = CreateObject("Word.Application")
'Template öffnen
AppWD.Visible = True
Set objWordDoc = AppWD.Documents.Open(ThisWorkbook.Path & "\Tischschildtemplate.docx")
'Namen eintragen
objWordDoc.Activate
objWordDoc.Bookmarks("TNstart").Range.Text = strTNname
intTNSchars = objWordDoc.Range(objWordDoc.Bookmarks("TNstart").Range.Start, objWordDoc. _
Bookmarks("TNende").Range.End).ComputeStatistics(Statistic:=wdStatisticCharacters)
intTNlines = objWordDoc.Range(objWordDoc.Bookmarks("TNstart").Range.Start, objWordDoc.Bookmarks( _
"TNende").Range.End).ComputeStatistics(Statistic:=wdStatisticLines)
Debug.Print intTNSchars 'liefert 1 obwohl 61
Debug.Print intTNlines 'liefert 1 obwohl 3
i = 0
Do Until intTNSlines = 1
Debug.Print intTNSlines
With objWordDoc
intTNSschriftgrad = .Range(.Bookmarks("TNstart").Range.Start, .Bookmarks("TNende").Range.End). _
Font.Size
Debug.Print intTNSschriftgrad
.Range(.Bookmarks("TNstart").Range.Start, .Bookmarks("TNende").Range.End).Font.Size = 28 - i
intTNSlines = .Range(.Bookmarks("TNstart").Range.Start, .Bookmarks("TNende").Range.End). _
ComputeStatistics(wdStatisticLines)
End With
i = i + 1
Loop
objWordDoc.SaveAs2 Filename:=ThisWorkbook.Path & "\Tischschilder\" & strTNname & ".docx"
objWordDoc.Close
Set objWord = Nothing
Set objDoc = Nothing
AppWD.Quit
Next
Application.ScreenUpdating = True
Worksheets("Tabelle1").Activate
End Sub
Die Word-Vorlage ist leer und enthält die zwei durch ein Leerzeichen getrennte Bookmarks TNstart und TNende.
Liegt das Problem vielleicht darin, dass ich den Bereich zwischen den beiden Bookmarks nicht richtig anspreche?
Über Hilfe oder eine zielführende Idee würde ich mich sehr freuen!
Schöne Grüße und Danke im voraus,
Daniel