I'm not quite familiar with VBA in general or working with Range. I'd like to add a checkbox after a line of text but the following code outputs all the checkboxes at the very end of the document. I'd think the range parameter in setting the checkbox needs to be fixed but I don't know how to identify it.
'http://wordribbon.tips.net/T010727_Inserting_Multiple_Graphics_in_a_Document.html
Sub GenerateLab()
Dim sPic As String
Dim sPath As String
sPath = "C:\Users\lab\Documents\PDF Gen 12-1\TestImages\"
sPic = Dir(sPath & "*.png")
Do While sPic <> ""
Selection.TypeText ("Is this an ***?")
Selection.TypeParagraph
Selection.TypeText ("***")
Dim objCC As ContentControl
Set objCC = ActiveDocument.ContentControls _
.Add(wdContentControlCheckBox)
Selection.TypeParagraph
Selection.TypeText ("Not ***")
Dim objCC2 As ContentControl
Set objCC2 = ActiveDocument.ContentControls _
.Add(wdContentControlCheckBox)
Selection.InlineShapes.AddPicture _
FileName:=sPath & sPic, _
LinkToFile:=False, SaveWithDocument:=True
sPic = Dir
Selection.InsertBreak (7)
Loop
End Sub
The problem is not that the checkbox is added at the end of the document but that it's added after the current selection/insertion point (which is the same as the end of the document). Then everything else is added in front of the box and it stays at the end. A short fix would be to move the cursor to the end of the line (or document) by adding the line
Selection.EndKey wdLine
or
Selection.EndKey wdStory
right after .Add.
Another possibility would be to move the cursor 3 characters to the right:
Selection.Move Unit:=wdCharacter, Count:=3
This would be an alternative if you don't add the checkbox at the end of a line.
Related
I have a Merged-letters Document I need to split it into individual letters.
Following code is doing exactly But it didn't copy the header and footer of each individual page. How can I make it to copy headers and footers along with first section.
Right now it is using oDoc.Sections.First.Range.Cut line to copy the section.
Code:
Sub Splitter_Updated()
' Based on a Macro created 16-08-98 by Doug Robbins to save each letter created by a
' mailmerge as a separate file.
Dim Letters As Long
Dim Counter As Long
Dim Mask As String
Dim DocName As String
Dim oDoc As Document
Dim oNewDoc As Document
Set oDoc = ActiveDocument
oDoc.Save
Selection.EndKey Unit:=wdStory
Letters = Selection.Information(wdActiveEndSectionNumber)
Selection.HomeKey Unit:=wdStory
Counter = 1
While Counter < Letters
DocName = Format(Date, "ddMMyy") _
& "-" & LTrim$(Str$(Counter)) & ".docx"
Debug.Print oDoc.Sections.Count
Debug.Print oDoc.Sections.First.Headers(wdHeaderFooterFirstPage).Range.Text
oDoc.Sections.First.Range.Cut
Set oNewDoc = Documents.Add
'Documents are based on the Normal template
'To use an alternative template follow the link.
With Selection
.Paste
.EndKey Unit:=wdStory
.MoveLeft Unit:=wdCharacter, Count:=1
.Delete Unit:=wdCharacter, Count:=1
End With
oNewDoc.SaveAs FileName:=oDoc.Path & Application.PathSeparator & DocName, AddToRecentFiles:=False
'FileFormat:=wdFormatDocument,
ActiveWindow.Close
Counter = Counter + 1
Wend
oDoc.Close wdDoNotSaveChanges
End Sub
'''
When I used the code below it works in the document where it was created. If I change documents, it fails. does anyone know why?
'''
'
Sub AddTOC() 'Need to find how to stop going in error on doc change
Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=0
Application.Templates( _
"C:\Users\Sean Celestin\AppData\Roaming\Microsoft\Document Building Blocks\1033\16\Built-In
Building Blocks.dotx" _
).BuildingBlockEntries("Automatic Table 1").Insert Where:=Selection.Range _
, RichText:=True
Selection.InsertBreak Type:=wdPageBreak
End Sub
'
The following code does essentially the same thing without embedding the Table of Contents in the container used by the Building Block Entry. That container imposes a significant performance hit when the TOC is updated. By not using Selection, the code is also more efficient.
Sub AddTOC()
Application.ScreenUpdating = False
With ActiveDocument
.Range(0, 0).Text = vbCr & Chr(12)
.Fields.Add .Range(0, 0), wdFieldEmpty, "TOC \o ""1-3"" \h \z \u", False
.Range(0, 0).Text = "Contents" & vbCr
.Range.Paragraphs.First.Style = "TOC Heading"
End With
Application.ScreenUpdating = True
End Sub
I am trying to create two keyboard shortcuts which allow me to move selected words quickly to the right and left within a text. The selected text should move one word to the left or the right.
Here is what I want to do
1) Select words e.g. “this is” in the sentence “this is a tree”
2) Press e.g. ctrl + alt + arrow to the right
3) The sentence reads now as “a this is tree”
4) Press again ctrl alt + arrow to the right
5) The sentence reads now as “a tree this is”
The idea is to replace the cut / paste steps and make the process a bit more efficient and smoother.
I have no knowledge in VB, but managed to get close to by using Word’s macro-function.
Sub moveRight()
'moveRight Macro
Selection.Cut
Selection.moveRight Unit:=wdWord, Count:=1
Selection.PasteAndFormat (wdFormatOriginalFormatting)
End Sub
The problem with this function is that the selected words are no longer selected once they are pasted. Hence, triggering the function again (=moving the text more than one word) results in an error (I would have to select the relevant text again). Is there any way that the selected words remain selected after they are pasted so that I can trigger the function repeatedly?
Many thanks.
You might like to try this solution. The first two procedures below should be called by your keyboard shortcuts. The both call the same executing sub, but with different parameters.
Sub MoveSelectionLeft()
' call with keyboard shortcut
GetSelection True
End Sub
Sub MoveSelectionRight()
' call with keyboard shortcut
GetSelection False
End Sub
Private Sub GetSelection(ByVal ToLeft As Boolean)
' 22 Apr 2017
Dim Rng As Range
Dim SelTxt As String ' selected text (trimmed)
Dim Sp() As String
Set Rng = Selection.Range
With Rng
SelTxt = Trim(.Text)
If ToLeft Then
.MoveStart wdWord, -1
Else
.MoveEnd wdWord, 1
End If
Sp = Split(Trim(.Text))
If ToLeft Then
.Text = SelTxt & " " & Sp(0) & " "
Else
.Text = Sp(UBound(Sp)) & " " & SelTxt & " "
End If
.Find.Execute SelTxt
.Select
End With
End Sub
A cheap way of doing this is with bookmarks. At some point before and after moving the text, run AddBookMark and DeleteBookMark respectively.
Public Sub AddBookMark()
Dim myDocument As Document
Set myDocument = ActiveDocument
myDocument.Bookmarks.Add "MySelectedText", Selection
End Sub
Public Sub DeleteBookMark()
Dim myDocument As Document
Set myDocument = ActiveDocument
myDocument.Bookmarks("MySelectedText").Delete
End Sub
Sub moveRight()
Dim myDocument As Document
Set myDocument = ActiveDocument
Selection.Cut
Selection.moveRight Unit:=wdWord, Count:=1
Selection.PasteAndFormat (wdFormatOriginalFormatting)
myDocument.Bookmarks("MySelectedText").Select
End Sub
I'm an amateur at vba for Word.
My macro (below) creates a hyperlink from selected text, but the new hyperlink is black, whereas a hyperlink that I create using MS Word's menu, is blue.
I want my macro to create hyperlinks that are blue too.
As you'll see in my macro (below), I've not been able to get the hyperlinks to be blue.
Any suggestions would be much appreciated.
Marc
Here's the macro:
Sub subHyprlinkSrch4PdfFiles_aaa()
'
' subHyprlinkSrch4PdfFiles_aaa Macro
'
'
Dim strTextToDisplay As String
Dim rngSelection As RAnge
Selection.MoveDown Unit:=wdLine, Count:=2
Selection.MoveLeft Unit:=wdCharacter, Count:=5
Selection.MoveLeft Unit:=wdCharacter, Count:=9, Extend:=wdExtend
Set rngSelection = ActiveDocument.Selection.RAnge
Application.Selection.Font.ColorIndex = wdBlue
strTextToDisplay = Application.Selection.Text
ActiveDocument.Hyperlinks.Add Anchor:=Selection.RAnge, Address:="" _
, SubAddress:="", ScreenTip:="", TextToDisplay:=strTextToDisplay
Application.Selection.Style = wdStyleHyperlink
Application.Selection.Font.ColorIndex = wdBlue
With rngSelection
.Font.ColorIndex = wdBlue
End With
End Sub 'subHyprlinkSrch4PdfFiles_aaa()
Here's the sub that I fixed with the solution User Don Jewett gave me yesterday, Nov. 2, 2016 (below):
Sub subHyperlinkSelectedTextaaa() 'Hyperlink to a file whatever text you selected.
'Hyperlink to a file whatever text you selected.
' http://www.wiseowl.co.uk/blog/s209/type-filedialog.htm
Dim Sel01 As Selection
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
Dim iFileChosen As Integer
Dim strFileFullname As String
Dim Txt2Display As String
Set Sel01 = Application.Selection
If Sel01.Type <> wdSelectionIP Then ' i.e., if the selection is valid, i.e., characters are selected
Txt2Display = Sel01.Text
'MsgBox Txt2Display
Else
MsgBox "No characters were selected validly; so this macro will terminate now."
Exit Sub
End If 'If Sel01.Type <> wdSelectionIP Then ' i.e., if the selection is valid, i.e., characters are selected
' Open FileDialog "fd" and select a file
iFileChosen = fd.Show
If iFileChosen <> -1 Then
'You didn't choose anything (clicked on CANCEL)
MsgBox "You chose cancel, or something prevented the file-selection-dialog from operating property."
Else
strFileFullname = CStr(fd.SelectedItems(1))
'MsgBox strFileFullname
End If
' http://stackoverflow.com/questions/40388765/color-of-new-ms-word-hyperlink-is-black-and-i-want-it-to-be-blue
With Application.Selection
.Font.ColorIndex = wdBlue
'ActiveDocument.Hyperlinks.Add Selection.Range, .Text, "", "", .Text
ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:= _
strFileFullname, SubAddress:="", ScreenTip:="", TextToDisplay:=Txt2Display
.Style = wdStyleHyperlink
End With
End Sub 'subHyperlinkSelectedTextaaa()
If you want to create a hyperlink using the selected text as the link and text, this should work fine:
Sub subHyprlinkSrch4PdfFiles_aaa()
With Application.Selection
.Font.ColorIndex = wdBlue
ActiveDocument.Hyperlinks.Add Selection.Range, .Text, "", "", .Text
.Style = wdStyleHyperlink
End With
End Sub
After reading many sources and copying-pasting a lot I have come up with a macro for MS Word 2010 to calculate my work done at the end of the day.
What it does:
Opens each DOCX file in a specified directory.
Copies text from the right part of a two-column table that I use for translations.
Opens the statistics file and pastes clipboard at the top of the file.
When no more files are left to process, the macro prints statistics at the top of the statistics file.
It works all right. However, I'd love to make it work faster. If I use the macro to process like 50-100 files, it may slow down after 10-15 to 1 file per second perhaps. I am at a loss. I guess I didn't choose the right tool for the job. Can I make this code run faster?
I've tried to experiment with:
1.Passing arguments to open file command (AddToRecentFiles:=False which added a negligible improvement if at all).
2.Setting Window.Visible = False to subroutines but then the macro does not copy any text.
I am not even sure what oDoc does in:
Set oDoc = Documents.Open(FileName:=vDirectory & vFile, AddToRecentFiles:=False)
Lots of Googling, copy-pasting with only basic knowledge. Sorry about that. But I am willing to learn.
'Create variables to use later
Dim vDirectory As String
Dim vFileTarget As String
Dim vStat1 As Variant
Dim vStat2 As Variant
'Variables to clear clipboard in case of errors
Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function EmptyClipboard Lib "user32" () As Long
Public Declare Function CloseClipboard Lib "user32" () As Long
Sub GoodStats()
vDirectory = "C:\Users\Job\Calculate\" 'Files to process
vFile = Dir(vDirectory & "*.docx*") 'Extension of the files to process
vFileTarget = "C:\Users\Job\stats.docx" 'File for the final count
Application.ScreenUpdating = False
DeleteOld 'Prepare final count file for new calculation
Do While vFile <> "" 'Get this show on the road
Set oDoc = Documents.Open(FileName:=vDirectory & vFile, AddToRecentFiles:=False)
TextCopy
TextMove
vFile = Dir
Loop
'Proceed to next function because there are no files left to process
FinalRun
Application.ScreenUpdating = True
End Sub
Function DeleteOld()
'Previous statistics is deleted from final count file
Documents.Open FileName:=vFileTarget
Selection.WholeStory
Selection.Delete Unit:=wdCharacter, Count:=1
ActiveDocument.Save
End Function
'Primary cycle of document open, copy, paste begins
Function TextCopy() 'Copy text from right part of the table
On Error GoTo ErrorHandler 'Goes to error handler if there is no text on the right side
Selection.MoveRight Unit:=wdCell
Selection.Copy
ActiveWindow.Close
Exit Function
ErrorHandler: 'If there is no text, close document, proceed to next function
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
ActiveWindow.Close
Exit Function
End Function
Function TextMove() 'Move copied text to final count file
On Error GoTo ErrorHandler
Documents.Open FileName:=vFileTarget
Selection.PasteAndFormat (wdFormatOriginalFormatting)
Selection.HomeKey Unit:=wdStory
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Font.Bold = wdToggle
Selection.HomeKey Unit:=wdLine
Selection.TypeParagraph
Selection.TypeParagraph
Selection.TypeParagraph
Selection.HomeKey Unit:=wdStory
ActiveDocument.Save
ActiveWindow.Close
ErrorHandler: 'If error, close document and move on
Exit Function
End Function
Function FinalRun()
'Open the final count file to calculate statistics
Documents.Open FileName:=vFileTarget
Selection.HomeKey Unit:=wdStory
'Calculate number of symbols and spaces
vStat1 = ActiveDocument.ComputeStatistics(Statistic:=wdStatisticCharactersWithSpaces)
'Translation pages = symbols + spaces divide by 1860
vStat2 = Round((ActiveDocument.ComputeStatistics(Statistic:=wdStatisticCharactersWithSpaces) / 1860), 2)
Selection.TypeText Text:=vStat1 & " symbols with spaces" 'First statistics line
Selection.TypeParagraph
Selection.TypeText Text:=vStat2 & " translated pages"
'Money = pages multiplied by 10000
Selection.TypeParagraph
Selection.TypeText Text:=vStat2 * 10000 & " rubles for all the translations"
ActiveDocument.Save
End Function
UPDATE
Thanks to KazJaw I now have the macro I want. Thanks a lot for directing me to the Range feature. The new macro does not copy files but calculates statistics from selections in each file one by one, adds all the numbers and displays the results in a message box. And it definitely feels faster.
UPDATE 2
I've added
Application.Visible = False
and the macro works like that. I've also added a timer to calculate the execution time and the macro now loops through 173 files in about 10 seconds :)
Sub GoodStats()
'Create variables to use later
Dim vDirectory As String
Dim charCount As Single
Dim tcharCount As Single
Dim pageCount As Single
Dim moneyCount As Single
Dim myRange As Range
Dim startTime As Double
'Clear basic statistics number if you run macro multiple times
tcharCount = 0
startTime = Timer
'Folder to process
vDirectory = "C:\Users\Job\Calculate\"
'Extension of the files to process
vFile = Dir(vDirectory & "*.docx*")
'Don't want all those files popping up
Application.ScreenUpdating = False
Application.Visible = False
'Get this show on the road
Do While vFile <> ""
Set oDoc = Documents.Open(FileName:=vDirectory & vFile, AddToRecentFiles:=False)
'Switch to the right column
Selection.MoveRight unit:=wdCell
Set myRange = ActiveDocument.Range(Selection.Start, Selection.End)
'Get the initial number
charCount = myRange.ComputeStatistics(Statistic:=wdStatisticCharactersWithSpaces)
'Add the current document stats to overall stats
tcharCount = tcharCount + charCount
ActiveWindow.Close
vFile = Dir
Loop
'Translation pages = symbols + spaces divide by 1860
pageCount = Round((tcharCount / 1860), 2)
moneyCount = pageCount * 10000
Application.ScreenUpdating = True
Application.Visible = True
Done = Timer - startTime
'Show the results in a message box with multiple lines
MsgBox tcharCount & " total characters" & vbCrLf & _
pageCount & " total pages" & vbCrLf & _
moneyCount & " total money" & vbCrLf & _
"Done in " & Done & " seconds"
End Sub
First of all- opening and closing documents is time consuming!
Second, selecting is usually inefficient way of working with Word documents, Excel ranges, Office shapes, etc.
Instead of that you could try to set reference to Object Variable and operate with your text by working with your variable. However, it requires some changes in your code and different approach.
Below you will find a part of your code (Function TextMove()) which I transformed from Selection approach to Object Variable approach. I kept your code (in comments) that you could compare what is instead of which part of the code. This code do the same but it should run much faster.
Function TextMove() 'Move copied text to final count file
On Error GoTo ErrorHandler
Documents.Open FileName:=vFileTarget
Selection.PasteAndFormat (wdFormatOriginalFormatting)
'CHANGES AS OF THIS SECTION
Dim myRange As Range
Selection.HomeKey unit:=wdStory
'Selection.EndKey unit:=wdLine, Extend:=wdExtend
Set myRange = ActiveDocument.Range(0, Selection.EndKey(wdLine, wdExtend))
'Selection.Font.Bold = wdToggle
myRange.Font.Bold = wdToggle
'Selection.HomeKey unit:=wdLine
'Selection.TypeParagraph
'Selection.TypeParagraph
'Selection.TypeParagraph
myRange.InsertBefore Chr(13) & Chr(13) & Chr(13)
'Selection.HomeKey unit:=wdStory
myRange.MoveStart wdStory '<< but you rather don't need it
'END OF CHANGES
ActiveDocument.Save
ActiveWindow.Close
ErrorHandler: 'If error, close document and move on
Exit Function
End Function