vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
NEU! sevCoolbar 3.0 - Professionelle Toolbars im modernen Design!  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2024
 
zurück
Rubrik: Word   |   VB-Versionen: VBA16.03.15
Mittels VBA In einer Word-Tabelle eine Zeile expandieren (erweitern)

Der Tipp beschreibt die Möglichkeit mittels VBA-Code eine Word-Tabelle so zu gestalten, dass man einzelne Zeilen so expandieren kann, dass der vollständige Text in den Zellen zu sehen ist.

Autor:   Dietrich HerrmannBewertung:     [ Jetzt bewerten ]Views:  13.003 
ohne HomepageSystem:  Win7, Win8, Win10, Win11kein Beispielprojekt 

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.
Man kennt die häufig im Internet auftretende Textdarstellung

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
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  • sp: gibt an, in welcher Spalte der Tabelle sich die zu erweiternden Texte befinden
  • z: gibt an, wieviele Zeilen Text bei Einstellung 'exakte Zeilenhöhe' in den Zellen angezeigt werdn
  • bez: gibt an, ab welcher Zeile der Tabelle die Operation ausgeführt werden soll
  • MButText: enthält den Namen des Makros, das das eigentliche Erweitern bzw. Komprimieren der Zeile realisiert
  • MButText1: ist der MacroButton-Text mit Dreifach-Punkt, also zum Erweitern
  • MButText2: ist der MacroButton-Text (wird durch VBA ergänzt) zum Komprimieren
  • colB: ist die Farbe, in der der MacroButton-Text gezeigt wird

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.003 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Neue Diskussion eröffnen

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!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.
 
   

Druckansicht Druckansicht Copyright ©2000-2024 vb@rchiv Dieter Otter
Alle Rechte vorbehalten.
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.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel