Reputation: 550

Word document formatting using vba

I have a document with the current formating

Title

Subtitle

SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText

here the para headings H1,H2,H3,H4 are bold i have just put sample text in place of the pragraph that appears below the heading

I need that doc to be formated to

Title Subtitle

H1: SampleText SampleText SampleText SampleText SampleText SampleTextSampleTextSampleText SampleText SampleText SampleText SampleText(para1)
H2: SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText(para2)
H3: SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText(para3)
H4: SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText SampleText(para4)

Currently i am adding a * to the start of the heading and a colon at the end. Using them as reference i am formating the paragraphs. here's the code that i am currently pondering on

    Sub wordfor()
    Dim oRng As Word.Range
    Dim flag As Integer
    Set oRng = ActiveDocument.Content

With oRng.Find
   .ClearFormatting
   .Text = ""
   .Font.Bold = True
        While .Execute
           oRng.Text = "*" + oRng.Text
           oRng.Font.Underline = True
           oRng.Text = oRng.Text + ":"
           oRng.Collapse wdCollapseEnd
        Wend
End With
Selection.HomeKey Unit:=wdStory
Do Until Selection.Information(wdFirstCharacterLineNumber) =   ThisDocument.BuiltInDocumentProperties("Number of lines").Value
'MsgBox (ThisDocument.BuiltInDocumentProperties("Number of lines").Value)
     Selection.HomeKey Unit:=wdLine
     Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
     If Selection.Text = "*" Then
         Selection.EndKey Unit:=wdLine
         Selection.TypeText Text:=" "
         Selection.Delete Unit:=wdCharacter, Count:=1

       Else
       Selection.MoveUp Unit:=wdLine, Count:=1
       Selection.EndKey Unit:=wdLine
       Selection.TypeText Text:=" "
       Selection.Delete Unit:=wdCharacter, Count:=1
       End If
Selection.MoveDown Unit:=wdLine, Count:=1
 Selection.MoveDown Unit:=wdLine, Count:=1
  Loop
    Selection.MoveUp Unit:=wdLine, Count:=1
         Selection.EndKey Unit:=wdLine
         Selection.TypeText Text:=" "
         Selection.Delete Unit:=wdCharacter, Count:=1
     Selection.HomeKey Unit:=wdStory
    With Selection.Find
        .Text = "*"
        .Replacement.Text = " "
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
     End With
Selection.Find.Execute Replace:=wdReplaceAll

Selection.HomeKey Unit:=wdStory
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Font.Bold = wdToggle
Selection.EndKey Unit:=wdLine
Selection.TypeParagraph
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.EndKey Unit:=wdStory, Extend:=wdExtend
With ListGalleries(wdBulletGallery).ListTemplates(1).ListLevels(1)
    .NumberFormat = ChrW(61623)
    .TrailingCharacter = wdTrailingTab
    .NumberStyle = wdListNumberStyleBullet
    .NumberPosition = InchesToPoints(0.25)
    .Alignment = wdListLevelAlignLeft
    .TextPosition = InchesToPoints(0.5)
    .TabPosition = InchesToPoints(0.5)
    .ResetOnHigher = 0
    .StartAt = 1
    With .Font
        .Bold = wdUndefined
        .Italic = wdUndefined
        .StrikeThrough = wdUndefined
        .Subscript = wdUndefined
        .Superscript = wdUndefined
        .Shadow = wdUndefined
        .Outline = wdUndefined
        .Emboss = wdUndefined
        .Engrave = wdUndefined
        .AllCaps = wdUndefined
        .Hidden = wdUndefined
        .Underline = wdUndefined
        .Color = wdUndefined
        .Size = wdUndefined
        .Animation = wdUndefined
        .DoubleStrikeThrough = wdUndefined
        .Name = "Symbol"
    End With
    .LinkedStyle = ""
End With
ListGalleries(wdBulletGallery).ListTemplates(1).Name = ""
Selection.Range.ListFormat.ApplyListTemplate ListTemplate:=ListGalleries( _
    wdBulletGallery).ListTemplates(1), ContinuePreviousList:=False, ApplyTo:= _
    wdListApplyToWholeList, DefaultListBehavior:=wdWord10ListBehavior

End Sub

But the code is going into an infinite loop.

Upvotes: 0

Answers (2)

ramses1592

Reputation: 550

After a lot of trail and error finally i found a solution:

Sub Word_Format()
Call copy_clipboard
Call create_wildcards
Call remove_spaces
Call separate_bpts
Call underline
Call add_Bullets
Call remove_wildcards
End Sub

Function copy_clipboard()
Dim rngFrom, rngTo
rngFrom = Selection.Start
Selection.PasteAndFormat wdFormatOriginalFormatting
rngTo = Selection.End
ActiveDocument.Range(rngFrom, rngTo).Select
ActiveDocument.Paragraphs(4).Range.Select
Selection.CopyFormat
ActiveDocument.Paragraphs(1).Range.Select  
Selection.PasteFormat
ActiveDocument.Paragraphs(2).Range.Select
Selection.PasteFormat
End Function

Function create_wildcards()
Dim oRng As Word.Range
Dim flag As Integer
Set oRng = ActiveDocument.Content

With oRng.Find
.ClearFormatting
.Text = ""
.Font.Bold = True
    While .Execute
        oRng.InsertBefore Text:="?"
        oRng.InsertAfter Text:=":}"
        oRng.Select
        'Selection.TypeBackspace
        'oRng.Text = oRng.Text + ": "
        oRng.Font.underline = True
        oRng.Collapse wdCollapseEnd
    Wend
End With
End Function

Function remove_spaces()
Dim selectedText As String
Dim textLength As Integer

Selection.WholeStory
selectedText = Selection.Text

' If no text is selected, this prevents this subroutine from typing another
' copy of the character following the cursor into the document
    If Len(selectedText) <= 1 Then
Exit Function
    End If

' Replace all carriage returns and line feeds in the selected text with spaces
selectedText = Replace(selectedText, vbCr, " ")
selectedText = Replace(selectedText, vbLf, " ")

' Get rid of repeated spaces
Do
    textLength = Len(selectedText)
    selectedText = Replace(selectedText, "  ", " ")
Loop While textLength <> Len(selectedText)

' Replace the selected text in the document with the modified text
Selection.TypeText (selectedText)

End Function

Function separate_bpts()
Dim oRng As Word.Range
Dim flag As Integer
Set oRng = ActiveDocument.Content

With oRng.Find
.ClearFormatting
.Text = "?"
    While .Execute
        oRng.Text = vbCrLf + oRng.Text
        oRng.Font.underline = True
         oRng.Collapse wdCollapseEnd
    Wend
End With

End Function

Function add_Bullets()
ActiveDocument.Select
Selection.HomeKey unit:=wdStory
Selection.EndKey unit:=wdLine, Extend:=wdExtend
Selection.Font.Bold = wdToggle
Selection.EndKey unit:=wdLine
Selection.TypeParagraph
Selection.MoveDown unit:=wdLine, Count:=1
Selection.EndKey unit:=wdStory, Extend:=wdExtend
Selection.Style = ActiveDocument.Styles("No Spacing")
With Selection.Font
.Name = Frutiger45Light
.Size = 9
End With
With ListGalleries(wdBulletGallery).ListTemplates(1).ListLevels(1)
    .NumberFormat = ChrW(61623)
    .TrailingCharacter = wdTrailingTab
    .NumberStyle = wdListNumberStyleBullet
    .NumberPosition = InchesToPoints(0.25)
    .Alignment = wdListLevelAlignLeft
    .TextPosition = InchesToPoints(0.5)
    .TabPosition = wdUndefined
    .ResetOnHigher = 0
    .StartAt = 1
    With .Font
        .Bold = wdUndefined
        .Italic = wdUndefined
        .StrikeThrough = wdUndefined
        .Subscript = wdUndefined
        .Superscript = wdUndefined
        .Shadow = wdUndefined
        .Outline = wdUndefined
        .Emboss = wdUndefined
        .Engrave = wdUndefined
        .AllCaps = wdUndefined
        .Hidden = wdUndefined
        .underline = wdUndefined
        .Color = wdUndefined
        .Size = wdUndefined
        .Animation = wdUndefined
        .DoubleStrikeThrough = wdUndefined
        .Name = "Symbol"
    End With
    .LinkedStyle = ""
End With
ListGalleries(wdBulletGallery).ListTemplates(1).Name = ""
Selection.Range.ListFormat.ApplyListTemplateWithLevel ListTemplate:= _
    ListGalleries(wdBulletGallery).ListTemplates(1), ContinuePreviousList:= _
    False, ApplyTo:=wdListApplyToSelection, DefaultListBehavior:= _
    wdWord10ListBehavior

Selection.Range.ListFormat.ListIndent
Selection.Range.ListFormat.ListIndent

    Selection.MoveUp unit:=wdLine, Count:=1
    Selection.TypeBackspace
End Function

Function remove_wildcards()
ActiveDocument.Select
Selection.WholeStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
    .Text = "?"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
    .Text = "}"
    .Replacement.Text = " "
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
    .Text = " :"
    .Replacement.Text = ":"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll

End Function

Function underline()
Dim str As String
Dim openPos As Integer
Dim closePos As Integer
Dim midBit, temp As String
Dim para As Paragraph

For Each para In ActiveDocument.Paragraphs

str = para.Range.Text
openPos = InStr(str, "?")
closePos = InStr(str, "}")
If openPos = 0 And closePos = 0 Then
GoTo nxt
 Else
 midBit = Mid(str, openPos + 1, closePos - openPos - 1)
 Call und(midBit)
 End If
 nxt: Next para
 End Function

 Function und(ByVal st As String)
 Dim oRng As Word.Range
 Dim flag As Integer
 Set oRng = ActiveDocument.Content

 With oRng.Find
 .ClearFormatting
 .Text = st
    While .Execute
        oRng.Font.underline = True
         oRng.Collapse wdCollapseEnd
    Wend
 End With
 End Function

Upvotes: 0

Dick Kusleika

Reputation: 33145

I think you problem is that you're trying to Find an asterisk which is a wildcard and therefore will always find something. If you search for ~*, the tilde escapes the wildcard.

You might consider a different approach.

Sub WordReFormat()

    Dim para As Paragraph

    For Each para In ThisDocument.Paragraphs
        If para.Range.Bold Then
            para.Range.Bold = False
            para.Range.InsertAfter ": "
            para.Range.Characters(para.Range.Characters.Count).Delete wdCharacter, 1
            para.Range.InsertBefore " * "
            para.Range.AutoFormat
        End If
    Next para

End Sub

Upvotes: 2

Word document formatting using vba

Answers (2)

Related Questions