I have a macro that find some properties of the word paragraphs. I need to find '4 Lines or more' paragraphs by using the macro.
I've try this code:
If oPar.LineCount = LineCount + 4 Then
See below for entire code:
Sub CheckKeepLinesTogether()
Application.ScreenUpdating = False
Const message As String = "Check Keep Lines Together"
Dim oPar As Paragraph
Dim oRng As Word.Range
Dim LineCount As Long
For Each oPar In ActiveDocument.Paragraphs
Set oRng = oPar.Range
With oRng
With .Find
.ClearFormatting
.Text = "^13"
.Execute
End With
Set oRng = oPar.Range
If oPar.KeepTogether = False Then
If oPar.LineCount = LineCount + 4 Then
.Select
Selection.Comments.Add Range:=Selection.Range
Selection.TypeText Text:=message
Set oRng = Nothing
End If
End If
End With
Next
Application.ScreenUpdating = True
End Sub
Replace the faulty line with the uncommented code :
'If oPar.LineCount = LineCount + 4 Then
If oPar.Range.ComputeStatistics(wdStatisticLines) >= 4 Then
By the way, you don't need to set Set oRng = oPar.Range twice.
Not tested
Sub CheckKeepLinesTogether()
Application.ScreenUpdating = False
Const message As String = "Check Keep Lines Together"
Dim oPar As Paragraph
Dim oRng As Word.Range
Dim LineCount As Long
For Each oPar In ActiveDocument.Paragraphs
Set oRng = oPar.Range
With oRng
With .Find
.ClearFormatting
.Text = "^13"
.Execute
End With
If oPar.KeepTogether = False Then
If oPar.Range.ComputeStatistics(wdStatisticLines) >= 4 Then
Set oRng = oPar.Range
oRng.Comments.Add Range:=oRng
oRng.TypeText Text:=message
Set oRng = Nothing
End If
End If
End With
Next
Application.ScreenUpdating = True
End Sub
Related
I am trying to create a VBA code for word that will search for a specific colored square bracket and then search for the corresponding closing bracket of that color and delete all text between these 2 colored bracket.
The code will search for a green square opening bracket then search for the green closing bracket and delete everything in between which in this case will be "brown fox". I will then add update the code for the color of the red bracket and have it delete everything between the red bracket. I have found the following code from another question on this site and this does work 90% but i cant get it to search for the specific colored bracket.
I tried
.Format = True + .Font.Color = WdColorRed
but it doesnt pick it up. Any help is appreciated. Thanks
Sub FindSquareBracketPairs()
Dim rngFind As Word.Range
Dim sOpen As String, sClose As String
Dim sFindTerm As String
Dim bFound As Boolean, lPosOpen As Long
Set rngFind = ActiveDocument.Content
sOpen = "["
sClose = "]"
sFindTerm = "\[*\] "
With rngFind.Find
.ClearFormatting
.Text = "\[*\] "
.Forward = True
.Wrap = Word.WdFindWrap.wdFindStop
.MatchWildcards = True
bFound = .Execute
Do While bFound
lPosOpen = NumberOfCharInRange(rngFind, sOpen)
rngFind.Delete
rngFind.Collapse wdCollapseEnd
bFound = .Execute
Loop
End With
End Sub
'Checks whether there's more than one instance of searchTerm in the rng.Text
'For each instance above one, move the Start point of the range
'To the position of that instance until no more are "found".
'Since the Range is passed ByRef this will change the original
'range's position in the calling procedure.
Function NumberOfCharInRange(ByRef rng As Word.Range, _
ByRef searchTerm As String) As Long
Dim lCountChars As Long, lCharPos As Long
Dim s As String
s = rng.Text
Do
lCharPos = InStr(s, searchTerm)
If lCharPos > 1 Then
lCountChars = lCountChars + 1
rng.Start = rng.Start + lCharPos
End If
s = Mid(s, lCharPos + 1)
Loop Until lCharPos = 0
NumberOfCharInRange = lCountChars
End Function
You'll want to get the Color from the Font of the range. Then use this website to use decimal you get or transfer/convert to hex or rgb someway. There are also constants in VBA such as wdRed but, it's the word red whatever that is.
Sub FindSquareBracketPairs()
Dim rngFind As Range
Dim sOpen As String, sClose As String
Dim sFindTerm As String
Dim bFound As Boolean, lPosOpen As Long
Set rngFind = ActiveDocument.Range
sOpen = "["
sClose = "]"
sFindTerm = "\[*\] "
For Each rng In ActiveDocument.StoryRanges
For Each rngChar In rng.Characters
Dim fnt As Font
Set fnt = rngChar.Font
Dim clr As WdColor
clr = rngChar.Font.Color
Next
Next
With rngFind.Find
'.ClearFormatting
.Text = "\[*\] "
.Forward = True
.Wrap = Word.WdFindWrap.wdFindStop
.MatchWildcards = True
bFound = .Execute
Do While bFound
lPosOpen = NumberOfCharInRange(rngFind, sOpen)
'Check if the first and last brackets are whatever color is passed here.
If (IsSurroundedByColor(wdColorRed, rngFind.Characters.First, rngFind.Characters(rngFind.Characters.Count - 1))) Then
rngFind.Delete
End If
rngFind.Collapse wdCollapseEnd
bFound = .Execute
Loop
End With
End Sub
Function IsSurroundedByColor(ByRef chkingClr As WdColor, ByRef frstChr As Range, ByRef lstChr As Range) As Boolean
IsSurroundedByColor = (frstChr.Font.Color = chkingClr And lstChr.Font.Color = chkingClr)
End Function
Hi the following code extracts all instances of bold text from the active Word document and copies it to a newly created Word document.
Can anyone please help me to adjust the code to perform the same task on all open Word documents into the newly created Word document.
Any help is very much appreciated.
Sub A__GrabTheBolds()
On Error GoTo cleanUp
Application.ScreenUpdating = False
Dim ThisDoc As Document
Dim ThatDoc As Document
Dim r As Range
Set ThisDoc = ActiveDocument
Set r = ThisDoc.Range
Set ThatDoc = Documents.Add
With r
With .Find
.Text = ""
.Format = True
.Font.Bold = True
End With
Do While .Find.Execute(Forward:=True) = True
'If r.HighlightColorIndex = wdDarkYellow Then 'highlightcols(7)
If r.Bold Then
ThatDoc.Range.Characters.Last.FormattedText = .FormattedText
ThatDoc.Range.InsertParagraphAfter
.Collapse 0
End If
Loop
End With
cleanUp:
Application.ScreenUpdating = True
Set ThatDoc = Nothing
Set ThisDoc = Nothing
End Sub
You can use the Documents-collection which returns all open documents:
Sub A__GrabTheBolds()
On Error GoTo cleanUp
Application.ScreenUpdating = False
Dim ThisDoc As Document
Dim ThatDoc As Document
Dim r As Range
Set ThatDoc = Documents.Add
'iterate over all open word documents
'For Each ThisDoc In Application.Documents
'handle documents in the order they were opened
'reverse order of documents collection
'loop until second to last as last one is ThatDoc
Dim i As Long
Dim FileNames As String, fFound As Boolean
Dim fWritten As Boolean
For i = Application.Documents.Count To 2 Step -1
Set ThisDoc = Application.Documents(i)
'Don't check document where the code runs
If Not ThisDoc Is ThisDocument Then
Set r = ThisDoc.Range
With r
With .Find
.Text = ""
.Format = True
.Font.Bold = True
End With
Do While .Find.Execute(Forward:=True) = True
'<-- remove this part if not needed
'add filename if the first bold range
If fWritten = False Then
ThatDoc.Content.InsertAfter vbCrLf & vbCrLf & ThisDoc.Name & vbCrLf
End If
'remove this part if not needed -->
fWritten = True
'If r.HighlightColorIndex = wdDarkYellow Then 'highlightcols(7)
If r.Bold Then
ThatDoc.Range.Characters.Last.FormattedText = .FormattedText
ThatDoc.Range.InsertParagraphAfter
.Collapse 0
End If
Loop
End With
'add filename to list only if bold has been found
If fWritten = True Then
FileNames = FileNames & vbCrLf & ThisDoc.Name
fWritten = False
End If
End If
Next
'Add list of filenames to the end of ThatDoc
With ThatDoc.Content
.InsertParagraphAfter
.InsertAfter FileNames
End With
cleanUp:
Application.ScreenUpdating = True
Set ThatDoc = Nothing
Set ThisDoc = Nothing
End Sub
I wrote a simple code in VBA for MS WORD,
in which I want to add dot at the end of each paragraph that has no dot.
The code is as follows:
Function FindParagraph(ByVal doc As Document, ByVal Npara As String) As Paragraph
Dim para As Paragraph
For Each para In doc.Paragraphs
If para.Range.ListFormat.ListString = Npara Then
Set FindParagraph = para
End If
Next para
End Function
Sub End_para_with_dot()
Dim doc As Document
Dim tb As table
Dim prange As Range
Dim srange As Range
Dim para As Paragraph
Dim spara As Paragraph
Dim epara As Paragraph
Dim txt As String
Set doc = ActiveDocument
Set spara = FindParagraph(doc, "1")
Set epara = FindParagraph(doc, "2")
Set srange = doc.Range(spara.Range.Start, epara.Range.Start) 'sets a specific range of paragraphs in doc
For Each para In srange.Paragraphs
Set prange = para.Range
With prange
If .Style <> "Nagłówek 1" Then
Debug.Print .Text
txt = Trim(.Text)
n = Len(txt)
last_c = Mid(txt, n - 1, 1)
If last_c <> "." Then
txt = Left(txt, n - 1) & "." & Chr(13)
Debug.Print txt
End If
.Text = txt '!!!SUPPOSED REASON FOR ERROR!!!
End If
End With
Next para
End Sub
Unfortunately, after I run this code an infinite loop is produced with the first found paragraph being print all the time.
I suppose that it is due to .Text = txt line. Earlier I made a reference to the range object in this statement Set prange = para.Range. But I do not understand why when I want to reassign the .Text property of this object then the infinite loop is produced.
I would be grateful for any tip.
I'm assuming you don't want to add a . when the paragraph ends with any of !.,:;?
Try a wildcard Find/Replace, where:
Find = ([!\!.,:;\?])(^13)
Replace = \1.\2
Or, as a macro:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "([!\!.,:;\?])(^13)"
.Replacement.Text = "\1.\2"
.Format = False
.Forward = True
.Wrap = wdFindContinue
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
End With
Application.ScreenUpdating = True
End Sub
I want to replace all date fields with, for example, "hello".
This Word VBA code replaces all the fields in the header and footer of the document. I only want to replaces the date fields.
Sub test()
Dim oField As Field
Dim oSection As Section
Dim oHeader As HeaderFooter
Dim oFooter As HeaderFooter
For Each oSection In ActiveDocument.Sections
For Each oHeader In oSection.Headers
If oHeader.Exists Then
For Each oField In oHeader.Range.Fields
If oField = wdFieldDate Then
oField.Result.Text = "hello"
oField.Unlink
Else
End If
Next oField
End If
Next oHeader
For Each oFooter In oSection.Footers
If oFooter.Exists = True Then
For Each oField In oFooter.Range.Fields
If IsDate(oField) = True Then
oField.Result.Text = "hello"
oField.Unlink
Else
End If
Next oField
End If
Next oFooter
Next oSection
End Sub
In your cross-post, you specified that you wanted DATE and TIME fields.
Sub DateFieldsReplace()
' Replace any date fields in active document
' Charles Kenyon 2020-09-09
' https://answers.microsoft.com/de-de/msoffice/forum/all/word-macro-search-for-date-fields-and-replace/ad578c92-e1ce-4258-903f-552dfae2a843
' =====================================================
' DECLARE VARIABLES AND CONSTANTS
Dim oField As Field, bErrMark As Boolean, strPrompt As String, bFieldCodeHidden As Boolean
Dim oStory As Range
Const strREPLACETEXT = "Hello" ' Change to suit
'
' =====================================================
' TURN OFF SCREEN UPDATING
' Application.ScreenUpdating = False
On Error GoTo OOPS
Let bFieldCodeHidden = ActiveWindow.View.ShowFieldCodes ' get current setting for field code display
Let ActiveWindow.View.ShowFieldCodes = True
'
' =====================================================
' FIND AND REPLACE DATE FIELDS
For Each oStory In ActiveDocument.StoryRanges
With oStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "^d Date"
.Replacement.Text = strREPLACETEXT
.Execute Replace:=wdReplaceAll
.Text = "^d Time"
.Execute Replace:=wdReplaceAll
End With
Next oStory
'
Let strPrompt = "All Date fields replaced with " & strREPLACETEXT
GoTo ResumeMacro
' =====================================================
' ERROR HANDLER
OOPS:
Let strPrompt = "Sorry. There was a problem with the macro DateFieldsReplace."
'
ResumeMacro:
'
' =====================================================
' RETURN SCREEN UPDATING AND FINISH
With ActiveDocument.Range.Find
.ClearFormatting
.Text = ""
.Replacement.ClearFormatting
.Replacement.Text = ""
End With
Application.ScreenUpdating = True
Application.ScreenRefresh
Set oField = Nothing
Set oStory = Nothing
Let ActiveWindow.View.ShowFieldCodes = bFieldCodeHidden
On Error GoTo -1
MsgBox strPrompt
'
End Sub
A document with this code can be found at this temporary link.
For cross-posting etiquette, please please read: A Message to Forum Cross-Posters
If oField = wdFieldDate Then doesn't compile because you haven't specified which property of the field you want to check. Your code should be as below
Sub test()
Dim oField As Field
Dim oSection As Section
Dim oHeader As HeaderFooter
Dim oFooter As HeaderFooter
For Each oSection In ActiveDocument.Sections
For Each oHeader In oSection.Headers
If oHeader.Exists Then
For Each oField In oHeader.Range.Fields
'check the field type
If oField.Type = wdFieldDate Then
oField.Result.Text = "hello"
oField.Unlink
Else
End If
Next oField
End If
Next oHeader
For Each oFooter In oSection.Footers
If oFooter.Exists = True Then
For Each oField In oFooter.Range.Fields
If oField.Type = wdFieldDate Then
oField.Result.Text = "hello"
oField.Unlink
Else
End If
Next oField
End If
Next oFooter
Next oSection
End Sub
How to extract text and non text data content (ex: Tables, pictures) associated with each heading irrespective of heading style?
With below code I am able to reach out to each header, post that I am failing to extract content associated with that heading:
Option Explicit
Sub Main()
Dim strFile As String
Dim oWord As Word.Application
Dim oWdoc As Word.Document
Dim oPar As Word.Paragraph
Dim rng As Word.Range
strFile = "C:\Users\SQVA\Desktop\My_Work\MyTest3.docx"
'Set oWord = CreateObject("Word.Application")
Set oWord = New Word.Application
Set oWdoc = oWord.Documents.Open(strFile)
Call Get_Heading_Name(oWord, oWdoc, strFile, rng)
Call Close_Word(oWord, oWdoc)
End Sub
Sub Get_Heading_Name(oWord As Word.Application, oWdoc As Word.Document, strFile As String, rng As Word.Range)
oWord.Visible = True
Dim astrHeadings As Variant
Dim strText As String
Dim intItem As Integer
Set rng = oWdoc.Content
astrHeadings = _
oWdoc.GetCrossReferenceItems(wdRefTypeHeading)
For intItem = LBound(astrHeadings) To UBound(astrHeadings)
strText = Trim$(astrHeadings(intItem))
'Debug.Print CStr(strText)
'Debug.Print astrHeadings(intItem).
Dim my_String As String
Dim intLevel
If CStr(strText) <> "" Then
my_String = Right(strText, Len(strText) - InStr(strText, " "))
intLevel = GetLevel(CStr(astrHeadings(intItem)))
' Call GetHeadingNextText(oWdoc, my_String)
' Debug.Print my_String
' Debug.Print intLevel
' rng.Style = "Heading " & intLevel
Dim sTextSearch() As String
Dim StrHdTxt1
Dim nStart As Long, nEnd As Long, n As Long, k As Long
Dim wdTable
Dim wdTbl As Word.Table, wdCell As Word.cell, wdCellRng As Word.Range
Dim wdIshp As Word.InlineShape, wdShp As Word.Shape, StrHdTxt As String
oWdoc.Range(0, 0).Select
With oWord.Selection.Find
.Style = oWdoc.Styles("Heading " & intLevel)
.Text = my_String
If .Execute Then
'Debug.Print "Found"
Call SelectHeadingandContent(oWdoc, oWord)
End If
End With
End If
Next intItem
End Sub
Sub Close_Word(oWord As Word.Application, oWdoc As Word.Document)
oWdoc.Close SaveChanges:=wdDoNotSaveChanges
oWord.Quit
Set oWdoc = Nothing
Set oWord = Nothing
End Sub
Private Function GetLevel(strItem As String) As Integer
' Return the heading level of a header from the
' array returned by Word.
' The number of leading spaces indicates the
' outline level (2 spaces per level: H1 has
' 0 spaces, H2 has 2 spaces, H3 has 4 spaces.
Dim strTemp As String
Dim strOriginal As String
Dim longDiff As Integer
' Get rid of all trailing spaces.
strOriginal = RTrim$(strItem)
' Trim leading spaces, and then compare with
' the original.
strTemp = LTrim$(strOriginal)
' Subtract to find the number of
' leading spaces in the original string.
longDiff = Len(strOriginal) - Len(strTemp)
GetLevel = (longDiff / 2) + 1
End Function
Sub SelectHeadingandContent(oWdoc As Word.Document, oWord As Word.Application)
Dim headStyle 'As Style
' Checks that you have selected a heading. If you have selected multiple paragraphs,checks only the first one. If you have selected a heading, makes sure the whole paragraph is selected and records the style. If not, exits the subroutine.
If oWdoc.Styles(oWord.Selection.Paragraphs(1).Style).ParagraphFormat.OutlineLevel < wdOutlineLevelBodyText Then
Set headStyle = oWord.Selection.Paragraphs(oWord.Selection.Paragraphs.Count).Style
oWord.Selection.Expand wdParagraph
Else: Exit Sub
End If
' Turns off screen updating so the the screen does not flicker.
Application.ScreenUpdating = False
' Loops through the paragraphs following your selection, and incorporates them into the selection as long as they have a higher outline level than the selected heading (which corresponds to a lower position in the document hierarchy). Exits the loop if there are no more paragraphs in the document.
Dim My_Text As String
My_Text = ""
Do While oWdoc.Styles(oWord.Selection.Paragraphs(oWord.Selection.Paragraphs.Count).Next.Style).ParagraphFormat.OutlineLevel > headStyle.ParagraphFormat.OutlineLevel
'Debug.Print oWord.Selection.Paragraphs(oWord.Selection.Paragraphs.Count).Range.Text
oWord.Selection.MoveEnd wdParagraph
' Debug.Print oWord.Selection.Paragraphs(oWord.Selection.Paragraphs.Count).Range.Text
My_Text = My_Text + vbCr + oWord.Selection.Paragraphs(oWord.Selection.Paragraphs.Count).Range.Text
If oWord.Selection.Paragraphs(oWord.Selection.Paragraphs.Count).Next Is Nothing Then Exit Do
Loop
Debug.Print My_Text
' Turns screen updating back on.
Application.ScreenUpdating = True
End Sub
You can loop through all the Heading1 ranges and their 'non-text' objects, as you call them, with code like:
Sub Read_Heading_Contents()
Dim wdApp As New Word.Application, wdDoc As Word.Document, wdRng As Word.Range
Dim wdTbl As Word.Table, wdCell As Word.Cell, wdCellRng As Word.Range
Dim wdIshp As Word.InlineShape, wdShp As Word.Shape, StrHdTxt As String
Const strFile As String = "C:\Users\SQVA\Desktop\My_Work\MyTest3.docx"
With wdApp
.Visible = True
Set wdDoc = .Documents.Open(Filename:=strFile, ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
With wdDoc
With .Range
With .Find
.Style = wdStyleHeading1
.Text = ""
.Wrap = wdFindStop
.Execute
End With
If .Find.Found = False Then
MsgBox "No 'Heading 1' style found."
Else
Do While .Find.Found = True
StrHdTxt = .Duplicate.Text: MsgBox StrHdTxt
Set wdRng = .Duplicate.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
For Each wdTable In .Tables
With wdTbl
For Each wdCell In .Range.Cells
Set wdCellRng = wdCell.Range
wdCellRng.End = wdCellRng.End - 1
MsgBox wdCellRng.Text
Next
End With
Next
For Each wdIshp In wdRng.InlineShapes
With wdIshp
If Not .TextEffect Is Nothing Then
MsgBox .TextEffect.Text
End If
End With
Next
For Each wdShp In wdRng.ShapeRange
With wdShp
If Not .TextFrame Is Nothing Then
MsgBox .TextFrame.TextRange.Text
End If
End With
Next
.Collapse wdCollapseEnd
.Find.Execute
Loop
End If
End With
.Close SaveChanges:=wdDoNotSaveChanges
End With
.Quit
End With
Set wdRng = Nothing: Set wdDoc = Nothing: Set wdApp = Nothing
End Sub
The above code includes message boxes to display the heading names and whatever it finds in the heading range's 'non-text' content. I'll leave it to you to turn the textbox output into whatever else you want it to be. Of course, not all inline & floating shapes have text; the loops find those, too, but I have no idea how you intend to 'read' those.