vbaobjectms-wordwidthdocx
Word VBA to check every object in the doc is smaller than page margin
I need to check every object (table, figure) in a large document and ensure they do not go outside of margins? i.e., compare each object's width with page width... then flag with <TOO_LARGE> on top of every page for easy search.
Thanks in advance! BT
I searched on the web and can't find anything to based off.
Solution
Because flag with <TOO_LARGE> on top of every page will change the original content, I bookmark those objects instead. You can try it first:
Only one kind PageSetup:
Sub CheckObjectMargins()
Dim doc As Word.Document, rng As Range, i As Long, c As Word.cell
Dim obj As Object, objWidth As Single
Dim objs As New VBA.Collection
Dim pageWidth As Long
Dim tooLarge As Boolean, ur As UndoRecord
Set ur = Word.Application.UndoRecord
ur.StartCustomRecord "CheckObjectMargins"
Set doc = ActiveDocument
' Get the page width.
pageWidth = doc.PageSetup.pageWidth - doc.PageSetup.LeftMargin - doc.PageSetup.RightMargin
' Loop through all the inline shapes in the document.
For Each obj In doc.InlineShapes
' Check if the object's width is greater than the page width.
tooLarge = obj.Width > pageWidth
' If the object is too large, flag it with a bookmark.
If tooLarge Then
objs.Add obj
End If
Next obj
For Each obj In doc.Tables
' Check if the object's width is greater than the page width.
If Not obj.PreferredWidth = 9999999 Then
tooLarge = obj.PreferredWidth > pageWidth
Else
For Each c In obj.Range.Cells
If i = 0 Then
i = c.RowIndex
Else
If i < c.RowIndex Then
Exit For
End If
End If
objWidth = objWidth + c.Width
Next c
End If
tooLarge = objWidth > pageWidth
' If the object is too large, flag it with a bookmark.
If tooLarge Then
objs.Add obj
End If
objWidth = 0: i = 0
Next obj
For Each obj In doc.Shapes
' Check if the object's width is greater than the page width.
tooLarge = obj.Width > pageWidth
' If the object is too large, flag it with a bookmark.
If tooLarge Then
objs.Add obj
End If
Next obj
i = 0
For Each obj In objs
Set rng = obj.Range
i = i + 1
If rng.Information(wdInContentControl) Then
If rng.End + 1 < doc.Range.End Then
rng.SetRange rng.End + 1, rng.End + 1
Else
rng.SetRange rng.Start - 1, rng.Start - 1
End If
End If
' If the object is too large, flag it with a bookmark.
rng.Bookmarks.Add "TOO_LARGE" & i, rng
Next obj
ur.EndCustomRecord
End Sub
Multiple PageSetups:
... One other question, how to ensure that the pagewidth is checked in every section break (i.e., I have portrait/landscape/portrait/landscape page orientation within the same document)... I noticed that every object in landscape orientation is flagged. I tried to add "For Each Sec In doc.Section" to have pagewidth re-calculated, but it is still using the portrait one to check for the entire document...
Sub CheckObjectMargins()
Dim doc As Word.Document, rng As Range, i As Long, c As Word.cell
Dim obj As Object, objWidth As Single
Dim objs As New VBA.Collection
Dim pageWidth As Long
Dim tooLarge As Boolean, ur As UndoRecord
Dim sec As Word.Section, sRng As Range
Set ur = Word.Application.UndoRecord
ur.StartCustomRecord "CheckObjectMargins"
Set doc = ActiveDocument
Set sRng = selection.Range.Duplicate
For Each sec In doc.Sections
' Get the page width.
'pageWidth = doc.PageSetup.pageWidth - doc.PageSetup.LeftMargin - doc.PageSetup.RightMargin
pageWidth = sec.PageSetup.pageWidth - sec.PageSetup.LeftMargin - sec.PageSetup.RightMargin
' Loop through all the inline shapes in the document.
For Each obj In sec.Range.InlineShapes
' Check if the object's width is greater than the page width.
tooLarge = obj.Width > pageWidth
' If the object is too large, flag it with a bookmark.
If tooLarge Then
objs.Add obj
End If
Next obj
For Each obj In sec.Range.Tables
' Check if the object's width is greater than the page width.
If Not obj.PreferredWidth = 9999999 Then
tooLarge = obj.PreferredWidth > pageWidth
Else
For Each c In obj.Range.Cells
If i = 0 Then
i = c.RowIndex
Else
If i < c.RowIndex Then
Exit For
End If
End If
objWidth = objWidth + c.Width
Next c
End If
tooLarge = objWidth > pageWidth
' If the object is too large, flag it with a bookmark.
If tooLarge Then
objs.Add obj
End If
objWidth = 0: i = 0
Next obj
For Each obj In sec.Range.ShapeRange
' Check if the object's width is greater than the page width.
tooLarge = obj.Width > pageWidth
' If the object is too large, flag it with a bookmark.
If tooLarge Then
objs.Add obj
End If
Next obj
Next sec
i = 0
For Each obj In objs
i = i + 1
If VBA.TypeName(obj) = "Shape" Then
' If the object is too large, flag it with a bookmark.
obj.Select
doc.Bookmarks.Add "TOO_LARGE" & i, selection.Range
Else
Set rng = obj.Range
If rng.Information(wdInContentControl) Then
If rng.End + 1 < doc.Range.End Then
rng.SetRange rng.End + 1, rng.End + 1
Else
rng.SetRange rng.Start - 1, rng.Start - 1
End If
End If
' If the object is too large, flag it with a bookmark.
rng.Bookmarks.Add "TOO_LARGE" & i, rng
End If
Next obj
selection.SetRange sRng.Start, sRng.End
ur.EndCustomRecord
End Sub
Multiple PageSetups and tables wider:
Question though... just for tables, is there a way to extract tables left/right locations so I can compare against page margins (i.e., table started at -0.3 in of the page... but there is a 0.5 left margin)... same goes with the right...
Sub CheckObjectMargins()
Dim doc As Word.Document, rng As Range, i As Long, c As Word.cell
Dim obj As Object, objWidth As Single
Dim objs As New VBA.Collection
Dim pageWidth As Long
Dim tooLarge As Boolean, ur As UndoRecord
Dim sec As Word.Section, sRng As Range
Dim tbLeft As Single
Const table_started_at As Single = 0.3
Const table_started_at_R As Single = 0.3
Set ur = Word.Application.UndoRecord
ur.StartCustomRecord "CheckObjectMargins"
Set doc = ActiveDocument
Set sRng = selection.Range.Duplicate
For Each sec In doc.Sections
' Get the page width.
'pageWidth = doc.PageSetup.pageWidth - doc.PageSetup.LeftMargin - doc.PageSetup.RightMargin
pageWidth = sec.PageSetup.pageWidth - sec.PageSetup.LeftMargin - sec.PageSetup.RightMargin
' Loop through all the inline shapes in the document.
For Each obj In sec.Range.InlineShapes
' Check if the object's width is greater than the page width.
tooLarge = obj.Width > pageWidth
' If the object is too large, flag it with a bookmark.
If tooLarge Then
objs.Add obj
End If
Next obj
For Each obj In sec.Range.Tables
' Check if the object's width is greater than the page width.
If Not obj.PreferredWidth = 9999999 Then
tooLarge = obj.PreferredWidth > pageWidth
Else
For Each c In obj.Range.Cells
If i = 0 Then
i = c.RowIndex
Else
If i < c.RowIndex Then
Exit For
End If
End If
objWidth = objWidth + c.Width
Next c
tooLarge = objWidth > pageWidth
End If
' If the object is too large, flag it with a bookmark.
If tooLarge Then
tbLeft = obj.Range.Information(wdHorizontalPositionRelativeToPage)
obj.Range.Select
If tbLeft < InchesToPoints(table_started_at) Or _
pageWidth - (tbLeft + objWidth) < table_started_at_R Then
objs.Add obj
End If
End If
objWidth = 0: i = 0
Next obj
For Each obj In sec.Range.ShapeRange
' Check if the object's width is greater than the page width.
tooLarge = obj.Width > pageWidth
' If the object is too large, flag it with a bookmark.
If tooLarge Then
objs.Add obj
End If
Next obj
Next sec
i = 0
For Each obj In objs
i = i + 1
If VBA.TypeName(obj) = "Shape" Then
' If the object is too large, flag it with a bookmark.
obj.Select
doc.Bookmarks.Add "TOO_LARGE" & i, selection.Range
Else
Set rng = obj.Range
If rng.Information(wdInContentControl) Then
If rng.End + 1 < doc.Range.End Then
rng.SetRange rng.End + 1, rng.End + 1
Else
rng.SetRange rng.Start - 1, rng.Start - 1
End If
End If
' If the object is too large, flag it with a bookmark.
rng.Bookmarks.Add "TOO_LARGE" & i, rng
End If
Next obj
selection.SetRange sRng.Start, sRng.End
ur.EndCustomRecord
End Sub
After marking them all, you can use Ctrl + Shift + F5 to navigate these bookmarks and go to every too-large one by double-clicking on a bookmark's name or select one then click go-to button. like this:
- Deleting a file in VBA
- Trying to late bind outlook to but getting type mismatch error after create object line
- Bitly API call using VBA Excel Macro
- excel vba projects not closing
- INDEX MATCH to also pull through notes
- Move formatted data in selection from Excel into Word tables
- Excel VBA function to remove letters at end of string
- Excel function to construct an array from values without VBA
- Alternative method to delete file with out having to add MS Scripting Runtime Reference
- How to implement joining muiltiple curves is Catia VBA?
- VBA: How to Loop IF Statement through a Cell and Chart Series
- Incorporating Checkbox to lines of code rather than Cell value
- How to write txt file at same file path but preventing window to update notepad display
- How do I remove a character from a column of data in Excel
- VBA Macro doesn't work if the selection is only have 1 instance of the searched character
- Loop to enter email address and attach applicable pdf
- Jump to an absolute page from the beginning of the document
- Excel VBA Selecting the files xxx_Before.log then xxx_After.log
- Run Time Error 1004 'Unable to get the PivotFields property of the PivotTable class' with Data Model Pivot Table
- How to find R_HOME with VBA Environ
- Append excel cell to end of a link and create a hyperlink
- How to Insert Double or Single Quotes
- How to get Reference plane from Sketch
- VBA create pivot with "data is added to the Data Model"
- Merge cells and add borders
- Need help about transposing rows to column
- how to check whether Scripting Runtime is available
- Optimize VBA code on lookup without using Vlookup
- Paste (dynamic) lookup formula in dynamic number of columns
- Setting FreezePanes Property of the windows class -Excel VBA