CODEWITHSUNDEEP
vbams-wordinsert
Kevin
Kevin

Reputation: 299

Insert text every nth character in Office Word

I would like to insert a text in the word document using macro. For example, I have a paragraph like this:

This is an example. This is an example. This is an example. This is an example. This is an example. This is an example. This is an example.

I want to change it to something like this (insert @@@ at every 30th character).

This is an example. This is an_@@@_ example. This is an example. T_@@@_his is an example. This is an _@@@_example. This is an example. T_@@@_his is an example.

As you can see, _@@@_ sometimes breaks the word. So I also want to insert the text in the closest space instead of in the middle of the word.

The following code works, but it inserts the text right into the middle of the words.

Sub AddPageNumber1000Chr()

 Dim doc As Document
 Dim CharPerPage As Integer
 Set doc = ActiveDocument
 CharPerPage = 1000
 Dim k As Integer

 k = doc.Range.Characters.Count / CharPerPage - 1

 For i = doc.Range.Characters.Count To 1 Step -1
 If i Mod CharPerPage = 0 Then
 doc.Range.Characters(i) = doc.Range.Characters(i) & "@@@" & k & "@@@"
 k = k - 1
 End If

 If i = 1 Then
 doc.Range.Characters(i) = "Total Page: " & doc.Range.Characters.Count / CharPerPage & " x " & CharPerPage & vbNewLine & doc.Range.Characters(i)
 End If

 Next

End Sub

Upvotes: 0

Views: 767

Answers (2)

macropod
macropod

Reputation: 13515

For larger intervals, try:

Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range, i As Long, j As Long, k As Long, w As Long
Const l As Long = 500
With ActiveDocument
  Set Rng = .Range(0, 0)
  With .Range
    For i = 1 To .Characters.Count Step l
      Rng.MoveEnd wdCharacter, l
      With Rng
        .End = .Words.Last.End
        w = .ComputeStatistics(wdStatisticWords)
        .MoveEndWhile .ComputeStatistics(wdStatisticWords) = w, 1
        .MoveEndWhile .Characters.Last = " ", -1
        j = InStrRev(.Text, " ") - 1
        If (Len(.Text) - l) > (Len(.Text) - j) / 2 Then
          .End = .Words.Last.Start
        End If
        If .Words.Last.Characters.Last = " " Then .End = .Words.Last.End - 1
        k = k + Len(.Text)
        .Collapse wdCollapseEnd
        .InsertBefore " _@@@_" & k & "_@@@_"
        .Collapse wdCollapseEnd
      End With
    Next
  End With
End With
Application.ScreenUpdating = True
End Sub

Upvotes: 1

macropod
macropod

Reputation: 13515

Try something along the lines of:

Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, j As Long
Const l As Long = 50
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "<?{" & l - 1 & "}@>"
    .Replacement.Text = ""
    .Forward = True
    .Format = False
    .Wrap = wdFindStop
    .MatchWildcards = True
    .Execute
  End With
  Do While .Find.Found
    i = InStrRev(.Text, " ") - 1
    If (Len(.Text) - l) > (Len(.Text) - i) / 2 Then
      .Start = .Start + i
      .Collapse wdCollapseStart
      j = j + i
    Else
      j = j + Len(.Text)
    End If
    .Collapse wdCollapseEnd
    .InsertBefore " _@@@_" & j & "_@@@_"
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Application.ScreenUpdating = True
End Sub

where variable l is the desired interval.

Upvotes: 1

Related Questions