I have VBA for Word that adds a button to the context menu of the right click which launches my application (which works).
I need the word clicked on to pass it as argument. I saw that I couldn't use Selection because right click doesn't select the word, it gives me the letter after the cursor.
With what I've read, I could possibly look at the position of the cursor, then look at both sides to where the word begins and finishes.
This seems to work
Selection.Words(1).Text
Edit
A little more robust to account for ends of sentences.
Sub FindWord()
Dim rWord As Range
If Selection.Words(1).Text = vbCr Then 'end of sentence
'get last word of sentence
Set rWord = Selection.Words(1).Previous(wdWord)
Else
'get selected word
Set rWord = Selection.Words(1)
End If
'There has to be a better way than this
If rWord.Text = "." Or rWord.Text = "?" Then
Set rWord = rWord.Previous(wdWord)
End If
Debug.Print rWord.Text
End Sub
Here is the most simple way to check for the word under the cursor.
Sub Sample()
Dim pos As Long
'~~> if the cursor is at the end of the word
Selection.MoveEnd Unit:=wdCharacter, Count:=1
Do While Len(Trim(Selection.Text)) = 0
'~~> Move one character behind so that the cursor is
'~~> at the begining or in the middle
Selection.MoveEnd Unit:=wdCharacter, Count:=-1
Loop
'~~> Expand to get the word
Selection.Expand Unit:=wdWord
'~~> Display the word
Debug.Print Selection.Text
End Sub
Related
I have a code like so:
Sub MoveToBeginningSentence()
Application.ScreenUpdating = False
Dim selectedWords As Range
Dim selectedText As String
Const punctuation As String = " & Chr(145) & "
On Error GoTo ErrorReport
' Cancel macro when there's no text selected
Selection.Cut
Selection.MoveLeft Unit:=wdSentence, Count:=1, Extend:=wdMove
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Set selectedWords = Selection.Range
selectedText = selectedWords
If InStr(selectedText, punctuation) = 0 Then
Selection.MoveLeft Unit:=wdSentence, Count:=1, Extend:=wdMove
Selection.Paste
Else
Selection.MoveLeft Unit:=wdSentence, Count:=1, Extend:=wdMove
Selection.Paste
Selection.Paste
Selection.Paste
Selection.Paste
End If
ErrorReport:
End Sub
Basically, it help me move whatever text I have selected to the beginning of the sentence in Word. If there's no quotation mark, then paste once. If there is a quote mark, paste 4 times.
The problem is regardless of whether there's any quotation there or not, it will only paste once. If I set the macro to detect any other character, it will work fine. But every single time I try to force it to detect smart quotations, it will fail.
Is there any way to fix it?
Working with the Selection object is always a bit chancy; on the whole, it's better to work with a Range object. You can have only one Selection; you can have as many Ranges as you need.
Because your code uses the Selection object it's not 100% clear what the code does. Based on my best guess, I put together the following example which you can tweak if it's not exactly right.
At the beginning, I check whether there's something in the selection, or it's a blinking insertion point. If no text is selected, the macro ends. This is better than invoking Error handling, then not handling anything: If other problems crop up in your code, you wouldn't know about them.
A Range object is instantiated for the selection - there's no need to "cut" it, as you'll see further along. Based on this, the entire sentence is also assigned to a Range object. The text of the sentence is picked up, then the sentence's Range is "collapsed" to its starting point. (Think of this like pressing the left arrow on the keyboard.)
Now the sentence's text is checked for the character Chr(145). If it's not there, the original selection's text (including formatting) is added at the beginning of the sentence. If it's there, then it's added four times.
Finally, the original selection is deleted.
Sub MoveToBeginningSentence()
Application.ScreenUpdating = False
Dim selectedText As String
Dim punctuation As String
punctuation = Chr(145) ' ‘ "smart" apostrophe
Dim selRange As word.Range
Dim curSentence As word.Range
Dim i As Long
' Cancel macro when there's no text selected
If Selection.Type = wdSelectionIP Then Exit Sub
Set selRange = Selection.Range
Set curSentence = selRange.Sentences(1)
selectedText = curSentence.Text
curSentence.Collapse wdCollapseStart
If InStr(selectedText, punctuation) = 0 Then
curSentence.FormattedText = selRange.FormattedText
Else
For i = 1 To 4
curSentence.FormattedText = selRange.FormattedText
curSentence.Collapse wdCollapseEnd
Next
End If
selRange.Delete
End Sub
Please check out this code.
Sub MoveToBeginningSentence()
' 19 Jan 2018
Dim Rng As Range
Dim SelText As String
Dim Repeats As Integer
Dim i As Integer
With Selection.Range
SelText = .Text ' copy the selected text
Set Rng = .Sentences(1) ' identify the current sentence
End With
If Len(SelText) Then ' Skip when no text is selected
With Rng
Application.ScreenUpdating = False
Selection.Range.Text = "" ' delete the selected text
Repeats = IIf(IsQuote(.Text), 4, 1)
If Repeats = 4 Then .MoveStart wdCharacter, 1
For i = 1 To Repeats
.Text = SelText & .Text
Next i
Application.ScreenUpdating = True
End With
Else
MsgBox "Please select some text.", _
vbExclamation, "Selection is empty"
End If
End Sub
Private Function IsQuote(Txt As String) As Boolean
' 19 Jan 2018
Dim Quotes
Dim Ch As Long
Dim i As Long
Quotes = Array(34, 147, 148, -24143, -24144)
Ch = Asc(Txt)
' Debug.Print Ch ' read ASCII code of first character
For i = 0 To UBound(Quotes)
If Ch = Quotes(i) Then Exit For
Next i
IsQuote = (i <= UBound(Quotes))
End Function
The approach taken is to identify the first character of the selected sentence using the ASC() function. For a normal quotation mark that would be 34. In my test I came up with -24143 and -24144 (opening and closing). I couldn't identify Chr(145) but found MS stating that curly quotation marks are Chr(147) and Chr(148) respectively. Therefore I added a function that checks all of them. If you enable the line Debug.Print Ch in the function the character code actually found will be printed to the immediate window. You might add more character codes to the array Quotes.
The code itself doesn't consider spaces between words. Perhaps Word will take care of that, and perhaps you don't need it.
You need to supply InStr with the starting position as a first parameter:
If InStr(1, selectedText, punctuation) = 0 Then
Also
Const punctuation As String = " & Chr(145) & "
is going to search for space-ampersand-space-Chr(145)-space-ampersand-space. If you want to search for the smart quote character then use
Const punctuation As String = Chr(145)
Hope that helps.
I want to make a macro that will do the following:
Highlight every nth selection.
Check that selection to ensure it is a word (and not numerical or punctuation).
Cut the word and paste it into another document.
Replace the word with a blank space.
Repeat until the end of the document.
The hard part is checking a selection to validate that it is indeed a word and not something else.
I found some code written by someone else that might work, but I don't understand how to implement it in my macro with the rest of the commands:
Function IsLetter(strValue As String) As Boolean
Dim intPos As Integer
For intPos = 1 To Len(strValue)
Select Case Asc(Mid(strValue, intPos, 1))
Case 65 To 90, 97 To 122
IsLetter = True
Case Else
IsLetter = False
Exit For
End Select
Next
End Function
Sub Blank()
Dim OriginalStory As Document
Set OriginalStory = ActiveDocument
Dim WordListDoc As Document
Set WordListDoc = Application.Documents.Add
Windows(OriginalStory).Activate
sPrompt = "How many spaces would you like between each removed word?"
sTitle = "Choose Blank Interval"
sDefault = "8"
sInterval = InputBox(sPrompt, sTitle, sDefault)
Selection.HomeKey Unit:=wdStory
Do Until Selection.Bookmarks.Exists("\EndOfDoc") = True
Selection.MoveRight Unit:=wdWord, Count:=sInterval, Extend:=wdMove
Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
If IsLetter = True Then
Selection.Cut
Selection.TypeText Text:="__________ "
Windows(WordListDoc).Activate
Selection.PasteAndFormat (wdFormatOriginalFormatting)
Selection.TypeParagraph
Windows(OriginalStory).Activate
Else
Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdMove
Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
Loop
Loop
End Sub
The function should sit 'above' the rest of the code right? But I get an error 'argument not optional' when I run it.
Any ideas or tips much appreciated.
I think the code below will do most of what you want. Note that some of the comments relate to the reasons for which I discarded some of your code while others may prove helpful in understanding the present version.
Sub InsertBlanks()
' 02 May 2017
Dim Doc As Document
Dim WordList As Document
Dim Rng As Range
Dim Interval As String, Inter As Integer
Dim Wd As String
' you shouldn't care which Window is active,
' though it probably is the one you want, anyway.
' The important thing is which document you work on.
' Windows(OriginalStory).Activate
Set Doc = ActiveDocument
Application.ScreenUpdating = False
Set WordList = Application.Documents.Add
' If you want to use all these variables you should also declare them.
' However, except for the input itself, they are hardly necessary.
' sPrompt = "How many spaces would you like between each removed word?"
' sTitle = "Choose Blank Interval"
' sDefault = "8"
Do
Interval = InputBox("How many retained words would you like between removed words?", _
"Choose Blank Interval", CStr(8))
If Interval = "" Then Exit Sub
Loop While Val(Interval) < 4 Or Val(Interval) > 25
Inter = CInt(Interval)
' you can modify min and max. Exit by entering a blank or 'Cancel'.
' You don't need to select anything.
' Selection.HomeKey Unit:=wdStory
Set Rng = Doc.Range(1, 1) ' that's the start of the document
' Set Rng = Doc.Bookmarks("James").Range ' I used another start for my testing
Do Until Rng.Bookmarks.Exists("\EndOfDoc") = True
Rng.Move wdWord, Inter
Wd = Rng.Words(1)
If Asc(Wd) < 65 Then
Inter = 1
Else
Set Rng = Rng.Words(1)
With Rng
' replace Len(Wd) with a fixed number of repeats,
' if you don't want to give a hint about the removed word.
.Text = String(Len(Wd) - 1, "_") & " "
.Collapse wdCollapseEnd
End With
With WordList.Range
If .Words.Count > 1 Then .InsertAfter Chr(11)
.InsertAfter Wd
End With
Inter = CInt(Interval)
End If
Loop
Application.ScreenUpdating = True
End Sub
In order to avoid processing non-words my above code tests, roughly, if the first character is a letter (ASCII > 64). This will preclude numbers and it will allow a lot of symbols. For example "€100" would be accepted for replacement but not "100". You may wish to refine this test, perhaps creating a function like you originally did. Another way I thought of would be to exclude "words" of less than 3 characters length. That would eliminate CrLf (if Word considers that one word) but it would also eliminate a lot of prepositions which you perhaps like while doing nothing about "€100". It's either very simple, the way I did it, or it can be quite complicated.
Variatus - thank you so much for this. It works absolutely perfectly and will be really useful for me.
And your comments are helpful for me to understand some of the commands you use that I am not familiar with.
I'm very grateful for your patience and help.
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
Example -
"Let this be the test sentence" , Suppose this line is selected , I need a Word macro to select only the first alphabet , that is 'L' and then format it in which ever way I want...
I am unable to get the macro to select only the first alphabet from the selected line.
I have tried this -
`'Selection.HomeKey Unit:=wdLine
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.Expand wdLine
MsgBox (Selection.Text)`
Can somebody please give me an answer to this
I assume you mean the first character in the selection?
MsgBox Selection.Characters(1)
Or, to use it to make that character bold:
Dim firstChar As Word.Range
Set firstChar = Selection.Characters(1)
firstChar.Bold = True
Option Explicit
Sub main()
Dim firstAlphabet As Range
Selection.SetRange Start:=0, End:=1 '<--| collapse Selection to its first character
Set firstAlphabet = Selection.Range
' now use 'firstAlphabet ' range for your formatting
End Sub
I need a word macro that either highlights the first 2500 words so I can later copy them to an external application or to copy those 2500 words to the clipboard directly.
After some research I have been able to find examples of similar things but it starts copying when it finds a certain word and ends in another word, not by amount of words.
Any ideas on how to copy the first x amount of words?
Here's a small example of one would do this :
Sub HighlightFirst2500()
counter = 0
For Each w In ThisDocument.Words
If w Like "*[0-z]*" Then
counter = counter + 1
If counter >= 2500 Then
Exit For
End If
End If
If counter = 1 Then
w.Select
Else
Selection.Extend
End If
w.HighlightColorIndex = wdYellow
Next w
Selection.Copy
MsgBox "The first " & counter & " words were highlighted in yellow AND added to the clipboard!"
End Sub
So basically,
For each word in this document
If it LOOKS like a word (or a number), increment the counter
Highlight the word and add it to the selection even if it doesn't look like a word
If the counter busts the limit, exit the loop early
Copy everything that is selected
I see two options, 1 will take the first 2,500 words and put it in a string for you for later use in the code, the second option will just select and copy the first 2,500 words
Sub PutInVariable()
Dim MyArr As Variant, MyString As String
MyArr = Split(ThisDocument.Content.Text, " ")
ReDim Preserve MyArr(2499)
MyString = Join(MyArr, " ")
End Sub
Sub SelectAndCopy()
Selection.HomeKey Unit:=wdLine
Selection.MoveRight Unit:=wdWord, Count:=2500, Extend:=wdExtend
Selection.Copy
End Sub