complex.cls

《Wrox Excel 2003 VBA Programmers Reference》 （Jun.2004）的源码

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Complex"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Implements IDTExtensibility2
Private Excel As Excel.Application

' Public Entry Point
Public Function GetNumbers(ByVal Min As Long, ByVal Max As Long) As Variant

  Dim aRange As Range
  Dim Values() As Double
  Dim Count As Long
  Dim I As Long
  Dim Value As Long
  Dim Rows As Long
  Dim Cols As Long
  
  On Error GoTo Catch
  
  Excel.Volatile
  Set aRange = Excel.Caller
  
  Rows = aRange.Rows.Count
  Cols = aRange.Columns.Count
  Count = Rows * Cols

  If (Not ValidateRange(Min, Max, Count)) Then
    GetNumbers = CVErr(xlErrValue)
    Exit Function '
  End If
  
  Values = GetRandomNumbers(Min, Max)
  Call Scramble(Values)
    
  GetNumbers = OrderValuesToCells(Rows, Cols, Values)
  Exit Function
Catch:
  MsgBox Err.Description, vbCritical
  
End Function

Private Function ValidateRange(ByVal Min As Long, _
  ByVal Max As Long, ByVal Count As Long) As Boolean

  ' We can't generate uniquely random numbers of the count if the
  ' number of elements is greater than the variety permitted by
  ' min and max
  Debug.Assert Min >= 0
  Debug.Assert Max > Min
  Debug.Assert Max - Min > Count
  
  ValidateRange = Max - Min > Count

End Function

Private Function GetRandomNumbers(ByVal Min As Long, _
  ByVal Max As Long) As Variant
  
  Dim Values() As Double
  Dim I As Long
  ReDim Values(1 To Max - Min, 1 To 2)
    
  ' We fill the first array dimension with all of the possible numbers,
  ' inclusively, between min and  max.
  ' The second column is filled with random numbers. These will be used
  ' to jumble up the possible numbers later
  
  Randomize
  For I = 1 To Max - Min
    Values(I, 1) = I + Min - 1
    Values(I, 2) = Rnd
  Next I
  
  GetRandomNumbers = Values
End Function



Private Function OrderValuesToCells(ByVal Rows As Long, ByVal Cols As Long, _
  ByVal Values As Variant) As Variant
  
  ' Order the results so that they are in a configuration
  ' that matches the selected cell configuration
  Dim Results() As Double
  ReDim Results(1 To Rows, 1 To Cols)
  
  Dim R As Long
  Dim C As Long
  Dim Index As Long
  Index = LBound(Values)
  
  For R = 1 To Rows
    For C = 1 To Cols
      Results(R, C) = Values(Index, 1)
      Index = Index + 1
    Next C
  Next R
  
  OrderValuesToCells = Results
End Function


Private Sub Scramble(ByRef Values As Variant)
  If (UBound(Values) < 10001) Then
    Call BubbleSort(Values)
  Else
    Call QuickSort(Values)
  End If
End Sub

Private Sub BubbleSort(ByRef Values As Variant)
  
  ' We can use an easy bubble sort here becasue it works well for
  ' arrays up to 10,000 or so elements. If you need to sort more items
  ' look at the selection sort or quick sort
  
  Dim I As Long
  Dim J As Long
  
  For I = LBound(Values) To UBound(Values) - 1
    For J = I + 1 To UBound(Values)
      If (Values(I, 2) > Values(J, 2)) Then
        Call Swap(Values, I, J)
      End If
    Next J
  Next I
  
End Sub

Private Sub QuickSort(ByRef Values As Variant, _
  Optional ByVal Left As Long, Optional ByVal Right As Long)

  ' A divide an conquer algorithm that works well on large,
  ' unsorted arrays.
  
  Dim I As Long
  Dim J As Long
  Dim K As Long
  Dim Item1 As Variant
  Dim Item2 As Variant

  On Error GoTo Catch

  If IsMissing(Left) Or Left = 0 Then Left = LBound(Values)
  If IsMissing(Right) Or Right = 0 Then Right = UBound(Values)

  I = Left
  J = Right

  ' Get the item between left and right
  Item1 = Values((Left + Right) \ 2, 2)

  ' Explore this section of the array of values
  Do While I < J
        
    Do While Values(I, 2) < Item1 And I < Right
      I = I + 1
    Loop

    Do While Values(J, 2) > Item1 And J > Left
      J = J - 1
    Loop
        
    If I < J Then
      Call Swap(Values, I, J)
    End If

    If I <= J Then
      I = I + 1
      J = J - 1
    End If
  Loop

  'Recurse, doing the same thing to teh left half
  If J > Left Then Call QuickSort(Values, Left, J)

  ' Recurse, doing the same thing to the right half
  If I < Right Then Call QuickSort(Values, I, Right)
  
    Exit Sub
Catch:
  MsgBox Err.Description, vbCritical
  
End Sub


Private Sub Swap(ByRef Values As Variant, ByVal I As Long, ByVal J As Long)
  
  Dim Temp1 As Double
  Dim Temp2 As Double
  
  Temp1 = Values(I, 1)
  Temp2 = Values(I, 2)
  
  Values(I, 1) = Values(J, 1)
  Values(I, 2) = Values(J, 2)
  Values(J, 1) = Temp1
  Values(J, 2) = Temp2

End Sub

Private Sub IDTExtensibility2_OnAddInsUpdate(custom() As Variant)

End Sub

Private Sub IDTExtensibility2_OnBeginShutdown(custom() As Variant)

End Sub

Private Sub IDTExtensibility2_OnConnection(ByVal Application As Object, _
  ByVal ConnectMode As AddInDesignerObjects.ext_ConnectMode, _
  ByVal AddInInst As Object, custom() As Variant)

  Set Excel = Application

End Sub

Private Sub IDTExtensibility2_OnDisconnection( _
  ByVal RemoveMode As AddInDesignerObjects.ext_DisconnectMode, custom() As Variant)

  Set Excel = Nothing

End Sub

Private Sub IDTExtensibility2_OnStartupComplete(custom() As Variant)

End Sub