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
Related
I am trying to delete ALL empty paragraphs at the start of a Word file. I am using the following to delete just the FIRST paragraph but I need to delete all empty paragraphs in a row, so that if you have 5 empty lines, they will all be deleted.
here is the code:
Dim MyRange As Range
Set MyRange = ActiveDocument.Paragraphs(1).Range
If MyRange.Text = vbCr Then MyRange.Delete
I've tried adding a loop and for statement, but to no avail.
thanks in advance.
Collapse to the start of the document, then extend the range whilst 'empty characters' are found.
Here is your starter for 10
Dim MyRange As Range
Set MyRange = ActiveDocument.Paragraphs(1).Range
MyRange.Collapse direction:=wdCollapseStart
MyRange.MoveEndWhile cset:=" " & vbCrLf ' & any other invisible characters that may be present
MyRange.Delete
Each paragraph must have at least one character - the paragraph mark itself. So all we need to do is to check if the paragraph contains only 1 character.
Simple like this:
Sub ClearEmptyPargraphAtStartOfDocument()
While (ActiveDocument.Paragraphs(1).Range.Characters.Count = 1)
ActiveDocument.Paragraphs(1).Range.Delete
Wend
End Sub
This seems to work for me
Public Sub SOCheck()
Dim MyRange As Range, CarryOn As Boolean
CarryOn = True
While CarryOn
Set MyRange = ActiveDocument.Paragraphs(1).Range
If MyRange.Text = vbCr Then
MyRange.Delete
Else
CarryOn = False
End If
Wend
'MsgBox "Done"
End Sub
It's just a loop around your own code
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 have this Word VBA code, which removes field codes, but retains their values. This works well, but not in the header. How can I edit it to work for the body of document ( and header/footer as well ) ?
Sub RemoveFieldCodeButRetainValue()
Dim d As Document
Dim iTemp As Integer
Dim strTemp As String
Set d = ActiveDocument
For iTemp = d.Fields.Count To 1 Step -1
strTemp = d.Fields(iTemp).Result
d.Fields(iTemp).Select
With Selection
.Fields(1).Delete
.TypeText strTemp
End With
Next
End Sub
Sorry, I realize this isn't exactly the answer to the question, but using:
For Each fld In ActiveDocument.Fields
fld.Unlink
Next
will preserve the value while deleting the underlying field. As far as I know, you could use the same technique while looping through the various story ranges as suggested in the other answer for the header/footer areas.
ok, I got it:
Use two macros:
Sub CtrlAPlusFNine()
Selection.WholeStory
Dim oStory As Range
For Each oStory In ActiveDocument.StoryRanges
oStory.Fields.Update
If oStory.StoryType <> wdMainTextStory Then
While Not (oStory.NextStoryRange Is Nothing)
Set oStory = oStory.NextStoryRange
oStory.Fields.Update
Wend
End If
Next oStory
lbl_Exit:
Set oStory = Nothing
Exit Sub
End Sub
Sub RemoveFieldCodeButRetainValue()
Dim d As Document
Dim iTemp As Integer
Dim strTemp As String
Set d = ActiveDocument
For iTemp = d.Fields.Count To 1 Step -1
strTemp = d.Fields(iTemp).Result
d.Fields(iTemp).Select
With Selection
.Fields(1).Delete
.TypeText strTemp
End With
Next
End Sub
..and call these two from a third macro using Application.Run
I am using a VBA Macro to render all the "Heading 1" style text from a word document.
It is working fine but taking huge time depends on the content of word doc.
I am looping each paragraph to check for "Heading 1" style and render the Text into an array.
I wonder if there is an alternative approach to simply find "Heading 1" style and store the text in array which would greatly reduce the execution time.
Below my Macro program and I would appreciate any expert thoughts regarding the above mentioned.
Sub ImportWordHeadings()
Dim wdDoc As Object
Dim wdFileName As Variant
Dim sHeader(50) As String
Dim Head1counter As Integer
Dim arrcount As Long
Dim mHeading As String
On Error Resume Next
wdFileName = Application.GetOpenFilename("Word files (*.doc),*.doc", , _
"Browse for file containing table to be imported")
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) 'open Word file
p = 1
RetCount = 0
parg = wdDoc.Paragraphs.Count
For Head1counter = 1 To parg
If wdDoc.Paragraphs(Head1counter).Range.Style = "Heading 1" Then
sHeader(p) = wdDoc.Paragraphs(Head1counter).Range.Text
p = p + 1
Else
p = p
End If
Next Head1counter
For arrcount = RetCount + 1 To UBound(sHeader)
If sHeader(arrcount) <> "" Then
Debug.Print sHeader(arrcount)
RetCount = arrcount
Exit For
Else
RetCount = RetCount
End If
Next arrcount
Set wdDoc = Nothing
End Sub
You can use the Find method to search for all of the headings, very similar to what I did over here on Code Review.
Set doc = ActiveDocument
Set currentRange = doc.Range 'start with the whole doc as the current range
With currentRange.Find
.Forward = True 'move forward only
.Style = wdStyleHeading1 'the type of style to find
.Execute 'update currentRange to the first found instance
dim p as long
p = 0
Do While .Found
sHeader(p) = currentRange.Text
' update currentRange to next found instance
.Execute
p = p + 1
Loop
End With
I'm trying to create a macro to look for to specific expressions and remove that content.
For example I need to remove everything that goes from the word "NOTIFICATION" to the expression "Good Morning" (but keeping "Good Morning, if possible).
I have a code to remove one line, but cannot figure out how to do it with a selection, because I don't have the same number of lines every time. Could be 3 or up to 9, more or less.
The code I have is like this (I've removed the parts of the code that did other things that are not related to this problem I have):
Private Sub ProcessMsg(msg As MailItem)
On Error GoTo ErrorHandlerProcessMsg
Dim msg2 As Outlook.MailItem
Dim msgDoc As Word.Document
Dim msgDoc2 As Word.Document
Dim objSel As Word.Selection
Set msg2 = Application.CreateItem(olMailItem)
Set msgDoc = msg.GetInspector.WordEditor
Set msgDoc2 = msg2.GetInspector.WordEditor
msgDoc.Select
msgDoc.Windows(1).Selection.Copy
msgDoc2.Windows(1).Selection.PasteAndFormat wdPasteDefault
Set objSel = msgDoc2.Windows(1).Selection
With objSel
.Find.Execute "NOTIFICATION"
.Collapse wdCollapseStart
.MoveEnd WdUnits.wdStory, 1
.Delete
End With
Set objSel = msgDoc2.Windows(1).Selection
With objSel
.MoveStart WdUnits.wdStory, -1
.Collapse wdCollapseStart
.MoveEnd WdUnits.wdParagraph, 1
.Delete
End With
Set msgDoc = Nothing
Set msgDoc2 = Nothing
Set objSel = Nothing
Set msg2 = Nothing
Exit Sub
ErrorHandlerProcessMsg:
Set msgDoc = Nothing
Set msgDoc2 = Nothing
Set objSel = Nothing
Set msg2 = Nothing
Err.Raise Err.Number, Err.Source, Err.Description
End Sub
Could anyone enlighten me?
This does what you want (from what I understand). Just paste this function inside one of the word document's code objects and run it (have tried on Word, rather than Excel). It's mainly to show you how you could go by handling such a problem.
Sub LineRemover()
Dim doc As Document
Set doc = ActiveDocument
Dim myParagraph As Paragraph
Dim mySentences As Sentences
Dim mySentence As Range
Dim deleted As Boolean
deleted = False
For Each myParagraph In doc.Paragraphs
Set mySentences = myParagraph.Range.Sentences
For Each mySentence In mySentences
If InStr(mySentence, "Good morning") <> 0 Then
'"Good morning" is present inside this line; exit the loop!
Exit For
ElseIf deleted Then
'"NOTIFICATION" was already deleted, need to remove all subsequent lines!
mySentence.Delete
ElseIf InStr(mySentence, "NOTIFICATION") <> 0 Then
'"NOTIFICATION" is present inside this line; delete it!
mySentence.Delete
deleted = True 'Tell the program you've deleted it!
End If
Next
If deleted Then
Exit For
End If
Next
End Sub
Extra details : InStr(String1, String2) will return the position at which String2 is found inside String1