Option Explicit
Private Const C_ERR_INVALID_ARGUMENT As Long = 5&
Dim m_avdblCurrentPerm As Variant
Dim m_dblCount As Double
Private Sub Class_Initialize()
m_avdblCurrentPerm = Empty
m_dblCount = 0
End Sub
Private Sub Class_Terminate()
On Error Resume Next
Erase m_avdblCurrentPerm
End Sub
Public Property Get Current() As Variant
Current = m_avdblCurrentPerm
End Property
Public Sub Init(ByVal n As Double)
If n < 1 Then
Err.Raise C_ERR_INVALID_ARGUMENT
Exit Sub
End If
Dim i As Double
ReDim m_avdblCurrentPerm(0 To n - 1) As Double
m_dblCount = n
For i = 0 To n - 1
m_avdblCurrentPerm(i) = i
Next
End Sub
Public Function MoveNext() As Boolean
If IsEmpty(m_avdblCurrentPerm) Then
Me.Init m_dblCount
Exit Function
End If
Dim i#, j#
For i = m_dblCount - 2 To 0 Step -1
If m_avdblCurrentPerm(i) < m_avdblCurrentPerm(i + 1) Then Exit For
Next
If i < 0 Then
Erase m_avdblCurrentPerm
m_avdblCurrentPerm = Empty
MoveNext = False
Exit Function
End If
For j = m_dblCount - 1 To 0 Step -1
If m_avdblCurrentPerm(j) > m_avdblCurrentPerm(i) Then Exit For
Next
Call Swap(i, j)
Call Reverse(i + 1, m_dblCount - 1)
MoveNext = True
End Function
Public Function ToString() As String
Dim i#
If Not IsEmpty(m_avdblCurrentPerm) Then
For i = 0 To m_dblCount - 1
ToString = ToString & IIf(ToString <> "", " ", "") & m_avdblCurrentPerm(i)
Next
Else
ToString = "<EOP>"
End If
End Function
Private Sub Swap(Idx1 As Double, Idx2 As Double)
Dim t As Double
t = m_avdblCurrentPerm(Idx1)
m_avdblCurrentPerm(Idx1) = m_avdblCurrentPerm(Idx2)
m_avdblCurrentPerm(Idx2) = t
End Sub
Private Sub Reverse(StartIdx As Double, EndIdx As Double)
Dim i#, j#
Dim t#
i = StartIdx
j = EndIdx
While i < j
t = m_avdblCurrentPerm(i)
m_avdblCurrentPerm(i) = m_avdblCurrentPerm(j)
m_avdblCurrentPerm(j) = t
i = i + 1
j = j - 1
Wend
End Sub