When using vba TextColumns method to split two column a part of a word document, it will affect the entire document - vba

I have a problem when using VBA for column operation.
I want to select an area in a Word document that contains several paragraphs, and then I want to split them from one column into two.
My VBA code is as follows:
Public Sub testSplitColumn()
Dim targetDoc As Document
Dim sourceFileName As String
sourceFileName = "file path"
Set targetDoc = Documents.Open(sourceFileName, , True)
targetDoc.Paragraphs(503).range.Select
'Splitting column on word
With targetDoc.Paragraphs(503).range.PageSetup.TextColumns
.SetCount NumColumns:=2
.EvenlySpaced = True
.LineBetween = False
End With
End Sub
It runs, but the result is wrong.
It is columnizing the paragraphs in the entire document, not just the selected paragraphs in the code.
I got a macro code that can achieve the correct effect through the method of word macro recording:
Sub split()
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type <> wdPrintView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
With Selection.PageSetup.TextColumns
.SetCount NumColumns:=2
.EvenlySpaced = True
.LineBetween = False
End With
End Sub
But it's no different from mine.
How can I fix my VBA code?

As #JerryJeremiah said: you need section breaks before and after your selection.
When recording a macro - they will be inserted as well.
I would create a generic sub to insert the section breaks:
Public Sub test_splitTo2Columns()
'your original code
Dim targetDoc As Document
Dim sourceFileName As String
sourceFileName = "file path"
Set targetDoc = Documents.Open(sourceFileName, , True)
'calling the generic function to test with specific paragraph
splitTo2Columns targetDoc.Paragraphs(503).Range
'this will work too - splitting the selected range
splitTo2Columns ActiveDocument.Selection.Range
End Sub
Public Sub splitTo2Columns(rg As Range, Optional fSplitWholeParagraphs As Boolean = True)
Dim rgToSplit As Range
Set rgToSplit = rg.Duplicate
If fSplitWholeParagraphs = True Then
'in case rg = selection and selection is only a single character
rgToSplit.Start = rgToSplit.Paragraphs.First.Range.Start
rgToSplit.End = rgToSplit.Paragraphs.Last.Range.End
End If
insertSectionBreakContinous rgToSplit, wdCollapseStart
insertSectionBreakContinous rgToSplit, wdCollapseEnd
rgToSplit.Start = rgToSplit.Start + 1 'move behind first section break
With rg.PageSetup.TextColumns
.SetCount NumColumns:=2
.EvenlySpaced = True
.LineBetween = False
End With
End Sub
Private Sub insertSectionBreakContinous(rg As Range, startEnd As WdCollapseDirection)
Dim rgBreak As Range
Set rgBreak = rg.Duplicate
With rgBreak
.Collapse startEnd
.InsertBreak wdSectionBreakContinuous
End With
End Sub

Related

Convert hyperlinks into footnotes

I currently employ a VBA script to copy all the hyperlinks in an MS Word document and list them in a new document. However, I wonder if there is any way to update this VBA script such that it would translate those hyperlinks into footnotes without affecting the original display words --or live hyperlinks, for that matter. This would be really helpful as copying and pasting those hyperlinks back into the original document is very, very time-consuming. The VBA script I currently have:
Sub PullHyperlinks()
Dim Src As Document
Dim Link As Hyperlink
Dim iDoDisplay As Integer
Set Src = ActiveDocument
If Src.Hyperlinks.Count > 0 Then
iDoDisplay = MsgBox("Include display text for links?", vbYesNo)
Documents.Add DocumentType:=wdNewBlankDocument
For Each Link In Src.Hyperlinks
If iDoDisplay = vbYes Then
Selection.TypeText Link.TextToDisplay
Selection.TypeText vbTab
End If
Selection.TypeText Link.Address
Selection.TypeParagraph
Next Link
Else
MsgBox "There are no hyperlinks in this document."
End If
End Sub
For example:
Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, Rng As Range, FtNt As Footnote
With ActiveDocument
For i = .Hyperlinks.Count To 1 Step -1
Set Rng = .Hyperlinks(i).Range
Rng.Collapse wdCollapseStart
Set FtNt = .Footnotes.Add(Rng)
FtNt.Range.FormattedText = .Hyperlinks(i).Range.FormattedText
.Hyperlinks(i).Range.Delete
With FtNt.Range.Hyperlinks(1)
.TextToDisplay = .Address
End With
Next
End With
Application.ScreenUpdating = True
End Sub

VBA Word macro not working as expected with field results in document

I have a word document (report) and in that document, I'm importing many text files with fields like this:
{INCLUDETEXT "C:\\PATH\\TOXMLFILES\\Request.xml" \*CHARFORMAT}
Also I'm updating all those fields with a macro on opening the document...
Sub AutoOpen()
With Options
.UpdateFieldsAtPrint = True
.UpdateLinksAtPrint = True
End With
ActiveDocument.Fields.Update
End Sub
Now I need to highlight the text of those imported XMLs (in the IncludeText fields) between <faultstring></faultstring> tags
Here is code I got here on stackoverflow for highlighting text (making it bold)
Sub BoldBetweenQuotes()
' base for a quotes finding macro
Dim blnSearchAgain As Boolean
Dim blnFindStart As Boolean
Dim blnFindEnd As Boolean
Dim rngFind As word.Range
Dim rngFindStart As word.Range
Dim rngFindEnd As word.Range
Set rngFind = ActiveDocument.content
Set rngFindStart = rngFind.Duplicate
Do
' set up find of first of quote pair
With rngFindStart.Find
.ClearFormatting
.Text = "<faultstring>"
.Replacement.Text = ""
.Forward = True
.wrap = wdFindStop
blnFindStart = .Execute
End With
If blnFindStart Then
rngFindStart.Collapse wdCollapseEnd
Set rngFindEnd = rngFindStart.Duplicate
rngFindEnd.Find.Text = "</faultstring>"
blnFindEnd = rngFindEnd.Find.Execute
If blnFindEnd Then
rngFindStart.End = rngFindEnd.Start
' make it bold
rngFindStart.Font.Bold = True
rngFindStart.Start = rngFindEnd.End
rngFindStart.End = rngFind.End
blnSearchAgain = True
Else
blnSearchAgain = False
End If
Else
blnSearchAgain = False
End If
Loop While blnSearchAgain = True
End Sub
Problem is, when I run the macro in my Word document (with the IncludeText fields) it keeps cycling and bolding just the first appearance of text between faultstring tags. When I run it in a new Word document with some random text and faultrstring tags it works well...
EDIT: It turns out the problem is due to the faultstring tags being inside the IncludeText fields. I need to turn the fields into static text after opening the document and updating the fields. How can I do that?
In order to convert dynamic field content to static text using Word's object model (such as VBA) the Fields.Unlink method is required. For the entire document:
ActiveDocument.Fields.Unlink
This is also possible for any given Range; to remove the fields in the last paragraph, for example:
ActiveDocument.Paragraphs.Last.Range.Fields.Unlink
In order to unlink only a certain type of field, loop the Fields collection, test the Field.Type and unlink accordingly. For example, for IncludeText:
Sub DeleteIncludeTextFields()
Dim doc As word.Document
Set doc = ActiveDocument
Debug.Print DeleteFieldType(wdFieldIncludeText, doc)
End Sub
Function DeleteFieldType(fldType As word.WdFieldType, doc As word.Document) _
As Long
Dim fld As word.Field
Dim counter As Long
counter = 0
For Each fld In doc.Fields
If fld.Type = wdFieldIncludeText Then
fld.Unlink
counter = counter + 1
End If
Next
DeleteFieldType = counter
End Function
Assuming you want to do this for all the fields in your document, after updating it:
Sub AutoOpen()
With Options
.UpdateFieldsAtPrint = True
.UpdateLinksAtPrint = True
End With
ActiveDocument.Fields.Update
ActiveDocument.Fields.Unlink
End Sub

MS WORD - Remove Field Code , Retain Value in Header

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

Word Userform won't open in second, currently active document after opened/unloaded in first document

The headline really says it all, but here's my situation: I have a userform set up to collect user input, then uses that input in a macro and executes it. That, in itself, works exactly like I want it to. The problem comes when more than one document is open.
To illustrate: I have two documents, 'doc a' and 'doc b'. I open both documents, then select 'doc a', open the userform using a show userform macro, input my data, and hit either 'Okay' or 'Cancel' (both of which are set to unload the userform once clicked). The macro runs, and then I select 'doc b' to do the same. This time, however, when I run my 'show userform' macro, 'doc a' is selected and the userform is opened there.
This seems like a pretty basic issue, but I haven't been able to figure out any fixes. After putting 'unload me' failed to work in my button-click subs, I tried creating an unload macro and calling it from those subs instead, but neither is working for me. Any thoughts? (Also, while I'm already here- are there any good tricks to autofill the Userform with the most recently filled data? Not between opening/closing word, which I've seen some solutions for, but just while word is open, and I'm switching between active documents)
Option Explicit
Option Compare Text
Private Sub UserForm_Initialize()
Folder_Name = ""
Tag_Name = ""
Checklist.Value = True
Site_Report.Value = False
Space_Check.Value = False
End Sub
Public Sub Okay_Click()
folder = Folder_Name.Text
tag = Tag_Name.Text
tagtxt = Tag_Name.Text & "[0-9]{1,}"
tagnum = Len(Tag_Name.Text)
If Checklist.Value = True Then
report_type = "cl"
Else
report_type = "sr"
End If
If Space_Check.Value = True Then
space = "yes"
Else
space = "no"
End If
If Len(Folder_Name.Text) > 0 Then
Application.Run "Mass_Hyperlink_v_5_0"
Application.Run "UnloadIt"
Else
Application.Run "UnloadIt"
End If
Unload Me
End Sub
Private Sub Cancel_Click()
Application.Run "UnloadIt"
Unload Me
End Sub
I don't think the issue is with the macros that this userform uses (it runs fine on its own, though the code is likely a bit hackneyed), but here's the code for good measure:
Option Explicit
Option Compare Text
Public tag As String
Public tagtxt As String
Public tagnum As String
Public folder As String
Public space As String
Public report_type As String
Public Sub Mass_Hyperlink_v_5_0()
Dim fileName As String
Dim filePath As String
Dim rng As Word.Range
Dim rng2 As Word.Range
Dim fileType As String
Dim start As String
Dim temp As String
Application.ScreenUpdating = False
fileType = "jpg"
If space = "Yes" Then
start = "%20("
Else: start = "("
End If
If report_type = "cl" Then
folder = "..\Images\" & folder
Set rng = ActiveDocument.Range
Else: folder = folder
End If
If report_type = "sr" Then
folder = "Images\" & folder
Set rng = Selection.Range
Else: folder = folder
End If
Set rng2 = rng.Duplicate
'tagtxt = tag & "[0-9]{1,}"
If Len(rng) > 0 And report_type = "sr" Then
With rng.Find
.Text = tagtxt
.Forward = False
.MatchWildcards = True
.Wrap = wdFindStop
Do While .Execute(findText:=tagtxt) = True
If rng.InRange(rng2) Then
rng.Select
'Selection.start = Selection.start + Len(tag)
Selection.start = Selection.start + tagnum
'ActiveDocument.Range(Selection.start - Len(tag), Selection.start).Delete
ActiveDocument.Range(Selection.start - tagnum, Selection.start).Delete
fileName = Selection.Text
filePath = folder & "\" & Hyperlinker.Tag_Name.Text & start & fileName & ")" & "." & fileType
ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, address:= _
filePath, SubAddress:="", ScreenTip:="", TextToDisplay:= _
(Hyperlinker.Tag_Name.Text & Selection.Text)
Else
Exit Sub
End If
rng.Collapse wdCollapseStart
Loop
End With
End If
If report_type = "cl" Then
With rng.Find
.Text = tagtxt
.Forward = False
.MatchWildcards = True
.Wrap = wdFindStop
Do While .Execute(findText:=tagtxt) = True
If rng.InRange(rng2) Then
rng.Select
'Selection.start = Selection.start + Len(tag)
Selection.start = Selection.start + tagnum
'ActiveDocument.Range(Selection.start - Len(tag), Selection.start).Delete
ActiveDocument.Range(Selection.start - tagnum, Selection.start).Delete
fileName = Selection.Text
filePath = folder & "\" & Hyperlinker.Tag_Name.Text & start & fileName & ")" & "." & fileType
ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, address:= _
filePath, SubAddress:="", ScreenTip:="", TextToDisplay:= _
(Hyperlinker.Tag_Name.Text & Selection.Text)
Else
Exit Sub
End If
rng.Collapse wdCollapseStart
Loop
End With
End If
Application.ScreenUpdating = True
End Sub
Sub Show_Linker()
Hyperlinker.Show
Hyperlinker.Folder_Name.SetFocus
End Sub
Sub UnloadIt()
Unload Hyperlinker
End Sub
Working with UserForms in VBA can be tricky, because they're actually a kind of Class. Since VBA tries to make everything exceptionally simple, classes are not obvious, nor is how to work with them correctly. There are situations where they become traps for the unwary.
So VBA makes it possible for you to work with an instance of a UserForm class without you needing to declare and instantiate a new object, as would normally be the case with a class object. The result being that the object can "hang around" and cause unexpected behavior, such as you're seeing.
The more correct way to work with a UserForm may seem like a lot more work (code to type and complexity), but it helps to keep things sorted. Indeed, this approach would theoretically allow you to have a separate UserForm for various documents.
Dim frmHyperlinker as Hyperlinker
Set frmHyperlinker = New Hyperlinker
frmHyperlinker.Folder_Name.SetFocus
frmHyperlinker.Show
'Execution waits...
'Now you're done with it, so clean up
Unload frmHyperlinker
Set frmHyperlinker = Nothing
There's an Answer in this discussion that goes into more technical detail, although the topic of that question is different from yours: Add Public Methods to a Userform Module in VBA

In which field the cursor is? (ms word, vba)

In a VBA Word macro, I'd like to get a Field-object for the field which contains the cursor.
The obvious try fails:
Private Sub Try1()
MsgBox Selection.Fields.Count
End Sub
The array is empty. Then I tried:
Private Sub Try2()
Dim oRange As Range
Set oRange = Selection.GoTo(What:=wdGoToField)
MsgBox oRange
End Sub
The cursor does not move, the message is empty.
I can iterate over ActiveDocument.Fields, compare the ranges and find the containing fiels. But probably there is a simple direct way?
My current production code with iteration over Document.Fields:
Sub Test()
Dim oField As Field
Set oField = FindWrappingField(Selection.Range)
If oField Is Nothing Then
MsgBox "not found"
Else
MsgBox oField
End If
End Sub
Private Function FindWrappingField(vRange As Range)
Dim oField As Field
Dim nRefPos As Long
' If selection starts inside a field, it also finishes inside.
nRefPos = vRange.Start
' 1) Are the fields sorted? I don't know.
' Therefore, no breaking the loop if a field is too far.
' 2) "Code" goes before "Result", but is it forever?
For Each oField In vRange.Document.Fields
If ((oField.Result.Start <= nRefPos) Or (oField.Code.Start <= nRefPos)) And _
((nRefPos <= oField.Result.End) Or (nRefPos <= oField.Code.End)) Then
Set FindWrappingField = oField
Exit Function
End If
Next oField
Set FindWrappingField = Nothing
End Function
The following function determines whether the selection spans or is within a field.
Function WithInField(Rng As Word.Range) As Boolean
' Based on code by Don Wells: http://www.eileenslounge.com/viewtopic.php?f=30&t=6622
' Approach : This procedure is based on the observation that, irrespective of _
a field's ShowCodes state, toggling the field's ShowCodes state _
twice collapses the selection to the start of the field.
Dim lngPosStart As Long, lngPosEnd As Long, StrNot As String
WithInField = True
Rng.Select
lngPosStart = Selection.Start
lngPosEnd = Selection.End
With Selection
.Fields.ToggleShowCodes
.Fields.ToggleShowCodes
' Test whether the selection has moved; if not, it may already have been _
at the start of a field, in which case, move right and test again.
If .Start = lngPosStart Then
.MoveRight
.Fields.ToggleShowCodes
.Fields.ToggleShowCodes
If .Start = lngPosStart + 1 Then
WithInField = False
End If
End If
End With
End Function
You can use the function with code like:
Sub TestWithInField()
Dim Rng As Word.Range, c As Word.Range, StrRslt As String
Set Rng = Selection.Range
For Each c In Rng.Characters
StrRslt = StrRslt & c.Text & ",WithInField:" & WithInField(Rng:=c) & vbCr
Next
Rng.Select
MsgBox StrRslt
End Sub
I had the same problem and I solved with the code below:
Sub Test()
NumberOfFields = Selection.Fields.Count
While NumberOfFields = 0
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
NumberOfFields = Selection.Fields.Count
Wend
End Sub
Of course, I have to know that the cursor is in a field.
Apparently, when you select a range extending to the right, at some moment the field will be selected. The end of the range doesn't count (it not acuses a field range)
I use this code
Sub GetFieldUnderCursor()
Dim NumberOfFields As Integer
Dim oFld As Field
Dim TextFeld As String
Dim Typ As Integer
Dim pos As Integer
Dim NameOfField As String
'update field. Cursor moves after the field
Selection.Fields.Update
'select the field
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
'check if there is a field
NumberOfFields = Selection.Fields.Count
If NumberOfFields = 0 Then
MsgBox "No field under cursor"
Exit Sub
End If
Set oFld = Selection.Fields(1)
TextFeld = Trim(oFld.Code.Text)
Typ = oFld.Type '85 is DOCPROPERTY, 64 is DOCVARIABLE
If Typ = 85 Or Typ = 64 Then
pos = InStr(15, TextFeld, " ")
If pos > 0 Then
NameOfField = Trim(Mid(TextFeld, 12, pos - 11))
MsgBox NameOfField
End If
End If
End Sub