I am trying to create a word VBA that can justify all the text if the font size is 10, ignoring all the tables and shapes.
Some how, it doesn't work on large documents with thousands of paragraph as it will hang.
Anyway I can streamline this code to make it run more faster and efficient.
Sub JustifyAllTheText()
On Error Resume Next
Dim para As Paragraph
Dim searchRange As Range
Set searchRange = Selection.Range
searchRange.End = ActiveDocument.Content.End
For Each para In searchRange.Paragraphs
If para.Range.Font.Size = 10 And para.Range.Font.ColorIndex = wdBlack And Not para.Range.InlineShapes.count > 0 And Not para.Range.Information(wdWithInTable) Then
para.Range.ParagraphFormat.Alignment = wdAlignParagraphJustify
End If
Next para
Sub JustifyAllTheText()
On Error Resume Next
Dim para As Paragraph
Dim searchRange As Range
Set searchRange = Selection.Range
searchRange.End = ActiveDocument.Content.End
For Each para In searchRange.Paragraphs
If para.Range.Font.Size = 10 Then
If para.Range.Font.ColorIndex = wdBlack Then
If Not para.Range.InlineShapes.Count > 0 Then
If Not para.Range.Information(wdWithInTable) Then
para.Range.ParagraphFormat.Alignment = wdAlignParagraphJustify
End If
End If
End If
End If
Next para
End Sub
Is there a direct way that we can split a word revision in to set of revisions?
If cannot, In this below case,
This is related to my other issue.
The document has several paragraphs with each has its own applied style.
When take the inserted revision in the above example, I want to separate the revision by the inserted paragraph ending marks as then it will split into three revisions. And the solution should be a global solution which can be able to apply for any insertion whatever the user does.
For example :
Insertion can contain any number of paragraph ending marks within it.
Insertion can start with a paragraph ending mark
Paragraphs has separate paragraph styles applied and we need to keep them unchanged.
This is the code I have modified,I tried to separate the first paragraph and other paragraphs. But, I have stuck in the logic part.
Private Function RemoveParagraphEndingsFromRevisions(ByRef WordRange As Word.Range)
On Error GoTo ErrorHandler
Dim fTrackRevisions As Boolean
Dim objRevision As Word.Revision
Dim objRange1, objRange2 As Word.Range
Dim sPara, firstParaStyle As String
Dim stylesCollection As VBA.Collection
Dim count As Long
Set stylesCollection = New VBA.Collection
sPara = vbCr
With WordRange.Document
fTrackRevisions = .TrackRevisions
.TrackRevisions = False
End With
For Each objRevision In WordRange.Document.Revisions
'AllowTrackChangesForInsertion method checks whether the revision contains a text change
If AllowTrackChangesForInsertion(objRevision) = True Then
'If there are paragraph ending marks within the revision
If InStr(objRevision.Range.Text, sPara) > 0 Then
Set objRange1 = objRevision.Range.Duplicate
Set objRange2 = objRange1.Duplicate
firstParaStyle = objRange2.Paragraphs(1).Style
If (objRange1.Paragraphs.count > 1) Then
count = 2
Do While (count < objRange1.Paragraphs.count + 1)
stylesCollection.Add objRange1.Paragraphs(count).Style
count = count + 1
Loop
.........
Else
'When there's no inserted text after inserted end para mark
End If
End If
End If
Next
ErrorHandler:
WordRange.Document.TrackRevisions = fTrackRevisions
Set objRevision = Nothing
Set objRange1 = Nothing
Set objRange2 = Nothing
Set stylesCollection = Nothing
Select Case Err.Number
Case 0
Case Else
ShowUnexpectedError ErrorSource:="RemoveParasFromRevisions" & vbCr & Err.Source
End Select
End Function
Could anybody please help me with this.
Thank you.
I have able to implement a code that split a revision into revisions when have paragraph ending marks within it along with there applied styles.
Any improvements for this code snippet are really appreciated.
Private Function RemoveParagraphEndingsFromRevisions(ByRef WordRange As Word.Range)
On Error GoTo ErrorHandler
Dim fTrackRevisions As Boolean
Dim objRevision As Word.Revision
Dim objRange1 As Word.Range
Dim sPara As String
Dim firstParaStyle As String
Dim objParagraph As Word.Paragraph
sPara = vbCr
With WordRange.Document
fTrackRevisions = .TrackRevisions
.TrackRevisions = False
End With
For Each objRevision In WordRange.Document.Revisions
If AllowTrackChangesForInsertion(objRevision) = True Then
'does the revision contains paragraph ending marks within it
If InStr(objRevision.Range.Text, sPara) > 0 Then
Set objRange1 = objRevision.Range.Duplicate
Set objParagraph = objRange1.Paragraphs.First
'Get the styles of the first paragraph of the revision
firstParaStyle = objRange1.Paragraphs.First.Style
objParagraph.Range.Collapse wdCollapseEnd
'Insert another paragraph as "buffer"
objParagraph.Range.InsertAfter sPara
'Ensure the first paragraph has its original style
objRange1.Paragraphs.First.Style = firstParaStyle
'Delete the "buffer" paragraph
objParagraph.Range.MoveStart wdCharacter, 1
objParagraph.Range.Characters.Last.Delete
End If
End If
Next
ErrorHandler:
WordRange.Document.TrackRevisions = fTrackRevisions
Set objRevision = Nothing
Set objRange1 = Nothing
Set objParagraph = Nothing
Select Case Err.Number
Case 0
Case Else
ShowUnexpectedError ErrorSource:="RemoveParasFromRevisions" & vbCr & Err.Source
End Select
End Function
I need to delete all paragraph marks of ActiveDocument except:
The one which is having Bold-Font after. (Example is in picture, attached)
Bullet-Point paragraph marks.
By using Ranges I came up with the following Code. It works well, but it is not detecting the bullet points. What should I do? I am beginner to use Ranges.
Sub PARAGRAPHSmark()
Dim PARA As Range
Dim p As Range
Set PARA = ActiveDocument.Range
PARA.MoveEnd wdCharacter, -1
Do
Set p = PARA.Duplicate
p.Find.Execute "^13"
PARA.Start = p.End
If p.Find.Found Then
p.MoveEnd wdCharacter, 1
If p.Bold = False Then
p.MoveEnd wdCharacter, -1
' This `If` condition is not detecting bullet when actually its there.
If p.ListFormat.ListType = wdListListNumOnly Or p.ListFormat.ListType = wdListSimpleNumbering Or p.ListFormat.ListType = wdListBullet Then
Else
p.Delete
p.InsertAfter " "
End If
Else
End If
Else
Exit Do
End If
Loop
End Sub
Illustration:
I wrote a macro to delete all the empty paragraphs in my document, but it exhibits weird behavior: If there are a number of empty paragraphs at the very end of the document, about half of them are deleted. Repeatedly running the macro gradually eliminates the empty paragraphs until only one empty paragraph remains. Even if there is a boundary condition so that I need a line of code to delete the last paragraph, but I still don't understand why only half of the empty paragraphs at the end are deleted. Can anyone explain why this is happening and how to correct this behavior? As an aside, I searched online and saw numerous posts about detecting paragraph markers (^p, ^13, and others, but only searching vbCr worked, which is another minor puzzle.)
Sub Delete_Empty__Paras_2() 'This macro looks for empty paragraphs and deletes them.
Dim original_num_of_paras_in_doc As Integer
Dim num_of_deleted_paras As Integer
original_num_of_paras_in_doc = ActiveDocument.Paragraphs.Count 'Count the number of paragraphs in the document to start
num_of_deleted_paras = 0 'In the beginning, no paragraphs have been deleted
Selection.HomeKey Unit:=wdStory 'Go to the beginning of the document.
For current_para_number = 1 To original_num_of_paras_in_doc 'Process each paragraph in the document, one by one.
If current_para_number + num_of_deleted_paras > original_num_of_paras_in_doc Then 'Stop processing paragraphs when the loop has processed every paragraph.
Exit For
Else 'If the system just deleted the 3rd paragraph of the document because
' it's empty, the next paragraph processed is the 3rd one again,
'so when we iterate the counter, we have to subtract the number of deleted paragraphs to account for this.
Set paraRange = ActiveDocument.Paragraphs(current_para_number - num_of_deleted_paras).Range
paratext = paraRange.Text
If paratext = vbCr Then 'Is the paragraph empty? (By the way, checking for vbCr is the only method that worked for checking for empty paras.)
paratext = "" 'Delete the paragraph.
ActiveDocument.Paragraphs(current_para_number - num_of_deleted_paras).Range.Text = paratext
num_of_deleted_paras = num_of_deleted_paras + 1 'Iterate the count of deleted paras.
End If
End If
Next current_para_number
End Sub
This code will delete all blank paragraphs...
Sub RemoveBlankParas()
Dim oDoc As Word.Document
Dim i As Long
Dim oRng As Range
Dim lParas As Long
Set oDoc = ActiveDocument
lParas = oDoc.Paragraphs.Count ' Total paragraph count
Set oRng = ActiveDocument.Range
For i = lParas To 1 Step -1
oRng.Select
lEnd = lEnd + oRng.Paragraphs.Count ' Keep track of how many processed
If Len(ActiveDocument.Paragraphs(i).Range.Text) = 1 Then
ActiveDocument.Paragraphs(i).Range.Delete
End If
Next i
Set para = Nothing
Set oDoc = Nothing
Exit Sub
End Sub
You can replace the paragraph marks:
ActiveDocument.Range.Find.Execute FindText:="^p^p", ReplaceWith:="^p", Replace:=wdReplaceAll
ActiveDocument.Range.Find.Execute "^p^p", , , , , , , , , "^p", wdReplaceAll ' might be needed more than once
I'm trying to use a macro to expedite some LabVIEW code that needs to write a report automatically for a client, it needs to be formatted a certain way, though. The issue I'm having is when I execute the code below with one format, and then execute it again using a different format, it reformats the previous line written, as well. I've been able to solve this using a .TypeParagraph, but I don't always want a carriage return after a line of text is written to the document. I've tried searching for how to break Word's selection, but have so far been unsuccessful.
Here's the code I'm executing:
Sub TextLineCreate(Text As String, Optional Style As String = "Title", Optional Bold As Boolean = True, Optional Italics As Boolean = False, Optional Underline As Boolean = False, Optional FontSize As Long = 16, Optional Alignment As String = "Center", Optional LineReturn As Long = 1)
'
' TextLineCreate Macro
' Creates a Formatted String with Text 'String'
'
Dim PreviousStyle As Style
Dim I As Long
Set PreviousStyle = Selection.Style ' Saves previous style configuration.
'Selection.EndKey Unit:=wdStory ' Moves to the end of the document.
With Selection
.Style = ActiveDocument.Styles(Style)
Select Case (Alignment)
Case ("Center"):
.ParagraphFormat.Alignment = wdAlignParagraphCenter
Case ("Left"):
.ParagraphFormat.Alignment = wdAlignParagraphLeft
Case ("Right"):
.ParagraphFormat.Alignment = wdAlignParagraphRight
Case Else
.ParagraphFormat.Alignment = wdAlignParagraphCenter
End Select
If (Underline) Then
.Font.UnderlineColor = wdColorAutomatic
.Font.Underline = wdUnderlineSingle
Else
.Font.Underline = wdUnderlineNone
End If
.Font.Bold = Bold ' Sets the boldness
If (Italics) Then
.Font.Italic = True
Else
.Font.Italic = False
End If
' Sets the Italicization
.Font.Size = FontSize ' Sets the font size.
.TypeText Text:=Text
.TypeParagraph
If Bold Then .Font.Bold = False ' Restores previous bold setting
.Style = PreviousStyle ' Restores previous style configuration.
For I = 1 To LineReturn
.TypeParagraph ' Adds any desired white space
Next I
End With
End Sub
Here is a link to a picture of the problem: https://imgur.com/a/CEk4Q
Here is a link to a picture of the problem with the return characters visualized: https://imgur.com/a/NG0M8
[UPDATE] Okay, I've continued working on this, and I have narrowed down the problem
All I need to do, is to be able to produce one line of text that has a bold and underlined section title, and a normal text description after. I have tried a couple different methods and even consulted my macro book for excel that has 1 chapter on automating excel. Here is the code that I have right now, along with pictures of what is happening upon execution.
Sub TextLineCreate(Text As String, _
Optional Style As String = "Normal", _
Optional Bold As Boolean = True, _
Optional Italics As Boolean, _
Optional Underline As Boolean, _
Optional FontSize As Long = 16, _
Optional Alignment As String, _
Optional LineReturn As Long)
' TextLineCreate Macro
' Creates a Formatted String with Text 'String'
Dim Rng As Range
Dim TextRng As Range
Dim Align As Variant
Dim i As Long
Dim CharCount As Long
Dim StartIndex As Long
Dim EndIndex As Long
Set Rng = Selection.Range
With Rng
.Style = ActiveDocument.Styles(Style)
.Text = Text
CharCount = ActiveDocument.Characters.Count ' Determines how many characters are on the sheet
StartIndex = CharCount - Len(Text) - 1 ' Determines the character index of where the Text's characters begin
EndIndex = CharCount - 1 ' Determines the character index of where the Text's characters end
Set TextRng = ActiveDocument.Range(StartIndex, EndIndex) ' Determines the range of characters that the text will occupy
TextRng.Select
With Selection
With .Font
.Size = FontSize ' Sets the font size
.Bold = Bold ' Sets the boldness
.Italic = Italics ' Sets the italics
If (Underline) Then ' Sets the Underline
.UnderlineColor = wdColorAutomatic
.Underline = wdUnderlineSingle
Else
.Underline = wdUnderlineNone
End If
End With
End With
Select Case (Alignment)
Case ("Center"):
.ParagraphFormat.Alignment = wdAlignParagraphCenter
Case ("Left"):
.ParagraphFormat.Alignment = wdAlignParagraphLeft
Case ("Right"):
.ParagraphFormat.Alignment = wdAlignParagraphRight
Case Else
.ParagraphFormat.Alignment = wdAlignParagraphCenter
End Select
If LineReturn Then
.Collapse wdCollapseEnd
.Text = String(LineReturn, Chr(13)) ' Adds any desired white space
End If
End With
Selection.EndKey Unit:=wdStory, Extend:=wdMove ' Moves to the end of the document.
End Sub
Sub HeaderTest()
TextLineCreate "Message:", Underline:=True, LineReturn:=0
TextLineCreate " Hello World", Style:="Normal", Bold:=False, FontSize:=12, LineReturn:=1
End Sub
Updated Images: https://imgur.com/a/TQVYI
Option Explicit
Enum Nft ' Index to Array 'Formats'
NftPara
NftFont
NftNew = 0
NftAlign
NftSpace
NftFontSize
NftBold
NftItalic
NftUnderline
End Enum
Private Sub Call_InsertText()
' 03 Dec 2017
' ============================================================
' 'InsertText' requires 2 arguments as follows.
' The two arguments are separated from each other by a comma.
' 1. 'Text' is the text to be inserted.
' It must be provided but can be a null string.
' 2. 'Arg' is a string, consisting of two parts as follows.
' A) Paragraph formatting codes
' B) Font formatting codes
' Either or both can be omitted but if part B is present
' it MUST be preceded by a semicolon,
' even if part A is omitted.
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' Formatting Codes can be partially or entirely omitted,
' can be written in any sequence, upper or lower case,
' with or without spaces between them.
' If omitted, no setting will be applied, for example,
' if Bold isn't specified the inserted text will not be bold,
' if no space is specified, no space will be added,
' if no new line is specified the text will be added to the
' last existing line.
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' Paragraph formatting codes
' - N = New paragraph (the text will be inserted in a new line)
' - L = Left (Default: text will be aligned at the left margin)
' - R = Right (text will be aligned at the right margin)
' - C = Centre (text will be aligned at the centre)
' - 1 = A multiple of 12 pt added above or below a paragraph.
' Can be positive or negative and include decimal fractions.
' The default = 0
' For example, 2.5 adds 2 and a half lines to the space already
' specified for insertion below the indicated paragraph,
' -0.5 reduces the space by half a line.
' If the space to be reduced is larger than available below the
' indicated paragraph, the space will be added above it.
' Paragraph formatting rules
' If N (=New paragraph) is specified the formatting will be applied
' to the new paragraph. Otherwise the format will be applied to
' the last existing paragraph. L, R or C will over-write previously
' specified settings. Specified space is added to existing.
' Font formatting codes
' - B = Bold (the default is Not Bold)
' - I = Italics (the default is Not Italic)
' - U = Underlined (Single line. The default is no underline)
' - 9 = A number expressing the font size.
' The default size is determined by the "Normal" style.
' Font formatting rules
' Font formatting is applied the the currently specified text.
' Formatting applied to previously inserted texts can't be changed
' by this program.
' Exception "Title"
' The program will apply the "Title" style to the first line in a document,
' formatting both the paragraph and the font with that style.
' Any different formatting specified for that line will over-ride
' the style's settings.
' The program will insert a new, blank line following the title, ignoring
' the N (= New line) instruction if given for the next line. If spacing
' use the spacing functinality for the paragraph format.
' Notes
' This program doesn't specify a font, for example, which is presumed to be
' the font provided by the "Normal" style. The "Normal" style is applied to
' all new paragraphs this program inserts.
' ============================================================
' Run the code below to create a new document using the specified formatting
InsertText "Document title", "C ;iu 27"
InsertText "First line", "N1.8;8i" ' N will be ignored
InsertText "Second line", "N"
InsertText "Add Bold Large", "1.5;24Bi"
InsertText "Add Tiny", "-1;6u"
InsertText "Another line", "N"
InsertText "Another new line, right aligned, without space", "NR;b"
InsertText "Add a left aligned line", "Nl;iu"
End Sub
Sub InsertText(ByVal Text As String, _
Optional ByVal Arg As String)
' 03 Dec 2017
' insert the specified text, in the specified format,
' at the end of the ActiveDocument
' TextLineCreate Macro
' Creates a Formatted String with String 'Text'
Dim Formats() As Variant
Dim Rng As Range
Dim Para As Paragraph
Dim Tmp As Single
If GetArguments(Arg, Formats) Then
Set Rng = ActiveDocument.Range
With Rng
.Collapse wdCollapseEnd
Set Para = .Paragraphs(1)
If .End <= 1 Then
' the document is blank:-
' insert the Text as Title and insert a blank paragraph below it
.InsertParagraphBefore
Set Para = .Paragraphs(1)
Para.Style = "Title"
.Collapse wdCollapseStart
Else
' the 2nd para was inserted by the program together with the title
If (ActiveDocument.Paragraphs.Count = 2) And _
(Len(Para.Range.Text) < 2) Then Formats(NftNew) = False
If Formats(NftNew) = vbTrue Then
.InsertParagraphAfter
.Collapse wdCollapseEnd
Set Para = .Paragraphs(1)
Para.Style = wdStyleNormal
End If
End If
' add a space between components
If (Len(Para.Range.Text) > 1) And _
(Right(Para.Range.Text, 1) <> " ") And _
(Asc(Text) <> 32) Then
.InsertBefore " "
.Collapse wdCollapseEnd
End If
.Text = Text
With .Font ' format the Font
If Formats(NftFontSize) <> wdUndefined Then
If .Size <> Formats(NftFontSize) Then .Size = Formats(NftFontSize)
End If
If Formats(NftBold) <> wdUndefined Then
If .Bold <> Formats(NftBold) Then .Bold = Formats(NftBold)
End If
If Formats(NftItalic) <> wdUndefined Then
If .Italic <> Formats(NftItalic) Then .Italic = Formats(NftItalic)
End If
If Formats(NftUnderline) <> wdUndefined Then
.UnderlineColor = wdColorAutomatic
.Underline = wdUnderlineSingle
End If
End With
End With
With Para ' format the paragraph
If Formats(NftAlign) <> wdUndefined Then
If .Alignment <> Formats(NftAlign) Then .Alignment = Formats(NftAlign)
End If
If Formats(NftSpace) <> wdUndefined Then
Tmp = .SpaceAfter + Formats(NftSpace)
If Tmp < 0 Then
.SpaceAfter = 0
.SpaceBefore = Abs(Tmp)
Else
.SpaceAfter = Tmp
End If
End If
End With
End If
End Sub
Private Function GetArguments(ByVal Arg As String, _
Formats() As Variant) As Boolean
' 03 Dec 2017
' assign parameter values to Formats()
' return False if fault was found in Arg
Dim Fun As Boolean ' function return value
Dim Sp() As String ' split of Arg
Dim Fmt() As Variant ' split of Sp
Dim i As Long, n As Long
ReDim Formats(NftUnderline)
For i = LBound(Formats) To UBound(Formats)
Formats(i) = wdUndefined
Next i
Arg = UCase(Replace(Arg, " ", ""))
If Len(Arg) Then
Sp = Split(Arg, ";")
End If
Fun = Not ((Not Sp) = -1) ' not empty array
If Fun Then
ReDim Fmt(NftFont)
For i = NftPara To NftFont
If i <= UBound(Sp) Then
Fmt(i) = SplitArg(Sp(i))
n = 0
Do While Len(Fmt(i)(n))
If IsNumeric(Fmt(i)(n)) Then
If i = NftPara Then
Formats(NftSpace) = Int(Val(Fmt(i)(n)) * 12)
Else
Formats(NftFontSize) = Val(Fmt(i)(n))
End If
Else
Select Case Fmt(i)(n)
Case "N"
Formats(NftNew) = vbTrue
Case "L", "C", "R"
Formats(NftAlign) = InStr("LCR", Fmt(i)(n)) - 1
Case "B"
Formats(NftBold) = vbTrue
Case "I"
Formats(NftItalic) = vbTrue
Case "U"
Formats(NftUnderline) = vbTrue
Case Else
MsgBox "The formatting argument """ & Fmt(i)(n) & _
""" isn't recognised." & vbCr & _
"Please review the instruction.", _
vbInformation, "Invalid formatting code"
Fun = False
Exit Do
End Select
End If
n = n + 1
If n > UBound(Fmt(i)) Then Exit Do
Loop
End If
If Not Fun Then Exit For
Next i
End If
GetArguments = Fun
End Function
Private Function SplitArg(ByVal Arg As String) As Variant
' 03 Dec 2017
Dim Fun() As String
Dim Ch As String
Dim i As Integer, n As Integer
ReDim Fun(Len(Arg))
For i = 1 To Len(Arg)
Ch = Mid(Arg, i, 1)
If IsNumeric(Ch) Or (InStr(".-", Ch) > 0) Then
If Len(Fun(n)) Then
If (Not IsNumeric(Fun(n))) And (Fun(n) <> ".") And _
(Fun(n) <> "-") And (Fun(n) <> "-.") Then n = n + 1
End If
Fun(n) = Fun(n) & Ch
Else
If Len(Fun(n)) Then n = n + 1
Fun(n) = Ch
End If
Next i
ReDim Preserve Fun(n)
SplitArg = Fun
End Function