Anyone have a word scrambler macro?

[sb1920alk]

I'm looking for a macro that will scramble all of the words in a document in
the following manner: all of the words in the document stay in their current
location, the first and last letter of each word remain where they are, the
letters between the first and last letter will be scrambled, whenever
possible the result is not the same spelling as the original word.

For example this sentence, "The quick brown fox jumps over the lazy dog"
would be replaced with something like, "The qicuk borwn fox jmpus oevr the
lzay dog"

So, it won't change 1, 2, or 3 letter words, it also won't change some 4
letter words like "cool" and "look"

It's interesting that the scrambled sentence is still fairly readable.

This would be great to work out. I'm trying to play a joke on someone. If I
can get a working macro, I'll make a button for it that looks like the spell
check button.

Thanks,

 

[Greg Maxey]

This only reverses the letters it doesn't scramble the them:

Sub TestReverseWords()
Dim myRange As Range
Dim aWord As Range
Dim nCount As Long
Set myRange = Selection.Range
'Set myRange = ActiveDocument.Range(Start:=0, End:=Selection.End)
For nCount = myRange.Words.Count To 1 Step -1
Set aWord = myRange.Words(nCount)
If Len(aWord) > 3 Then
aWord.MoveStart wdCharacter, 1
If (aWord.Characters.Last = " ") Then
aWord.MoveEnd wdCharacter, -2
Else
aWord.MoveEnd wdCharacter, -1
End If
aWord.Text = StrReverse(aWord.Text)
End If
Next nCount
End Sub

--
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Greg Maxey - Word MVP

My web site http://gregmaxey.mvps.org
Word MVP web site http://word.mvps.org~~~~~~~~~~~~~~~~~~~~~~~~~~

 

[sb1920alk]

That's pretty cool.
Thanks,

This only reverses the letters it doesn't scramble the them:

Sub TestReverseWords()
Dim myRange As Range
Dim aWord As Range
Dim nCount As Long
Set myRange = Selection.Range
'Set myRange = ActiveDocument.Range(Start:=0, End:=Selection.End)
For nCount = myRange.Words.Count To 1 Step -1
Set aWord = myRange.Words(nCount)
If Len(aWord) > 3 Then
aWord.MoveStart wdCharacter, 1
If (aWord.Characters.Last = " ") Then
aWord.MoveEnd wdCharacter, -2
Else
aWord.MoveEnd wdCharacter, -1
End If
aWord.Text = StrReverse(aWord.Text)
End If
Next nCount
End Sub

--
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Greg Maxey - Word MVP

My web site http://gregmaxey.mvps.org
Word MVP web site http://word.mvps.org~~~~~~~~~~~~~~~...spell check button. Thanks,[/QUOTE] [/QUOTE]

 

[Greg Maxey]

Here is one that will actually randomize the mid-characters. However,
randomization of four letters words could result in the same word.

Sub RandomizeCharactersInWordsFirstAndLastExclusive()
Dim myRange As Range
Dim aWord As Range
Dim aWordCut As Range
Dim i As Long
Dim pStr As String
Dim pTempStr As String
Dim j As Long
Set myRange = ActiveDocument.Range
For i = 1 To myRange.Words.Count
Set aWord = myRange.Words(i)
If Len(aWord) > 3 Then
aWord.MoveStart wdCharacter, 1
If (aWord.Characters.Last = " ") Then
aWord.MoveEnd wdCharacter, -2
Else
aWord.MoveEnd wdCharacter, -1
End If
Set aWordCut = aWord
pStr = aWordCut.Text
Randomize
Do While pStr <> ""
j = Int((Len(pStr) * Rnd) + 1)
pTempStr = pTempStr & Mid(pStr, j, 1)
pStr = Replace(pStr, Mid(pStr, j, 1), "", , 1)
Loop
aWordCut.Text = pTempStr
pTempStr = ""
End If
Next i
End Sub

--
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Greg Maxey - Word MVP

My web site http://gregmaxey.mvps.org
Word MVP web site http://word.mvps.org~~~~~~~~~~~~~~~~~~~~~~~~~~

 

[Greg Maxey]

The following will help minimize the number of times that randomizatin of
the inner characters result in the same word. Of course as you have already
mentioned, there is nothing to be done with words like look, book, seem,
teen, good, etc.

Sub RandomizeCharactersInWordsFirstAndLastExclusive()
Dim myRange As Range
Dim aWord As Range
Dim aWordCut As Range
Dim i As Long
Dim pStr As String
Dim pTempStr As String
Dim j As Long
Set myRange = ActiveDocument.Range
For i = 1 To myRange.Words.Count
Set aWord = myRange.Words(i)
If Len(aWord) > 3 Then
aWord.MoveStart wdCharacter, 1
If (aWord.Characters.Last = " ") Then
aWord.MoveEnd wdCharacter, -2
Else
aWord.MoveEnd wdCharacter, -1
End If
Set aWordCut = aWord
pStr = aWordCut.Text
Randomize
Do While pStr <> ""
j = Int((Len(pStr) * Rnd) + 1)
pTempStr = pTempStr & Mid(pStr, j, 1)
pStr = Replace(pStr, Mid(pStr, j, 1), "", , 1)
Loop
If aWordCut.Text = pTempStr Then
pTempStr = StrReverse(pTempStr)
End If
aWordCut.Text = pTempStr
pTempStr = ""
End If
Next i
End Sub


--
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Greg Maxey - Word MVP

My web site http://gregmaxey.mvps.org
Word MVP web site http://word.mvps.org~~~~~~~~~~~~~~~~~~~~~~~~~~

 

[sb1920alk]

LOL. This is perfect.

Thanks,

The following will help minimize the number of times that randomizatin of
the inner characters result in the same word. Of course as you have already
mentioned, there is nothing to be done with words like look, book, seem,
teen, good, etc.

Sub RandomizeCharactersInWordsFirstAndLastExclusive()
Dim myRange As Range
Dim aWord As Range
Dim aWordCut As Range
Dim i As Long
Dim pStr As String
Dim pTempStr As String
Dim j As Long
Set myRange = ActiveDocument.Range
For i = 1 To myRange.Words.Count
Set aWord = myRange.Words(i)
If Len(aWord) > 3 Then
aWord.MoveStart wdCharacter, 1
If (aWord.Characters.Last = " ") Then
aWord.MoveEnd wdCharacter, -2
Else
aWord.MoveEnd wdCharacter, -1
End If
Set aWordCut = aWord
pStr = aWordCut.Text
Randomize
Do While pStr <> ""
j = Int((Len(pStr) * Rnd) + 1)
pTempStr = pTempStr & Mid(pStr, j, 1)
pStr = Replace(pStr, Mid(pStr, j, 1), "", , 1)
Loop
If aWordCut.Text = pTempStr Then
pTempStr = StrReverse(pTempStr)
End If
aWordCut.Text = pTempStr
pTempStr = ""
End If
Next i
End Sub


--
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Greg Maxey - Word MVP

My web site http://gregmaxey.mvps.org
Word MVP web site http://word.mvps.org~~~~~~~~~~~~~~~...That's pretty cool. Thanks, [/QUOTE] [/QUOTE]

 

[Greg Maxey]

Good. Have fun with your prank. You might want to duck and run if your
victim doesn't have a saved a copy of their document available before you
spring your prank.



--
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Greg Maxey - Word MVP

My web site http://gregmaxey.mvps.org
Word MVP web site http://word.mvps.org~~~~~~~~~~~~~~~~~~~~~~~~~~