Numbering word headings from excel - Code fails randomly

[askerh]

Hi

I want to create numbering of headings in word through a VBA excel code.

It runs sometimes and somtimes if fails. I can't figure out why so I've read a lot of threads but can't seem to find the problem.
I've added a pause function to be sure the doc is loaded.

I hopw somebody can help me with it.

Sub NumberingHeadings()
   Dim objWord As Object
   Dim objDoc As Object

   Set objWord = CreateObject("Word.Application")
   Set objDoc = objWord.Documents.Add
   objWord.Visible = True
   
   Tstart = Timer
   Tend = Start + 1
   Do
   DoEvents
   Loop Until Timer >= Tend
   
    With ListGalleries(wdOutlineNumberGallery).ListTemplates(1).ListLevels(1)
        .NumberFormat = "%1"
        .TrailingCharacter = wdTrailingTab
        .NumberStyle = wdListNumberStyleArabic
        .NumberPosition = CentimetersToPoints(0)
        .Alignment = wdListLevelAlignLeft
        .TextPosition = CentimetersToPoints(0.76)
        .TabPosition = wdUndefined
        .ResetOnHigher = 0
        .StartAt = 1
        .LinkedStyle = "Heading 1"
    End With
    With ListGalleries(wdOutlineNumberGallery).ListTemplates(1).ListLevels(2)
        .NumberFormat = "%1.%2"
        .TrailingCharacter = wdTrailingTab
        .NumberStyle = wdListNumberStyleArabic
        .NumberPosition = CentimetersToPoints(0)
        .Alignment = wdListLevelAlignLeft
        .TextPosition = CentimetersToPoints(1.02)
        .TabPosition = wdUndefined
        .ResetOnHigher = 1
        .StartAt = 1
        .LinkedStyle = "Heading 2"
    End With
    With ListGalleries(wdOutlineNumberGallery).ListTemplates(1).ListLevels(3)
        .NumberFormat = "%1.%2.%3"
        .TrailingCharacter = wdTrailingTab
        .NumberStyle = wdListNumberStyleArabic
        .NumberPosition = CentimetersToPoints(0)
        .Alignment = wdListLevelAlignLeft
        .TextPosition = CentimetersToPoints(1.27)
        .TabPosition = wdUndefined
        .ResetOnHigher = 2
        .StartAt = 1
        .LinkedStyle = "Heading 3"
    End With
    With ListGalleries(wdOutlineNumberGallery).ListTemplates(1).ListLevels(4)
        .NumberFormat = "%1.%2.%3.%4"
        .TrailingCharacter = wdTrailingTab
        .NumberStyle = wdListNumberStyleArabic
        .NumberPosition = CentimetersToPoints(0)
        .Alignment = wdListLevelAlignLeft
        .TextPosition = CentimetersToPoints(1.52)
        .TabPosition = wdUndefined
        .ResetOnHigher = 3
        .StartAt = 1
        .LinkedStyle = "Heading 4"
    End With

    ListGalleries(wdOutlineNumberGallery).ListTemplates(1).Name = ""
    
    objWord.Selection.Range.ListFormat.ApplyListTemplateWithLevel ListTemplate:= _
        ListGalleries(wdOutlineNumberGallery).ListTemplates(1), _
        ContinuePreviousList:=False, ApplyTo:=wdListApplyToWholeList, _
        DefaultListBehavior:=wdWord10ListBehavior
   
MsgBox "done"

End Sub

 

[askerh]

I'm aware of early binding and are gonna convert the "wd"codes to numbers later on.

 

[askerh]

I finally figured it out.

I converted everything to latebinding and then it worked.

Sub NumberingHeadings()
   Dim objWord As Object
   Dim objDoc As Object

   Set objWord = CreateObject("Word.Application")
   Set objDoc = objWord.Documents.Add
   objWord.Visible = True
   
   Tstart = Timer
   Tend = Start + 1
   Do
   DoEvents
   Loop Until Timer >= Tend
   
    With objWord.ListGalleries(3).ListTemplates(1).ListLevels(1)
        .NumberFormat = "%1"
        .TrailingCharacter = 0
        .NumberStyle = 0
        .NumberPosition = objWord.CentimetersToPoints(0)
        .Alignment = 0
        .TextPosition = objWord.CentimetersToPoints(0.76)
        .ResetOnHigher = 0
        .StartAt = 1
        .LinkedStyle = "Heading 1"
    End With
    With objWord.ListGalleries(3).ListTemplates(1).ListLevels(2)
        .NumberFormat = "%1.%2"
        .TrailingCharacter = 0
        .NumberStyle = 0
        .NumberPosition = objWord.CentimetersToPoints(0)
        .Alignment = 0
        .TextPosition = objWord.CentimetersToPoints(1.02)
        .ResetOnHigher = 1
        .StartAt = 1
        .LinkedStyle = "Heading 2"
    End With
    With objWord.ListGalleries(3).ListTemplates(1).ListLevels(3)
        .NumberFormat = "%1.%2.%3"
        .TrailingCharacter = 0
        .NumberStyle = 0
        .NumberPosition = objWord.CentimetersToPoints(0)
        .Alignment = 0
        .TextPosition = objWord.CentimetersToPoints(1.27)
        .ResetOnHigher = 2
        .StartAt = 1
        .LinkedStyle = "Heading 3"
    End With
    With objWord.ListGalleries(3).ListTemplates(1).ListLevels(4)
        .NumberFormat = "%1.%2.%3.%4"
        .TrailingCharacter = 0
        .NumberStyle = 0
        .NumberPosition = objWord.CentimetersToPoints(0)
        .Alignment = 0
        .TextPosition = objWord.CentimetersToPoints(1.52)
        .ResetOnHigher = 3
        .StartAt = 1
        .LinkedStyle = "Heading 4"
    End With

    objWord.ListGalleries(3).ListTemplates(1).Name = ""
    
    objWord.Selection.Range.ListFormat.ApplyListTemplateWithLevel ListTemplate:= _
    objWord.ListGalleries(3).ListTemplates(1), _
    ContinuePreviousList:=False, _
    ApplyTo:=wdListApplyToWholeList, _
    DefaultListBehavior:=2
    

End Sub

 

[askerh]

I cleaned up the code

Sub NumberingHeadings()

Dim objWord As Object
Dim objDoc As Object

Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add
objWord.Visible = True
  
For i = 1 To 4
    With objWord.ListGalleries(3).ListTemplates(1).ListLevels(i)
    .TrailingCharacter = 0
    .NumberStyle = 0
    .NumberPosition = objWord.CentimetersToPoints(0)
    .Alignment = 0
    .StartAt = 1
    .LinkedStyle = "Heading " & i
        If i = 1 Then
            .TextPosition = objWord.CentimetersToPoints(0.76)
            .ResetOnHigher = 0
            .NumberFormat = "%1"
        ElseIf i = 2 Then
            .TextPosition = objWord.CentimetersToPoints(1.02)
            .ResetOnHigher = 1
            .NumberFormat = "%1.%2"
        ElseIf i = 3 Then
            .TextPosition = objWord.CentimetersToPoints(1.27)
            .ResetOnHigher = 2
            .NumberFormat = "%1.%2.%3"
        ElseIf i = 4 Then
            .TextPosition = objWord.CentimetersToPoints(1.52)
            .ResetOnHigher = 3
            .NumberFormat = "%1.%2.%3.%4"
    End If
    End With
Next i
  
objWord.Selection.Range.ListFormat.ApplyListTemplateWithLevel ListTemplate:= _
objWord.ListGalleries(3).ListTemplates(1), _
ContinuePreviousList:=False, _
ApplyTo:=wdListApplyToWholeList, _
DefaultListBehavior:=2

End Sub