Cool code to mix up the letters in a word.

Hmm, I can't wait!!!! No, realy!!! comon!!!

I lvoe sutf lkie tihs!

"Madvis is gnoig to psot smoe ncie cdoe hree whcih mxeis up all the ltretes in a stecenne but SILTL LAEVES IT RDABAELE. amzniag."

Yeah I read somewhere once that the eyes can usually read a word if the first and last letters remain in place, and figured I'd give it a test :) For all the non-Loungers, this is in regards to https://www.experts-exchange.com/questions/21140708/Hush-that-fuss.html

As I said I have it in an addin, but it doesnt need to be.  I created a userform, put a big text box in it (multiline=true) and named it JumbleTextBox.  I then put two buttons at the bottom named JumbleButton and CancelButton.  This is code from the userform:

Private Sub JumbleButton_Click()
 Dim RegX As Object, RegO, RegS
 Dim inString As String, tempString As String
 Dim i As Integer, midString As Collection
 Set RegX = CreateObject("VBScript.Regexp")
 Set midString = New Collection
 inString = JumbleTextBox.Text
 RegX.MultiLine = True
 RegX.Global = True
 RegX.IgnoreCase = True
 RegX.Pattern = "\b[a-z]+\b"
 Set RegO = RegX.Execute(inString)
 If RegO.Count > 0 Then
  For Each RegS In RegO
   If RegS.Length > 3 Then
    tempString = Left(RegS, 1)
    For i = 2 To Len(RegS) - 1
     midString.Add Mid(RegS, i, 1)
    Next i
    Do While midString.Count <> 0
     Randomize
     i = Int(Rnd() * midString.Count + 1)
     tempString = tempString & midString(i)
     midString.Remove (i)
    Loop
    tempString = tempString & Right(RegS, 1)
    inString = Left(inString, RegS.firstindex) & Replace(inString, RegS, tempString, RegS.firstindex + 1, 1, 1)
   End If
  Next RegS
  JumbleTextBox.Text = inString
 End If
 Set RegO = Nothing
 Set RegS = Nothing
 Set RegX = Nothing
 Set midString = Nothing
End Sub
Private Sub CancelButton_Click()
 Unload Me
End Sub

Of course you could just substitute the JumbleTextBox.Text for wherever your string is coming from/going to if you're not using a userform.  For the Excel addin I put the following in the ThisWorkbook object:

Private Sub Workbook_AddinInstall()
 Dim BordMenu As CommandBarPopup
 On Error Resume Next
 Application.CommandBars("Tools").Controls("&Word Jumble").Delete
 On Error GoTo 0
 With Application.CommandBars("Tools").Controls.Add
  .Caption = "&Word Jumble"
  .Tag = "Word Jumble"
  .OnAction = ThisWorkbook.Name & "!ThisWorkbook.ShowWordJumble"
 End With
 MsgBox "'Word Jumble' option added to Tools menu"
End Sub
Private Sub Workbook_AddinUninstall()
 On Error Resume Next
 Application.CommandBars("Tools").Controls("&Word Jumble").Delete
End Sub
Sub ShowWordJumble()
 WordJumble.Show 0
End Sub

Easy enough!
Matt

Mmmm, vrey ncie. Wntanig Aid-ni touhgh, Can you ulopad it smwohree?

Sure, I can uoplad it laetr on the scpae my isp gveis me, or you can sned an email to the adrdess in my piolrfe and I'll send it to you wehn I get out of wrok

You soluhd be able to do as I dicsbeerd avobe and jsut do svae as add-in (lsat type cioche on the list), just make srue the wokorbok you're saving has the cdoe in the the TohbsiroWokk and the uorefsrm is prat of that.  But I dnot mnid snndieg the adidn to you, it just wnot be for 3-4 hours

You may want to change the pattern line to

 RegX.Pattern = "\b\w+\b"

That way it will count _ and numbers. I was only going to jumble up alpha-only words, but a _ or number wouldnt hurt.  Just an afterthought

LOL :)

"We lost thaat blodoy cireckt mcath to thsoe pmomy baatdsrs"

I've read two of Simon Singh's excellent books "Fermat's Last Theorem" and "The Code Book", see http://www.simonsingh.net/Crypto_Corner.html. I highly  recommed "The Code Book" for anyone interested in the art and istory of cryptology

I've been toying with making my own little encryption addin but haven't got around it it yet

Some of you here would no doubt suggest that my typing skills mean that my normal posts are encrypted...

Cheers

Dave

i dnot tinhk tihs lttile tgihny wulod be any good at eiyortpcnn, but it deitenfaly wloud be fun to try to cmoe up wtih an eptronyicn alihrgtom.  i colud sntad to raed sohemting new, mbyae i wlil cehck taht out
it deos mkae for an isenntterig raed thguoh

Grrr, I can't get it working! I'll email you so if you could send the addin to me that would be good.

Cheers!

brettdj;

>>"We lost thaat blodoy cireckt mcath to thsoe pmomy baatdsrs"<<

the ahess are orus tihs tmie ;-)

Malic,

I saw your last email right as I was leaving for work.  If you use the line:

Try:

    inString = Left(inString, RegS.firstindex) & tempString & Mid(inString, RegS.firstindex + RegS.Length + 1)
    'inString = Left(inString, RegS.firstindex) & Replace(inString, RegS, tempString, RegS.firstindex + 1, 1, 1)

That should do the same for you.  The standalone replace function must have been added after xl97.  
Matt

Mlaic,

I frgoot wchih tehrad I'm in!   I saw yuor lsat eaiml rhgit as I was lvaieng for work.  If you use the lnie:

    inString = Left(inString, RegS.firstindex) & tempString & Mid(inString, RegS.firstindex + RegS.Length + 1)
    'inString = Left(inString, RegS.firstindex) & Replace(inString, RegS, tempString, RegS.firstindex + 1, 1, 1)

Taht sluhod do the smae for you.  The salntoadne rpelcae fiontcun must hvae been aeddd aetfr x9l7.  
Mtat

Woooho, it is wnrikog! Thoykanu very much sir, many hruos of etimntanerent slhal come of tihs!

Not a prelbom, tahts why i mdae it!
Its fnnuy how tihs wnet form a tetnwy piont qeuiostn to a ftify petonir, now to fvie hnruedd.  I jsut wnetad to shrae!  Tnhkas tguohh,
Mtat

PS- yvuoe pobralby aredaly freuigd it out but to cartee the leneiefd in the urrofsem teoxtbx use sifht etenr

Mmmm, being playing with this and came up with a very simple encryption and of course you can jumble it and then encrypt! It is seriously easy to crack it, but looks like total rubbish to the casual viewer. Here's the code for it, I just added a Encrypt button and a Decrypt button to Matt's add-in.

Public Const EncCode As Integer = 4
Sub EncryptButton_Click()

Dim fullStr As String
Dim tempStr As String
Dim Char As Integer
Dim i As Integer

fullStr = JumbleTextBox.Text

For i = 1 To Len(fullStr)
Char = Asc(Mid(fullStr, i, 1)) + EncCode
tempStr = tempStr & Chr(Char)
Next

JumbleTextBox.Text = tempStr

End Sub

Sub DecryptButton_Click()

Dim fullStr As String
Dim tempStr As String
Dim Char As Integer
Dim i As Integer

fullStr = JumbleTextBox.Text

For i = 1 To Len(fullStr)
Char = Asc(Mid(fullStr, i, 1)) - EncCode
tempStr = tempStr & Chr(Char)
Next

JumbleTextBox.Text = tempStr

End Sub

Like I said, extemely simple. But here is everything I wrote here after the encryption:

Qqqq0$fimrk$tpe}mrk${mxl$xlmw$erh$geqi$yt${mxl$e$ziv}$wmqtpi$irgv}txmsr$erh$sj$gsyvwi$}sy$ger$nyqfpi$mx$erh$xlir$irgv}tx%$Mx$mw$wivmsywp}$iew}$xs$gvego$mx0$fyx$pssow$pmoi$xsxep$vyffmwl$xs$xli$gewyep$zmi{iv2$Livi+w$xli$gshi$jsv$mx0$M$nywx$ehhih$e$Irgv}tx$fyxxsr$erh$e$Higv}tx$fyxxsr$xs$Qexx+w$ehh1mr2Wyf$Irgv}txFyxxsrcGpmgo,-Hmq$jyppWxv$Ew$WxvmrkHmq$xiqtWxv$Ew$WxvmrkHmq$Glev$Ew$MrxikivHmq$m$Ew$MrxikivjyppWxv$A$NyqfpiXi|xFs|2Xi|xJsv$m$A$5$Xs$Pir,jyppWxv-Glev$A$Ewg,Qmh,jyppWxv0$m0$5--$/$IrgGshixiqtWxv$A$xiqtWxv$*$Glv,Glev-Ri|xNyqfpiXi|xFs|2Xi|x$A$xiqtWxvIrh$WyfWyf$Higv}txFyxxsrcGpmgo,-Hmq$jyppWxv$Ew$WxvmrkHmq$xiqtWxv$Ew$WxvmrkHmq$Glev$Ew$MrxikivHmq$m$Ew$MrxikivjyppWxv$A$NyqfpiXi|xFs|2Xi|xJsv$m$A$5$Xs$Pir,jyppWxv-Glev$A$Ewg,Qmh,jyppWxv0$m0$5--$1$IrgGshixiqtWxv$A$xiqtWxv$*$Glv,Glev-Ri|xNyqfpiXi|xFs|2Xi|x$A$xiqtWxvIrh$WyfPmoi$M$wemh0$i|xiqip}$wmqtpi2$Fyx$livi$mw$iziv}xlmrk$M${vsxi$livi$ejxiv$xli$irgv}txmsr>

Having played a bit more change the value of the public const EncCode to 100. Then you reall do get gibberish:

¬ÅÚÍÒË„ÔÐÅÝÉÈ„Å„ÆÍØ„ÑÓÖÉ„ÇÌÅÒËÉ„ØÌÉ„ÚÅÐÙÉ„ÓÊ„ØÌÉ„ÔÙÆÐÍÇ„ÇÓÒ×Ø„©ÒǧÓÈÉ„ØÓ„•””’„¸ÌÉÒ„ÝÓÙ„ÖÉÅÐЄÈÓ„ËÉØ„ËÍÆÆÉÖÍ×Ìž

Matt, you might want to check out https://www.experts-exchange.com/questions/21143275/I-WANT-to-generate-Spelling-Errorrs.html

I think that a RegExp Replace might simplify the code above

Cheers

Dave