Porgramme to Solve the words in a set of jumbled Alphabets

I had created this program while playing text games on BING so that I can quickly solve puzzles and earn points... lost the lust after sometime. But searched a lot on Internet at that time and did not find it. I found that hub users may be interested....

take it into word VBA macro and run "my trained script"

provide the jumbled letters from Bing text game...

It would generate all valid combinations for 3,4, 5, 6 and 7 letter words and write on the page. solve your text puzzles fast... Did not get time to clean.. but it works.. the more letter you give and more time it takes... try up to 7 letters.. it takes about 30 - 50 seconds.

enjoy!

 Public myWords() As String
Public wordCount As Integer
Public xx As Long
Public expString As Words
Public scrambDict As New Scripting.Dictionary
Public Sub myTrainedScript()

Dim word As String
Dim strcombis As String
Dim l, pos, c
Dim myStrs() As String * 1
Dim wordLen As Integer
Dim mlen, posx
Dim loopWord
xx = 0

wordCount = 0
ReDim myWords(wordCount) As String

word = InputBox("Please give me letters", "Ask Letters")
word = sortStr(word)
wordLen = Len(word)
ReDim myStrs(wordLen) As String * 1

For l = 1 To wordLen
  myStrs(l) = Mid(word, l, 1)
Next
strCombi word
elimOnePos word, 3
scrambDict.RemoveAll

Debug.Print xx

wordCount = UBound(myWords)

If wordCount = 0 Then Exit Sub

For i = 1 To wordCount
  For j = i + 1 To wordCount
    If myWords(i) > myWords(j) Then
      temp = myWords(i)
      myWords(i) = myWords(j)
      myWords(j) = temp
    End If
  Next
Next

For i = 1 To wordCount
  For j = i + 1 To wordCount
    If Len(myWords(i)) > Len(myWords(j)) Then
      temp = myWords(i)
      myWords(i) = myWords(j)
      myWords(j) = temp
    End If
  Next
Next

mylen = Len(myWords(1))

For i = 1 To wordCount
  If myWords(i) <> myWords(i - 1) Then
  If Len(myWords(i)) = mylen Then
    ActiveDocument.Range.InsertAfter myWords(i) & ", "
  Else
    ActiveDocument.Range.InsertAfter Chr(13)
    ActiveDocument.Range.InsertAfter myWords(i) & ", "
    mylen = Len(myWords(i))
 End If
End If
Next
End Sub
Public Sub elimOnePos(srcStr, tgtLen)
Dim thisLen As Integer, thisLoopStr As String
thisLen = Len(srcStr)
For i = 1 To thisLen
  Select Case i
  Case 1
    thisLoopStr = Right(srcStr, thisLen - 1)
  Case thisLen
    thisLoopStr = Left(srcStr, thisLen - 1)
  Case Else
    thisLoopStr = Mid(srcStr, 1, i - 1) & Mid(srcStr, i + 1, thisLen - i)
  End Select
  thisLoopStr = sortStr(thisLoopStr)
  If Not (scrambDict.Exists(thisLoopStr)) Then
    scrambDict.Add thisLoopStr, thisLoopStr
    strCombi thisLoopStr
    If Len(thisLoopStr) <> tgtLen Then
      elimOnePos thisLoopStr, tgtLen
    End If
  End If
  xx = xx + 1
Next
End Sub

Sub strCombi(inputString As String) ' main program structure begins here
Dim seedinput As String * 1
Dim remainstrX As String
Dim chkchar As String * 1
Dim stringLength As Integer, i As Integer
Dim strs() As String * 1
stringLength = Len(inputString)
ReDim strs(stringLength) As String * 1
inputString = sortStr(inputString)
seedinput = ""
For i = 1 To stringLength
  strs(i) = Mid(inputString, i, 1)
Next
For i = 1 To stringLength
  If (strs(i) <> seedinput) Then
    seedinput = strs(i)
    Select Case i
      Case 1
        remainstrX = Right(inputString, stringLength - 1)
      Case stringLength
        remainstrX = Left(inputString, stringLength - 1)
      Case Else
        remainstrX = Mid(inputString, 1, i - 1) & Mid(inputString, i + 1, stringLength - i)
    End Select
    Call StrRecur(seedinput, Trim(remainstrX), 0, "@")
  End If
Next
End Sub

Sub StrRecur(instrX, mainstrX, cplace, cchar) ' this is a recursive subsroutine
Dim chklen As Integer, i As Integer
Dim seedStr As String, nxtstr As String
Dim nxtchar
Dim strsX() As String * 1

chklen = Len(mainstrX)
If (chklen = 1) Then
  seedStr = instrX & mainstrX
  GoTo myt20
End If
nxtchar = ""
ReDim strsX(chklen) As String * 1
For i = 1 To chklen
  strsX(i) = Mid(mainstrX, i, 1)
Next

For i = 1 To chklen
  If (nxtchar <> strsX(i)) Then
    nxtchar = strsX(i)
    seedStr = instrX & nxtchar
    Select Case i
    Case 1
      nxtstr = Mid(mainstrX, i + 1, chklen - i)
    Case chklen
      nxtstr = Mid(mainstrX, 1, i - 1)
    Case Else
      nxtstr = Mid(mainstrX, 1, i - 1) & Mid(mainstrX, i + 1, chklen - i)
    End Select
    Call StrRecur(Trim(seedStr), Trim(nxtstr), cplace, cchar)
  End If
Next
GoTo myt30
myt20: If (cplace <> 0) Then
        If (Mid(seedStr, cplace1) = cchar) Then
          If Application.CheckSpelling(seedStr) Then
            ActiveDocument.Paragraphs.Add (seedStr)
          End If
        End If
      Else
        If Application.CheckSpelling(seedStr) Then
          wordCount = wordCount + 1
          ReDim Preserve myWords(wordCount) As String
          myWords(wordCount) = seedStr
        End If
      End If
myt30: xxd = 0
End Sub

Function sortStr(instrX) As String
Dim temp As String * 1
Dim strLen As Integer
Dim strs() As String * 1

strLen = Len(instrX)
ReDim strs(strLen) As String * 1

For i = 1 To strLen
  strs(i) = Mid(instrX, i, 1)
Next

For i = 1 To strLen - 1
  For j = (i + 1) To strLen
    If (strs(i) > strs(j)) Then
      temp = strs(i)
      strs(i) = strs(j)
      strs(j) = temp
    End If
  Next
Next

sortStr = ""

For i = 1 To strLen
  sortStr = sortStr & strs(i)
Next

End Function