vb@rchiv · Tipps & Tricks · VBA-Funktionen #2, Funktionen zur Verwendung an Word-Tabellen

Rubrik: Word | VB-Versionen: VBA

21.04.15

VBA-Funktionen #2, Funktionen zur Verwendung an Word-Tabellen Im Tipp werden mehrere Funktionen vorgestellt, die bei der programmtechnischen Arbeit mit Word-Tabellen verwendet werden können.
Autor: Dietrich Herrmann	Bewertung:	Views: 8.690
ohne Homepage	System: Win7, Win8, Win10, Win11	kein Beispielprojekt

In diesem Tipp veröffentliche ich mehrere Funktionen zu Word-Tabellen-Programmierung, die ich in kleinen, später hier gezeigten Projekten verwenden werde. Sie werden ebenfalls wie die Funktionen im Tipp VBA-Funktionen #1, bestimmte Funktionen zur Array-Verwendung im Voraus mitgeteilt (und können natürlich vom Anwender nach eigenen Bedürfnissen modifiziert und variiert werden).

Hier die Funktionen, die durch die Parameter recht selbsterkärend sind.

' Ermitteln der Tabellennummer, in der sich der Cursor befindet
' Rückgabe: die Tabellennummer
Public Function WhichTableNumber() As Integer
  Dim i As Integer
  With selection
    If ActiveDocument.Tables.Count = 0 Or Not .Information(wdWithInTable) Then
      MsgBox "Cursor befindet sich nicht in einer Tabelle!"
      WhichTableNumber = 0
      Exit Function
    End If
    For i = 1 To ActiveDocument.Tables.Count
      If (.Range.Start >= ActiveDocument.Tables(i).Range.Start) And _
        (.Range.End <= ActiveDocument.Tables(i).Range.End) Then
        Exit For
      End If
    Next i
  End With
  WhichTableNumber = i
End Function

' Erstellen einer neuen Tabelle an der Cursorposition
' colNums: die Anzahle der Spalten
' rowNums: die Anzahl der Zeilen
' prozentual: die prozentuale Breitenverteilung der Spalten
' Rückgabe: die Nummer der Tabelle im Dokument
Public Function CreateTable(colNums As Integer, rowNums As Integer, Optional prozentual As Variant)
  ActiveDocument.Tables.Add Range:=selection.Range, NumRows:=rowNums, NumColumns:=colNums, _
  DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed
  If Not IsMissing(prozentual) Then
    ' prozentuale Spaltenbreiten setzen
    setProz ActiveDocument.Tables(ActiveDocument.Tables.Count), prozentual
 
    ' Tabellengitter erzeugen
    setGridLines ActiveDocument.Tables(ActiveDocument.Tables.Count)
  End If
  CreateTable = ActiveDocument.Tables(ActiveDocument.Tables.Count)
End Function

' Die Spaltenbreiten einer Tabelle prozentual berechnen und verteilen
' tb: die Tabelle
' prozentual: ein Feld der Prozentzahlen für die Spaltenbreiten
Public Sub setProz(tb As Word.table, prozentual As Variant)
  Dim i As Integer, co As Integer
  With tb
    .AllowAutoFit = False
    .PreferredWidthType = wdPreferredWidthPercent
    co = .columns.Count
    For i = 0 To co - 1
      If i > UBound(prozentual) Then Exit For
      .columns(i + 1).PreferredWidth = Val(prozentual(i))
    Next 
  End With
End Sub

' Tabellengitter erzeugen
' tb: die Tabelle
Public Sub setGridLines(tb As Word.table)
  tb.Rows(1).Cells(1).Select
  selection.Collapse
  selection.WholeStory
  WordBasic.ShowTableGridlines
 
  With selection.Borders(wdBorderTop)
    .LineStyle = Options.DefaultBorderLineStyle
    .LineWidth = Options.DefaultBorderLineWidth
    .Color = Options.DefaultBorderColor
  End With
 
  With selection.Borders(wdBorderLeft)
    .LineStyle = Options.DefaultBorderLineStyle
    .LineWidth = Options.DefaultBorderLineWidth
    .Color = Options.DefaultBorderColor
  End With
 
  With selection.Borders(wdBorderBottom)
    .LineStyle = Options.DefaultBorderLineStyle
    .LineWidth = Options.DefaultBorderLineWidth
    .Color = Options.DefaultBorderColor
  End With
 
  With selection.Borders(wdBorderRight)
    .LineStyle = Options.DefaultBorderLineStyle
    .LineWidth = Options.DefaultBorderLineWidth
    .Color = Options.DefaultBorderColor
  End With
 
  With selection.Borders(wdBorderHorizontal)
    .LineStyle = Options.DefaultBorderLineStyle
    .LineWidth = Options.DefaultBorderLineWidth
    .Color = Options.DefaultBorderColor
  End With
End Sub

' Einfügen eines Dezimal-Tabstopps in die Zellen einer Tabellenspalte
' tb: die Tabelle
' col: die Spaltennummer
' w: der Wert der Stelle für den Tabstopp (~ die Mitte der Zelle)
Public Sub AddDecimalTabToCell(tb As table, col As Integer, w As Single)
  ' to be expanded by inserting a decimal tab at 1.7 cm in all cells 
  ' starting from row 2 of Column 2 and 3
  Dim mytable As table, i As Integer, cellT As Range, cw As Integer
  Set mytable = tb
  With mytable
    cw = .columns(col).Width
    For i = 1 To .Rows.Count
      Set cellT = mytable.Rows(i).Cells(col).Range
      cellT.ParagraphFormat.TabStops.Add Position:=cw \ 2, _
        Alignment:=wdAlignTabDecimal, Leader:=wdTabLeaderSpaces
    Next 
  End With
End Sub

' Eine Bezeichnung als Über- oder Unterschrift zur Tabelle hinzufügen
' tb: die Tabelle
' str: der Text für die Bezeichnung
' pos: die Position für die Bezeichnung (unten bzw. oben)
' fontS: die Schriftgröße für die Bezeichnung
' fontC: die Farbe der Bezeichnung
Public Sub TabelleUeberUnterschrift(tb As Word.table, str As String, pos As WdCaptionPosition, _
  fontS As Integer, fontC As WdColor)
 
  Dim ad As Range
  Set ad = ActiveDocument.Range
  ' einfügen einer Bezeichnung
  tb.Range.InsertCaption Label:=wdCaptionTable, Title:=str, Position:=pos, ExcludeLabel:=True
  ' löschen der Nummerierung (Feld)
  ad.Fields(ad.Fields.Count).Delete
  ' formatieren des Absatzes mit der Bezeichnung
  With selection
    .Expand unit:=wdParagraph
    .Font.Size = fontS
    .Font.Color = fontC
    .Move unit:=wdParagraph
  End With
  tb.Range.Collapse wdCollapseStart
End Sub