VBA Word script Anzeige der Schriftart und Schriftgröße von Schnellbausteinen (BuildingBlocks)

tplanitz

Erfahrenes Mitglied
Hallo liebe Gemeinde,

Schnellbausteine erlauben es, dass man Sie mit unterschiedlichen Fonts(z.B Schriftart, Schriftgröße) anlegt.

Nun habe ich ein Script geschrieben, dass mir die sogenannten BuildingBlocks und deren BuildingBlockEntries herauszieht aus der Nomal.dotm oder aus der eigenen Schnellbaustein.dotm.

Leider gelingt mir der letzte Schritt nicht, die Fontart und die Fontgröße über ein RangeObject aneigen zu lassen.

Hat jemand einen Ansatz oder Idee wie ich weiter vorgehen muss?

HIer der Code:
Code:
Sub DisplayCustomBuildingBlock()
 
 Dim objTemplate As Template
 Dim objBB2 As BuildingBlock
 Dim objRange As Range
 Dim iCount As Integer
 Dim jCount As Integer
 Dim zCount As Integer
 
 ' Set the template to store the building block
 
 zCount = Templates.Count
 
 For iCount = 1 To zCount
 
 Debug.Print "==> Template Name: " + Templates(iCount).Name
 
    If Templates(iCount).Name = "Normal.dotm" Then
 
        Set objTemplate = Templates(iCount)
      
    End If
  
 Next iCount


Debug.Print "===> " + Str(iCount) + ". TEMPALTE NAME/TYPE: "; objTemplate.Path & Application.PathSeparator & objTemplate.Name & " template type: " & objTemplate.Type
 
' Parse the building block entries for text font and text size
 
 For iCount = 1 To objTemplate.BuildingBlockEntries.Count

     Set objBB2 = objTemplate.BuildingBlockEntries(iCount)

     selection.Text = objBB2.Value

     Set objRange = selection.Range
  
     ' This is working all names , types and categories are displayed
     Debug.Print "====> objBB2.Name: " + objBB2.Name + " ==> value: " + objBB2.Value + " ==> category: " + objBB2.Category.Name
      
     ' This does not work only the same fond and font size is displayed although three different Building Blocks are configured
     Debug.Print "+++++ " + objRange.Text + " Font: " + objRange.Font.Name + " Font Size: " + Str(objRange.Font.Size)
 
 Next iCount
 
End Sub
 
Zuletzt bearbeitet:
Hallo Alle,

mein Ziel wie oben beschrieben musste etwas angepasst werden.

Das Tool ändert nun bestehende BuildingBlockEntries und deren Font und Font Größe.

Sicher geht da noch mehr. Derzeit kann das tool nicht mit Feldern in Schnellbausteinen umgehen.

Evtl. kann das ja mal jemand brauchen und sich das als tool speichern.

Viel Spass damit:
Code:
Option Explicit

' rename the building blocks and change the fond style
Sub RenameBuildingBLocks()

 Dim objBBOrig As BuildingBlock
 Dim objBBTemp As BuildingBlock
 Dim objBBNeu As BuildingBlock

 Dim objTemplate As Template
 Dim objRange As Range
 
 ' Set the template to store the building block
 Dim iCount As Integer
 Dim jCount As Integer
 Dim zCount As Integer
 
 Dim sName As String
 
 '  Set the template where the building blocks are saved
 
 zCount = Templates.Count
 
 For iCount = 1 To zCount
 
    ' use this filter to find your template
    If Templates(iCount).Name = "Schnellbausteine-lernen.dotm" Then
    
        Debug.Print "==> Template Name: " + Templates(iCount).Name
 
        Set objTemplate = Templates(iCount)
        
    End If
    
 Next iCount
 
' some counter
 zCount = 0
 zCount = objTemplate.BuildingBlockEntries.Count
 jCount = zCount
 
For iCount = 1 To zCount
  
    Set objBBOrig = objTemplate.BuildingBlockEntries.Item(jCount)
    
    Debug.Print "===> objBBOrig Name: " + objBBOrig.Name
    
        ' use the collapsed the range, set the range, and add the text
        ' selection.Collapse
         Set objRange = selection.Range
         objRange.Text = objBBOrig.Value
         objRange.Font.Name = "Berlin Type Office"
         objRange.Font.Size = 40
         objRange.Font.Bold = True
 
         ' Add the building block to the template
         Set objBBTemp = objTemplate.BuildingBlockEntries.Add( _
         Name:="ETL-" + objBBOrig.Name, _
         Type:=wdTypeQuickParts, _
         Category:="Allgemein", _
         Range:=objRange _
         )
         Debug.Print "===> objBBTemp Name: " + objBBTemp.Name
    
         ' Delete the buidling block orig
         objBBOrig.Delete

        
         ' temp str for the name
         sName = Replace(objBBTemp.Name, "ETL-", "")
        
         ' Delete the buidling block temp
         objBBTemp.Delete
        
         ' rename
         Set objBBNeu = objTemplate.BuildingBlockEntries.Add( _
         Name:=sName, _
         Type:=wdTypeQuickParts, _
         Category:="Allgemein", _
         Range:=objRange _
         )        
        
         ' counter --
         jCount = jCount - 1
        
Next iCount

' set all to nothing
Set objBBOrig = Nothing
Set objBBNeu = Nothing
Set objBBTemp = Nothing
 
End Sub
 
Zurück