Option Explicit
Public Junk As Integer
Public Type ExchangeData
    TheString As String
    StringN As Integer  'String length
    StringX As Integer  'Position of moving byte
    Forward As Boolean  'Direction
  End Type
Public Pcontrol(1 To 30) As ExchangeData
Public Pslot As Long 'Subscript for Pcontrol
Public PermutationF() As String * 10
Public PermutationX() As String
Public NextPermutation As String
Public Sub Main()

Load frmPerm
frmPerm.Show

End Sub
Public Sub NextMaker()
Dim Tbyte As String * 1
Dim Tstring As String
Dim N As Long
Dim X As Long

Tstring = Pcontrol(Pslot).TheString
N = Pcontrol(Pslot).StringN
X = Pcontrol(Pslot).StringX

If N = 2 Then
        Tstring = Right(Tstring, 1) & Left(Tstring, 1)
    ElseIf Pcontrol(Pslot).Forward Then
        If X < N Then
                Tbyte = Mid(Tstring, X, 1)
                Mid(Tstring, X, 1) = Mid(Tstring, X + 1, 1)
                Mid(Tstring, X + 1, 1) = Tbyte
                Pcontrol(Pslot).StringX = X + 1
            Else
                Pcontrol(Pslot).Forward = False
                Pslot = Pslot + 1
                Call NextMaker
                Pslot = Pslot - 1
                Tstring = NextPermutation _
                            & Right(Pcontrol(Pslot).TheString, 1)
          End If
    Else
        If X > 1 Then
                    Tbyte = Mid(Tstring, X, 1)
                    Mid(Tstring, X, 1) = Mid(Tstring, X - 1, 1)
                    Mid(Tstring, X - 1, 1) = Tbyte
                    Pcontrol(Pslot).StringX = X - 1
                Else
                    Pcontrol(Pslot).Forward = True
                    Pslot = Pslot + 1
                    Call NextMaker
                    Pslot = Pslot - 1
                    Tstring = Left(Pcontrol(Pslot).TheString, 1) _
                                    & NextPermutation
          End If
  End If

Pcontrol(Pslot).TheString = Tstring
NextPermutation = Tstring

End Sub
Public Sub KwikSortF(LastSlot As Long, _
                        Item() As String * 10)
Dim KwikFirst(1 To 30) As Long
Dim KwikLast(1 To 30) As Long
Dim KwikSlot As Integer
Dim Alpha As Long
Dim Omega As Long
Dim A As Long
Dim Z As Long
Dim M As Long
Dim J As Long
Dim LengthA As Long
Dim LengthZ As Long
Dim MidString As String * 10

KwikSlot = 1
KwikFirst(1) = 1
KwikLast(1) = LastSlot

Do
    DoEvents
    Alpha = KwikFirst(KwikSlot)
    Omega = KwikLast(KwikSlot)
    M = Alpha + (Omega - Alpha) / 2
    A = Alpha
    Z = Omega
    MidString = Item(M)
    Do
        For J = A To M - 1
            If MidString > Item(J) Then
                    'Okay as is'
                Else
                    Item(M) = Item(J)
                    M = J
                    Exit For
              End If
          Next J
        A = J
        For J = Z To M + 1 Step -1
            If MidString < Item(J) Then
                    'Okay as is'
                Else
                    Item(M) = Item(J)
                    M = J
                    Exit For
              End If
          Next J
        Z = J
      Loop While A < Z
    
    Item(M) = MidString
    LengthA = M - Alpha
    LengthZ = Omega - M
    'Some replacements superfluous (Alpha & Omega in Kwikslot),'
    'but make code easier to understand'
    If LengthA < LengthZ Then
            If LengthZ < 6 Then
                    KwikSlot = KwikSlot - 1 'both new Partitions are small'
                ElseIf LengthA < 6 Then
                    KwikFirst(KwikSlot) = M + 1 'Replace current Partition'
                    KwikLast(KwikSlot) = Omega
                Else 'Must replace current with 2 Partitions'
                    KwikFirst(KwikSlot) = Alpha
                    KwikLast(KwikSlot) = M - 1
                    KwikSlot = KwikSlot + 1
                    KwikFirst(KwikSlot) = M + 1
                    KwikLast(KwikSlot) = Omega
              End If
        ElseIf LengthA < 6 Then
                    KwikSlot = KwikSlot - 1 'Both new Partitions small'
        ElseIf LengthZ < 6 Then
                    KwikFirst(KwikSlot) = Alpha
                    KwikLast(KwikSlot) = M - 1
        Else
                    KwikFirst(KwikSlot) = M + 1
                    KwikLast(KwikSlot) = Omega
                    KwikSlot = KwikSlot + 1
                    KwikFirst(KwikSlot) = Alpha
                    KwikLast(KwikSlot) = M - 1
      End If
      
  Loop Until KwikSlot = 0

End Sub
Public Sub KwikSortX(LastSlot As Long, _
                        Item() As String)
Dim KwikFirst(1 To 30) As Long
Dim KwikLast(1 To 30) As Long
Dim KwikSlot As Integer
Dim Alpha As Long
Dim Omega As Long
Dim A As Long
Dim Z As Long
Dim M As Long
Dim J As Long
Dim LengthA As Long
Dim LengthZ As Long
Dim MidString As String

KwikSlot = 1
KwikFirst(1) = 1
KwikLast(1) = LastSlot

Do
    DoEvents
    Alpha = KwikFirst(KwikSlot)
    Omega = KwikLast(KwikSlot)
    M = Alpha + (Omega - Alpha) / 2
    A = Alpha
    Z = Omega
    MidString = Item(M)
    Do
        For J = A To M - 1
            If MidString > Item(J) Then
                    'Okay as is'
                Else
                    Item(M) = Item(J)
                    M = J
                    Exit For
              End If
          Next J
        A = J
        For J = Z To M + 1 Step -1
            If MidString < Item(J) Then
                    'Okay as is'
                Else
                    Item(M) = Item(J)
                    M = J
                    Exit For
              End If
          Next J
        Z = J
      Loop While A < Z
    
    Item(M) = MidString
    LengthA = M - Alpha
    LengthZ = Omega - M
    'Some replacements superfluous (Alpha & Omega in Kwikslot),'
    'but make code easier to understand'
    If LengthA < LengthZ Then
            If LengthZ < 6 Then
                    KwikSlot = KwikSlot - 1 'both new Partitions are small'
                ElseIf LengthA < 6 Then
                    KwikFirst(KwikSlot) = M + 1 'Replace current Partition'
                    KwikLast(KwikSlot) = Omega
                Else 'Must replace current with 2 Partitions'
                    KwikFirst(KwikSlot) = Alpha
                    KwikLast(KwikSlot) = M - 1
                    KwikSlot = KwikSlot + 1
                    KwikFirst(KwikSlot) = M + 1
                    KwikLast(KwikSlot) = Omega
              End If
        ElseIf LengthA < 6 Then
                    KwikSlot = KwikSlot - 1 'Both new Partitions small'
        ElseIf LengthZ < 6 Then
                    KwikFirst(KwikSlot) = Alpha
                    KwikLast(KwikSlot) = M - 1
        Else
                    KwikFirst(KwikSlot) = M + 1
                    KwikLast(KwikSlot) = Omega
                    KwikSlot = KwikSlot + 1
                    KwikFirst(KwikSlot) = Alpha
                    KwikLast(KwikSlot) = M - 1
      End If
      
  Loop Until KwikSlot = 0

End Sub
Public Sub InsertSortF(LastSlot As Long, _
                    Item() As String * 10)
Dim J As Long
Dim K As Long
Dim Tstring As String * 10

Item(0) = ""
J = 1
K = 2

Do
    DoEvents
    If Item(K) < Item(J) Then
            Tstring = Item(K)
            For J = K To 2 Step -1
                If Item(J - 1) < Tstring Then
                        Item(J) = Tstring
                        Exit For
                    Else
                        Item(J) = Item(J - 1)
                  End If
              Next J
       End If
    J = K
    K = K + 1
  Loop While J < LastSlot

End Sub
Public Sub InsertSortX(LastSlot As Long, _
                    Item() As String)
Dim J As Long
Dim K As Long
Dim Tstring As String

Item(0) = ""
J = 1
K = 2

Do
    DoEvents
    If Item(K) < Item(J) Then
            Tstring = Item(K)
            For J = K To 2 Step -1
                If Item(J - 1) < Tstring Then
                        Item(J) = Tstring
                        Exit For
                    Else
                        Item(J) = Item(J - 1)
                  End If
              Next J
       End If
    J = K
    K = K + 1
  Loop While J < LastSlot

End Sub
Public Function LongFormat(X As Long) As String
Dim DoubleX As Double

DoubleX = X
LongFormat = DoubleFormat(DoubleX)

End Function
Public Function DoubleFormat(RawNumber As Double) As String
Dim P As Integer
Dim Q As Integer
Dim N As Integer
Dim E As Integer

Dim Estring As String
Dim Gstring As String
Dim Tstring As String
Dim AbsNumber As Double
Dim CpyNumber As Double

AbsNumber = Abs(RawNumber)
Gstring = CStr(AbsNumber)
N = Len(Gstring)
P = InStr(Gstring, "E")

If P > 0 Then
        'Use Gstring as is'

    ElseIf AbsNumber > 9999.999 Then
        P = InStr(Gstring, ".")

        If P = 0 Then
                Q = N - 3
            Else
                Q = P - 4
          End If

        Gstring = Left(Gstring, Q) & "," _
                    & Right(Gstring, N - Q)

        If Q > 3 Then

            Do
                Q = Q - 3
                N = Len(Gstring)
                Gstring = Left(Gstring, Q) & "," _
                    & Right(Gstring, N - Q)
              Loop Until Q < 4
          End If
    
    ElseIf Left(Gstring, 2) = "0." Then
        Gstring = Right(Gstring, N - 1)
    Else
        'Use Gstring as is'
  End If
  
If RawNumber < 0 Then
        DoubleFormat = "-" & Gstring
    Else
        DoubleFormat = Gstring
  End If
  
End Function
