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
Related
I am enumerating tables in Microsoft Word in a following way:
Dim doc As Document, t As Table
Set doc = ActiveDocument
For Each t In doc.Tables
Next t
Now I would like to find the nearest paragraph with "Heading 2" style above the table and get it's text into a variable. Great if it could be accomplished without changing the selection focus in the document.
I can enumerate paragraphs in the document, but how to determine that some paragraph is above some table?
I solved that by building a list of paragraph start positions:
Private Type CaptionRec
Text As String
EndPos As Long
End Type
Dim caps() As CaptionRec
Dim i As Long
Dim p As Paragraph
ReDim caps(0)
i = 0
For Each p In doc.Paragraphs
If p.Style = "Überschrift 2" Then
i = i + 1
ReDim Preserve caps(i)
caps(i).Text = TrimGarbageAtEnd(p.Range.Text)
caps(i).EndPos = p.Range.Start 'Ok, this should be the end, not the start
End If
Next p
... and finding the minimum distance between table start and a "Heading 2" paragraph from array:
Public Function GetClosestCaption(tableStart As Long, ByRef caps() As CaptionRec) As String
Dim cap As CaptionRec, distance As Long, minDistance As Long, res As String, i As Long
minDistance = 2147483647 'Max long
res = ""
For i = LBound(caps) To UBound(caps)
cap = caps(i)
distance = tableStart - cap.EndPos
If distance >= 0 Then
If distance < minDistance Then
minDistance = distance
res = cap.Text
End If
End If
Next i
GetClosestCaption = res
End Function
The routine gets called in a following loop:
Public Sub MainRoutine()
For Each t In doc.Tables
If table_validity_criteria_go_here Then
caption = GetClosestCaption(t.Range.Start, caps)
For Each r In t.Rows
'Enumerate rows
Next r
End If
Next t
End Sub
An alternative is to reverse the logic. Instead of processing the tables and then looking for the associated heading, find the headings then process the tables within the range of the heading level, For example:
Sub FindHeading2Ranges()
Dim findRange As Range
Dim headingRange As Range
Set findRange = ActiveDocument.Content
With findRange.Find
.ClearFormatting
.Forward = True
.Wrap = wdFindStop
.Format = True
.Style = ActiveDocument.Styles(wdStyleHeading2)
Do While .Execute
Set headingRange = findRange.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
If headingRange.Tables.Count > 0 Then
ProcessTables headingRange, TrimGarbageAtEnd(findRange.text)
End If
findRange.Collapse wdCollapseEnd
Loop
End With
End Sub
Sub ProcessTables(headingRange As Range, caption As String)
Dim t As Table
For Each t In headingRange.Tables
If table_validity_criteria_go_here Then
For Each r In t.Rows
'Enumerate rows
Next r
End If
Next t
End Sub
I have the following code that deletes the paragraph following any entirely bold paragraphs (i.e. deletes blank lines following subheadings), but this has caused an issue with the part of my macro that converts text to tables, in that it deletes the content following a table header when the table has bold headers. Is there a way I can get this code to ignore tables?
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.Bold = True Then para.Next.Range.Delete
Next para
You can utilize the Information property of the Range.
Try something like:
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.Bold = True And Not para.Range.Information(wdWithInTable) Then para.Range.Next.Delete
Next para
My word document template has several local styles that, combined, make a box (boxPara, boxNote, boxTitle, etc). Unfortunately all my boxes are missing the boxTitle paragraphs. My goal is to have a macro that looks for the first boxPara and adds in a blank boxTitle before it - then looks for the boxNote (last item in the box) to reset.
Problem is I'm having difficulty styling the paragraph. The closest I've come is styling the current paragraph wrong, inserting the new paragraph, then re-styling the current paragraph correctly. This seems rather...wrong. And I'd also like to be able to set the text of the inserted paragraph.
Sub addTag()
Dim BoxStart As Integer
Dim Para As Word.Paragraph
BoxStart = 0
For Each Para In ActiveDocument.Paragraphs
If Para.Format.Style = "BoxParagraph" And BoxStart = 0 Then
BoxStart = 1
' Selection.Paragraphs(1).Range.InsertParagraphBefore
Para.Format.Style = "BoxTitle"
Para.Range.InsertParagraph
Para.Format.Style = "BoxParagraph"
' Testing the flag works correctly
' Debug.Print BoxStart
' Debug.Print Para.Range.Text
ElseIf Para.Format.Style = "BoxNote" Then
BoxStart = 0
' Debug.Print BoxStart
End If
Next
End Sub
Here is the solution:
Dim BoxStart As Integer
Dim Para As Word.Paragraph
BoxStart = 0
For Each Para In ActiveDocument.Paragraphs
If Para.Format.Style = "BoxParagraph" And BoxStart = 0 Then
BoxStart = 1
' Insert Box Title with tags before start of answer boxes
' Insert paragraph before current paragraph
Para.Range.InsertParagraphBefore
' Select current paragraph
Para.Range.Select
' Move to previous paragraph
Selection.MoveUp Unit:=wdParagraph, Count:=1
Selection.MoveEnd Unit:=wdCharacter, Count:=-1
' format previous pararaph
Selection.Paragraphs.Format.Style = "BoxTitle"
' Testing the flag works correctly
' Debug.Print BoxStart
' Debug.Print Para.Range.Text
ElseIf Para.Format.Style = "BoxNote" Then
BoxStart = 0
' Debug.Print BoxStart
End If
Next
End Sub
I have the code below without using Selection.
Sub Format paragraph()
Dim wdDoc As Document
With wdDoc.Range.Find
.Font.Size = 12
.Text = "?"
.Execute
End With
End Sub
When the character with font size = 12 is found, how can I change the format of the current paragraph? for example:
wdDoc.Paragraph(current).Font.Size = 14
wdDoc.Paragraph(current).Font.Color = wdBlue
Thanks for any help.
The trick is to work with a specific Range object, which can be used to access its "parent" paragraph. When Find.Execute is successful, the Range being searched contains the found item (same as the selection jumps to the found item). For example:
Sub Format paragraph()
Dim rng as Range, para as Paragraph
Dim wdDoc As Document
Set wdDoc = ActiveDocument. 'Missing in code in question...
Set rng = wdDoc.Content 'Content returns the Range
With rng.Find
.Font.Size = 12
.Text = "?"
If .Execute = True Then
Set para = rng.Paragraphs(1)
para.Font.Size = 14
para.Font.Color = wdBlue
End If
End With
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