Ce code cherche les permutations d'une chaîne.
Il recherche en fait toutes les chaines que l'on peut paire a partir d'une chaine (je ne suis pas sûr d'être clair, regardez l'exemple ;) )
Ex.: "pour "abc", il retourne "abc", "acb", "bac", "bca", "cab", "cba"
J'ai mis le code de la classe qui fait ca, et dans le zip y a le prog de démo...
Source / Exemple :
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'' clsPermutaion
'' Written by : Christophe POLLET
''
'' Modifications :
'' - 25. jun. 2002 by Christophe POLLET : Starting developpement
''
'' Description :
'' Searches for the permutations of some letters
''
'' Copyright : Christophe POLLET
''
'' Contact :
'' - Christophe POLLET : <seyev@infomaniak.ch>
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' PUBLICS DATAS
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' PRIVATES DATAS
Private gcLetters As New Collection ' The letters
Private gsWords() As String ' The words
Private gsTempWords() As String '
Private gsSeparator As String ' The separator
Private gdNumberOfPermutations As Double '
Private gcListBox As ListBox '
Private gcTextBox As TextBox '
Private gbUseListBox As Boolean '
Private gbUseTextBox As Boolean '
Private gbFound As Boolean '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' PUBLICS EVENTS
Public Event NewPermutation(dCurrentNumber As Double)
Public Event NewPrint(dCurrentNumber As Double)
Public Event SearchDone()
Public Event PrintDone()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' PUBLIC PROPERTIES
Public Property Let Letters(ByVal sLetters As String)
Dim sLettersArray() As String
Dim N As Integer
sLettersArray = Split(sLetters, gsSeparator, -1, vbTextCompare)
For N = gcLetters.Count To 1 Step -1
gcLetters.Remove (N)
Next N
For N = 0 To UBound(sLettersArray)
Call gcLetters.Add(sLettersArray(N))
Next N
gdNumberOfPermutations = GetNumberOfPermutations(gcLetters.Count)
gbFound = False
End Property
Public Property Get Letters() As String
Dim sLettersArray() As String
Dim N As Integer
ReDim sLettersArray(gcLetters.Count - 1)
For N = 1 To gcLetters.Count
sLettersArray(N - 1) = gcLetters.Item(N)
Next N
Letters = Join(sLettersArray, gsSeparator)
End Property
Public Property Let Separator(ByVal sSeparator As String)
If sSeparator <> "" Then
gsSeparator = sSeparator
Else
MsgBox ("clsPermutaion::Separator : cannot use null separator")
End If
End Property
Public Property Get Separator() As String
Separator = gsSeparator
End Property
Public Property Let UseListBox(ByRef cListBox As ListBox)
Set gcListBox = cListBox
gbUseListBox = True
End Property
Public Property Let UseTextBox(ByRef cTextBox As TextBox)
Set gcTextBox = cTextBox
gbUseTextBox = True
End Property
Public Property Get NumberOfLetters() As Long
NumberOfLetters = gcLetters.Count
End Property
Public Property Get NumberOfPermutations() As Double
NumberOfPermutations = gdNumberOfPermutations
End Property
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' PRIVATES METHODS
Private Sub Class_Initialize()
gsSeparator = " "
gbUseListBox = False
gbUseTextBox = False
gbFound = False
End Sub
Private Function GetNumberOfPermutations(ByVal lNumberOfLetters As Long) As Double
Dim Result As Double
Dim N As Long
If (lNumberOfLetters < 0) Or (lNumberOfLetters > 170) Then
Call MsgBox("Number too high : " & CStr(lNumberOfLetters), vbCritical + vbOKOnly, "clsPermutation")
Exit Function
End If
Result = 1
For N = 1 To lNumberOfLetters
Result = Result * N
Next
GetNumberOfPermutations = Result
End Function
Private Sub GetPermutations(cLetters As Collection)
Dim N As Long
Dim cTempLetters As New Collection
Dim lCurrent As Long
DoEvents
lCurrent = UBound(gsTempWords)
For N = 1 To cLetters.Count
Call CopyCollection(cLetters, cTempLetters)
gsTempWords(lCurrent) = gsTempWords(lCurrent - 1) & cTempLetters(N)
cTempLetters.Remove (N)
If cTempLetters.Count = 0 Then
gsWords(UBound(gsWords)) = gsTempWords(lCurrent)
ReDim Preserve gsWords(UBound(gsWords) + 1)
ReDim Preserve gsTempWords(lCurrent - 1)
RaiseEvent NewPermutation(CDbl(UBound(gsWords)))
Exit Sub
End If
ReDim Preserve gsTempWords(lCurrent + 1)
Call GetPermutations(cTempLetters)
Next N
End Sub
Private Sub CopyCollection(cFrom As Collection, cTo As Collection)
Dim N As Long
For N = cTo.Count To 1 Step -1
cTo.Remove (N)
Next N
For N = 1 To cFrom.Count
Call cTo.Add(cFrom.Item(N))
Next N
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' PUBLICS METHODS
Public Sub printPermutations(ByVal bUseDefaut, _
Optional ByVal bUseListBox As Boolean = False, _
Optional bUseTextBox As Boolean = False)
Dim N As Long
If Not gbFound Then
Call MsgBox("Permutations must be found before calling Permutation::printPermutation", vbOKOnly + vbCritical, "clsPermtuation")
Exit Sub
End If
For N = 0 To UBound(gsWords)
RaiseEvent NewPrint(CDbl(N))
DoEvents
If bUseDefaut Then
If gbUseListBox Then gcListBox.AddItem (gsWords(N))
If gbUseTextBox Then gcTextBox.Text = gcTextBox.Text & vbCrLf & gsWords(N)
Else
If bUseListBox And gbUseListBox Then gcListBox.AddItem (gsWords(N))
If bUseTextBox And gbUseListBox Then gcTextBox.Text = gcTextBox.Text & vbCrLf & gsWords(N)
End If
Next N
RaiseEvent NewPrint(CDbl(N))
RaiseEvent PrintDone
End Sub
Public Sub searchPermutations()
ReDim gsTempWords(1)
ReDim gsWords(0)
Call GetPermutations(gcLetters)
ReDim Preserve gsWords(UBound(gsWords) - 1)
ReDim gsTempWords(0)
gbFound = True
RaiseEvent SearchDone
End Sub
Conclusion :
Voila... Si vous faites des modifs, merci de me tenir au courant à seyev@infomaniak.ch
Encore quelque chose : pour une chaine contenant deux fois la même lettre, le programme renvoie des doublons (pas de contrôles de doublons)
Pour ls prochaines versions : contrôle de doublons
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.