Exporting Highlighted Text to New Word Doc

[Underwood]

Hello all,

Thanks for the help with the initial steps of my extractor project.
At this point, I think a script to successfully move already highlighted text (from previous thread) is the last piece.
The code below will copy/paste highlighted text into a new document, but it's unfinished.

How might I add the following elements to the script posted below?:
- Bulleting all pastes
- A bolded header (ideally, one that somehow retrieves the search term from another sub... haven't done my homework on that, yet)
- No blank lines when bulleting (maybe something that sweeps after all the terms are pasted down)
- Returns to header upon pasting/formatting (basically restarts so you can run it again with another search term)

Graphical representation of wishlist above:
17892




Sub Export_Highlights()


Dim objWord As Word.Application
Dim doc As Word.Document
Dim oneword
Dim i As Integer
i = 0
Set objWord = CreateObject("Word.Application")
With objWord
.Visible = True
Set doc = .Documents.Add

End With
With objWord.selection
.Font.Name = "Calibri"
.Font.Size = 10.5
For Each Char In ActiveDocument.Characters
If Char.HighlightColorIndex = wdYellow Then
i = 1
oneword = Char.Text
.TypeText oneword

Else
If i = 1 Then
.TypeText vbCrLf
i = 0
End If
End If
Next
End With
doc.Activate

End Sub


Thank you for all your help, so far.
I intend on making this into a resource for my fellow pharmacy students.
No sense in searching 1000x like a caveman.

~DH

[gmayor]

The following will copy highlighted text to a new document, retaining its original format (without the highlight).


Sub Export_Highlights()
Dim oRng As Range
Dim oNewRng As Range
Dim oDoc As Document
Dim oTarget As Document

Set oDoc = ActiveDocument
Set oTarget = Documents.Add
Set oRng = oDoc.Range
With oRng.Find
.Highlight = True
Do While .Execute
oRng.Copy
Set oNewRng = oTarget.Range
oNewRng.Collapse 0
oNewRng.Paste
oNewRng.HighlightColorIndex = wdNoHighlight
oNewRng.InsertAfter vbCr
oRng.Collapse 0
Loop
End With
lbl_Exit:
Set oDoc = Nothing
Set oTarget = Nothing
Set oRng = Nothing
Set oNewRng = Nothing
Exit Sub
End Sub

[Kilroy]

This gets you a bit closer


Sub CopyHighlightsToOtherDoc()
Dim ThisDoc As Document
Dim ThatDoc As Document
Dim r As Range
Dim StrName As String
Set ThisDoc = ActiveDocument
Set r = ThisDoc.Range
Set ThatDoc = Documents.Add
With r.Find
.Text = ""
.Highlight = True
Do While .Execute(Forward:=True) = True
ThatDoc.Range.InsertAfter r.Text
r.Collapse 0
Loop
End With
Selection.WholeStory
With ListGalleries(wdBulletGallery).ListTemplates(1).ListLevels(1)
.NumberFormat = ChrW(61623)
.TrailingCharacter = wdTrailingTab
.NumberStyle = wdListNumberStyleBullet
.NumberPosition = InchesToPoints(0.25)
.Alignment = wdListLevelAlignLeft
.TextPosition = InchesToPoints(0.5)
.TabPosition = wdUndefined
.ResetOnHigher = 0
.StartAt = 1
With .Font
.Name = "Symbol"
End With
.LinkedStyle = ""
End With
ListGalleries(wdBulletGallery).ListTemplates(1).Name = ""
Selection.Range.ListFormat.ApplyListTemplateWithLevel ListTemplate:= _
ListGalleries(wdBulletGallery).ListTemplates(1), ContinuePreviousList:= _
False, ApplyTo:=wdListApplyToWholeList, DefaultListBehavior:= _
wdWord10ListBehavior
Set ThatDoc = ActiveDocument
StrName = ThisDoc.FullName
StrName = Left(StrName, InStrRev(StrName, Chr(46)) - 1) & " Extractions.docx"
ThatDoc.SaveAs2 FileName:=StrName 'Save the new document"
Call title

End Sub
Sub title()
'
Dim myRange As Range
With ActiveDocument
Set myRange = .Sections(1).Headers(wdHeaderFooterPrimary).Range
.Fields.Add Range:=myRange, Type:=wdFieldFileName, PreserveFormatting:=True
myRange.Collapse wdCollapseEnd

End With
End Sub

[Underwood]

Awesome.
OK so I'm now that the part when I'm calling the name of the search term.

I figure this would look something like:

objEnv("Term") = "edoxaban"
in my sub that calls everything
I figured I'd define the term there
(or maybe in a textbox - would take more work/asking you guys)

17897

and
Do While .Execute(findtext:="%Term%")
in the searching part of the script...



Although this is not working.
Perhaps obj.env isn't the right thing to put in front?
(I got the idea from first page of this web search:
"How can one script pass and return values to another script? by Programmer1974")

[gmayor]

You are making up your own syntax. Define the term as a string variable

Const strTerm As String = "edoxaban"
'....................
Do While .Execute(FindText:=strTerm)