Code Snippet "VBA Word"

Dekodierungsmakro: Zerlegt einen Text in Tabelle mit einem Wort pro Zelle und zwei leeren Zeilen

Achtung: noch nicht sehr robust!

Sub procDekodierung()
' Zerlegt einen russischen Text (Unicode) anhand der Leerzeichen
' in Tabellenzeile (ein Wort pro Zelle). Darunter werden zwei Leerzeilen
' eingefügt, eine für die deutsche Dekodierung, die zweite für die Zeiten.
' Vorbedingungen: Ein Satz pro Absatz, Sprecher fett formatiert

  On Error Resume Next
  
  Dim objPar As Paragraph
  Dim intAnzWords As Integer
  Dim strTest As String
  Dim blnAbZeile2 As Boolean
  blnAbZeile2 = False
    
  'Flackern des Bildschirms verhindern
  Application.ScreenUpdating = False
  
  For Each objPar In ActiveDocument.Paragraphs
    'Ab dem zweiten Paragraphen zuerst 2 Tabellenzeilen einfügen
    If blnAbZeile2 Then
      Selection.InsertRowsBelow 2
      '3. Reihe ist hidden, nicht ausgedruckt, nur für Zeiten
      Selection.Tables(1).Rows(3).Range.Font.Hidden = True
      Selection.MoveDown Unit:=wdLine, Count:=1
      Selection.TypeParagraph
    Else
      blnAbZeile2 = True
    End If
    strTest = objPar.Range.Words(1)
    
    objPar.Range.Select
    Set objDialog = Dialogs(wdDialogToolsWordCount)
    ' Execute the dialog box in order to refresh its data.
    objDialog.Execute
    intAnzWords = objDialog.Words
    
    If intAnzWords > 0 Then
      Selection.Find.ClearFormatting
      Selection.Find.Replacement.ClearFormatting
      With Selection.Find
        .Text = " "
        .Replacement.Text = "^t"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
      End With
      Selection.Find.Execute Replace:=wdReplaceAll
      
      Selection.ConvertToTable Separator:=wdSeparateByTabs, _
        NumColumns:=intAnzWords, NumRows:=1, Format:=wdTableFormatNone, ApplyBorders:=True, _
         ApplyShading:=True, ApplyFont:=True, ApplyColor:=True, ApplyHeadingRows _
        :=True, ApplyLastRow:=False, ApplyFirstColumn:=True, ApplyLastColumn:= _
        False, AutoFit:=True, AutoFitBehavior:=wdAutoFitContent
      
      Selection.Tables(1).AutoFitBehavior (wdAutoFitContent)
    End If
  Next
  
  Selection.InsertRowsBelow 2
  Selection.MoveDown Unit:=wdLine, Count:=1
  Selection.TypeParagraph
  
  'Bildschirmupdate wieder aktivieren
  Application.ScreenUpdating = True
  
End Sub