Ich gehe von meinem Tipp Eine Word-Tabelle "expandable" machen mit VBA aus, in dem ich prinzipiell zeige, wie man eine ganze Tabelle "expandable" machen kann. Bei Klick auf einen MacroButton alterniert gewissermaßen die Tabelle zwischen zwei Zuständen: einerseits exakte Zeilenhöhe und andererseits automatische Zeilenhöhe. Dadurch erreicht man die Darstellung der gesamten Tabelle entweder in Kurz- oder Langform. Dieder neue Tipp realisiert ausgehend von einer Tabelle, die auf exakte Zeilenhöhe eingestellt ist, nicht die gesamte Tabelle sondern nur ausgewählte einzelne Zeilen zu erweitern, so dass der ganze enthaltene Text angezeigt wird. Um das zu erreichen ist eine programmatische Vorbereitung notwendig. Text Text Text ... wobei der dreifache Punkt signalisiert, dass mehr Text bei Klick angesehen werden kann. Dieses Prinzip lässt sich nicht original umsetzen. Der Dreifach-Punkt kann in einer Word-Tabelle nur an einen Zellenanfang, also vor den zu erweiternden Text gesetzt werden. Das ist die erste Aktion, die mittels VBA-Routine realisiert werden muss. Zunächst einige Vereinbarungen: ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Definitionen für Tabellen-Expandable Const sp = 2 ' die spezielle Spalte Const z = 3 ' die Zeilenzahl in spezieller Spalte Const tbn = 1 ' die Tabellennummer im Dokument Const tiz = 1 ' die Titelzeilennummer Const bez = 2 ' die Beginn-Zeilennummer Const fld = 2 ' die Beginn-Feldnummer für Zeilen-Expand Const MButText = "SetHeightRow" ' MacroButton-Texte Const MButText1 = " SetHeightRow ..." Const MButText2 = " SetHeightRow " Const colB = wdColorRed ' die Farbe für den MacroButton-Text ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Die folgende Routine wird zum Vorbereiten der Tabelle benutzt. Sie fügt in die entsprechenden Tabellenzellen, die mehr als z Textzeilen enthalten, jeweils einen MacroButton (mit Dreifach-Punkt) am Textanfang ein. Dabei werden alle Tabellenzeilen durchgegangen. Mit der Funktion 'GetLineNumberOfWrappedText' wird für jede Zelle die Anzahl der tatsächlichen Textzeilen ermittel und dann geprüft, ob z überschritten wird. Wird z überschritten, dann wird der MacroButton eingefügt, sonst nicht. Hier die Routine für diesen Vorgang: ' MacroButtons in Tabellenzellen einfügen, die mehr als z Textzeilen enthalten Sub InsertButtonsInCells() Dim r As Integer, zz As Integer Dim tabRange As Range, cellRange As Range Set tabRange = ActiveDocument.Tables(tbn).Range Application.ScreenUpdating = False For r = bez To tabRange.Rows.Count Set cellRange = tabRange.Rows(r).Cells(sp).Range zz = GetLineNumberOfWrappedText(cellRange) If zz > z Then selection.Collapse wdCollapseStart selection.Font.color = colB tabRange.Fields.Add Range:=selection.Range, _ Type:=wdFieldMacroButton, text:=MButText1, preserveformatting:=False End If DoEvents Next Application.ScreenUpdating = True ' Cursor an den Tabellenanfang tabRange.Rows(1).Cells(1).Select selection.Collapse wdCollapseStart End Sub Die Funktion 'GetLineNumberOfWrappedText' ist dabei ein bisschen 'tricky'. Mit ihr wird ermittelt, ob und wenn ja, wie viele Zeilen ein Text in einer Tabellenzelle benötigt. Sie gibt die Anzahl der Zeilen zurück: ' Anzahl von Zeilen, die ein umbrochener Text in Tabellenzelle benötigt Public Function GetLineNumberOfWrappedText(c As Range) Dim numLines As Long, t As String c.Select t = Left(c.text, Len(c.text) - 2) ' einkürzen Text If t <> "" Then selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend With Dialogs(wdDialogToolsWordCount) .Execute numLines = .Lines End With Else numLines = 0 End If selection.Collapse wdCollapseStart GetLineNumberOfWrappedText = numLines End Function Nach dieser 'Vorarbeit' ist die Tabelle bereit dafür, dass man durch Klicken auf die entsprechenden MacroButtons die dazugehörige Zeile erweitern oder komprimieren kann. Der Code zu den MacroButtons ist folgender: ' einzelne Tabellzeilenhöhe ändern Public Sub SetHeightRow() Dim h As Integer ' Höhe der Schrift in spezieller Spalte Dim actN As Integer ' die aktuelle Zeile Dim fidx As Integer ' Index des geklickten Feldes Dim tabRange As Range, cellRange As Range Set tabRange = ActiveDocument.Tables(tbn).Range Set cellRange = tabRange.Rows(bez).Cells(sp).Range h = cellRange.Font.Size * (z + 1) actN = selection.Information(wdEndOfRangeRowNumber) fidx = getFieldIndex(tabRange.Rows(actN).Range) ' den aktuellen Index des geklickten Feldes ermitteln With tabRange.Rows(actN) If .HeightRule = wdRowHeightAuto Then ' setzen der Zeilenhöhe auf eine feste Höhe .SetHeight RowHeight:=h, HeightRule:=wdRowHeightExactly ' setzen des Symbols für 'expand' auf 'Pfeil nach unten' tabRange.Fields(fidx).Code.text = "MACROBUTTON " & MButText1 & " " Else ' setzen der Zeilenhöhe auf Automatik .HeightRule = wdRowHeightAuto ' setzen des Symbols für 'no expand' auf 'Pfeil nach oben' tabRange.Fields(fidx).Code.text = "MACROBUTTON " & MButText2 _ & manifoldChars(3, ChrW(&H2191)) & " " End If End With selection.Collapse Direction:=wdCollapseEnd End Sub Darin enthalten die Hilfsfunktion 'getFieldIndex', die in einer Tabellenzelle den MacroButton identifiziert und seinen Index ermittelt und zurück gibt: ' ermitteln des Index eines Feldes Function getFieldIndex(r As Range) As Integer Dim oFld As Field, t As String, ix As Integer With r For Each oFld In .Fields t = Trim(oFld.Code.text) If InStr(t, MButText) > 0 Then If oFld.Type = wdFieldMacroButton Then ix = oFld.Index End If End If Next End With getFieldIndex = ix End Function Ebenso wird die kleine String-Hilfsfunktion 'manifoldChars' verwendet, die sich selbst erklärt: ' Vervielfältigen eines Strings in einen String Public Function manifoldChars(n As Integer, c As String) As String Dim i As Integer, z As String For i = 1 To n z = z & c Next manifoldChars = z End Function Dieser Tipp wurde bereits 13.005 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv Vol.6 Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! - nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten - Symbol-Galerie mit mehr als 3.200 Icons im modernen Look Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m. |
sevZIP40 Pro DLL Zippen und Unzippen wie die Profis! Mit nur wenigen Zeilen Code statten Sie Ihre Anwendungen ab sofort mit schnellen Zip- und Unzip-Funktionen aus. Hierbei lassen sich entweder einzelnen Dateien oder auch gesamte Ordner zippen bzw. entpacken. Tipp des Monats März 2024 Dieter Otter UTF-8 Konvertierung von Dateien und Strings VB6 selbst verfügt über keine Funktionen zur UTF-8 Konvertierung von Daten. Mit Hilfe des ADODB.Stream-Objekts lassen sich diese fehlenden Funktionen aber schnell nachrüsten. TOP Entwickler-Paket TOP-Preis!! Mit der Developer CD erhalten Sie insgesamt 24 Entwickler- komponenten und Windows-DLLs. Die Einzelkomponenten haben einen Gesamtwert von 1605.50 EUR... |
||||||||||||||||
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein. |