Вот то, что я сделал пару лет назад после того, как выучил много теории, что касается списков. Я пытался реализовать списки как они реализованы в SML (функциональный язык такой). То что от теории до практики далеко, очень хорошо видно на этом примере  Сделать все это можно наверняка намного лучше, но два года назад я это сделал так... Если вообще непонятно как класс пользовать, то пишите, но пока у меня такой бардак в форме в которой используется этот класс, а разгребать лень  | Код |
'********************************************************************'
' '
' ~~~ list.dll ~~~ '
' Version 1.0 '
' '
' Copyright (c)2003 cardinal, All Rights Reserved '
' '
'********************************************************************'
' ~~~ List methods ~~~
'--------------------------------------------------------------------'
' id | type | effect '
'--------------------------------------------------------------------'
' Append | 'a NList -> 'a NList | append
'--------------------------------------------------------------------'
' Cons | 'a -> 'a NList | adds an element '
' | | ('a::('a NList)) '
'--------------------------------------------------------------------'
' Rev | () -> 'a NList | reverse list '
'--------------------------------------------------------------------'
' Tail_Cut | () -> 'a NList | delete first element '
'--------------------------------------------------------------------'
' ~~~ List properties ~~~
'--------------------------------------------------------------------'
' id | type | effect '
'--------------------------------------------------------------------'
' Head | 'a | first element '
' Tail | 'a NList | tail of list '
' ListType | String | type of list ("'a NList") '
' Length | Integer | number of elements '
' Elem | Integer -> 'a | n`th element (1-based) '
'--------------------------------------------------------------------'
' ~~~ List errors ~~~
'--------------------------------------------------------------------'
' id | description '
'--------------------------------------------------------------------'
' 1 | Your list is empty '
' 2 | List is not empty '
' 3 | Unknown type '
' 13 | Type mismatch '
'--------------------------------------------------------------------'
Option Explicit
Private mListCol As New Collection ' the list itself
Private mListType As String ' type of the list
Private mHelpList As New NList ' NList for inner operations
Private mHelpCol As New Collection ' Collection for inner operations
' type check functions
'/////////////////////////////////////////////////////////////////////
Private Function ConcatCheck(y As NList) As NList
If y = "nil" Then
Exit Function
End If
Check (y.Head)
'y.Tail_Cut
'ConcatCheck y
End Function
'*****************************************************
' Purpose: Checks the type of the given element
'
' Inputs: s: element as a string.
'
' Returns: raises an exception if incorrect
' type.
'*****************************************************
Private Function Check(s As Variant)
On Error GoTo ErrorHandle
If s = "nil" Then
Exit Function
End If
Select Case Split(mListType, " ")(0)
Case "Boolean"
s = CBool(s)
Case "Byte"
s = CByte(s)
Case "Currency"
s = CCur(s)
Case "Date"
s = CDate(s)
Case "Double"
s = CDbl(s)
Case "Decimal"
s = CDec(s)
Case "Integer"
s = CInt(s)
Case "Long"
s = CLng(s)
Case "Single"
s = CSng(s)
Case "String"
s = CStr(s)
Case "Variant"
s = CStr(s)
End Select
ErrorHandle:
If Err.Number = 13 Then
Err.Raise 13, , "Type mismatch" & _
vbCrLf & "Your list is an " & ListType
End If
End Function
'*****************************************************
' Purpose: Sets a type to a string element
'
' Inputs:
' s: the string in list format.
' Returns: A Variant type element.
'*****************************************************
Private Function SetType(s As Variant) As Variant
On Error GoTo ErrorHandle
Select Case Split(mListType, " ")(0)
Case "Boolean"
SetType = CBool(s)
Case "Byte"
SetType = CByte(s)
Case "Currency"
SetType = CCur(s)
Case "Date"
SetType = CDate(s)
Case "Double"
SetType = CDbl(s)
Case "Decimal"
SetType = CDec(s)
Case "Integer"
SetType = CInt(s)
Case "Long"
SetType = CLng(s)
Case "Single"
SetType = CSng(s)
Case "String"
SetType = CStr(s)
Case "Variant"
SetType = CStr(s)
Case "NList"
Case Else
Err.Raise 3
End Select
ErrorHandle:
If Err.Number = 3 Then ' type mismatch
Err.Raise 3, , "Unknown type"
End If
If Err.Number = 13 Then ' type mismatch
Err.Raise 13, , "Type mismatch" & _
vbCrLf & "Your list is an " & mListType
End If
End Function
Property Let ListType(lt As String)
If mListCol.Count < 2 Then
Select Case lt
Case "Boolean NList"
Case "Byte NList"
Case "Currency NList"
Case "Date NList"
Case "Double NList"
Case "Decimal NList"
Case "Integer NList"
Case "Long NList"
Case "Single NList"
Case "String NList"
Case "NList NList"
Case "Variant NList"
Case Else
Err.Raise 3, , "Unknown type"
End Select
mListType = lt
Else
Err.Raise 2, , "List is not empty"
End If
End Property
Property Let Value(val As String)
Dim i As Integer
For i = 1 To mListCol.Count
mListCol.Remove (1)
Next
If val = "" Then
ListCreate "nil"
Else
ListCreate val
End If
End Property
Private Function valOfNListNList(n As Integer) As String
Dim i As Integer
Dim s As String
Dim j As Integer
If mListCol.Count <= 3 Then
For i = 1 + n To mListCol.Count - 1
s = s & "("
For j = 1 To mListCol.Item(i).Count - 1
s = s & CStr(mListCol.Item(i).Item(j)) & "::"
Next
s = s & CStr(mListCol.Item(i).Item(mListCol.Item(i).Count)) & ")::"
Next
valOfNListNList = s & mListCol.Item(mListCol.Count)
Else
For i = 1 To 3
s = s & "("
For j = 1 To mListCol.Item(i).Count - 1
s = s & CStr(mListCol.Item(i).Item(j)) & "::"
Next
s = s & CStr(mListCol.Item(i).Item(j)) & ")"
Next
valOfNListNList = s & "..."
End If
End Function
Property Get Value() As String
On Error GoTo ErrorHandle
Dim i As Integer
Dim j As Integer
Dim s As String
Dim e As String
If mListCol.Count < 2 Then
Value = "nil"
Exit Property
End If
If mListType = "NList NList" Then
Value = valOfNListNList(0)
Else
If mListCol.Count <= 10 Then
For i = 1 To mListCol.Count - 1
If mListType = "Byte NList" Then
e = "&H" & Hex(mListCol.Item(i))
Else
e = mListCol.Item(i)
End If
s = s & e & "::"
Next
Value = s & mListCol.Item(mListCol.Count)
Else
For i = 1 To 9
s = s & CStr(mListCol.Item(i)) & "::"
Next
Value = s & "..."
End If
End If
ErrorHandle:
If Err.Number = 424 Then
Err.Raise 13, , "Type mismatch" & _
vbCrLf & "Your list is an " & mListType
End If
End Property
Property Get Length() As Variant
Length = mListCol.Count - 1
End Property
Property Get Elem(Num As Integer) As Variant
Elem = mListCol.Item(Num)
End Property
' the head of the list
Property Get Head() As Variant
On Error GoTo ErrorHandle
Dim i As Integer
Dim s As String
If mListCol.Count > 1 Then
If mListType = "NList NList" Then
If mListCol.Count <= 10 Then
For i = 1 To mListCol.Item(1).Count - 1
s = s & CStr(mListCol.Item(1).Item(i)) & "::"
Next
Head = s & mListCol.Item(1).Item(mListCol.Item(1).Count)
Else
For i = 1 To 9
s = s & CStr(mListCol.Item(1).Item(i)) & "::"
Next
Head = s & "..."
End If
Else
Head = mListCol.Item(1)
End If
Else
Err.Raise 1, , "Your list is empty!"
End If
ErrorHandle:
If Err.Number = 424 Then
Err.Raise 13, , "Type mismatch" & _
vbCrLf & "Your list is an " & mListType
End If
End Property
Public Function Append(x As NList) As NList
Dim y As New NList
Dim z As New NList
y = x
If mListCol.Count > 1 Then
z = x
ConcatCheck y
Do Until z = "nil"
mListCol.Add z.Head, , before:=mListCol.Count
z.Tail_Cut
Loop
Else
Do Until y = "nil"
Check (y.Head)
y.Tail_Cut
Loop
Do Until x = "nil"
If mListCol.Count = 0 Then
mHelpCol.Add SetType(x.Head)
Else
mHelpCol.Add SetType(x.Head), , before:=mListCol.Count
End If
x.Tail_Cut
Loop
mHelpCol.Add ("nil")
Set mListCol = mHelpCol
Set mHelpCol = Nothing
End If
End Function
Property Get Tail() As String
Dim i As Integer
Dim s As String
If mListCol.Count < 2 Then
Err.Raise 1, , "Your list is empty!"
Exit Property
End If
If mListType = "NList NList" Then
Tail = valOfNListNList(1)
Else
If mListCol.Count <= 10 Then
For i = 2 To mListCol.Count - 1
s = s & CStr(mListCol.Item(i)) & "::"
Next
Tail = s & mListCol.Item(mListCol.Count)
Else
For i = 2 To 10
s = s & CStr(mListCol.Item(i)) & "::"
Next
Tail = s & "..."
End If
End If
End Property
Public Function Tail_Cut() As NList
If mListCol.Count > 1 Then
mListCol.Remove (1)
Else
Err.Raise 1, , "List is empty"
End If
End Function
'*****************************************************
' Purpose: Reverses the string by given list format
'
' Inputs:
' s: the string in list format.
' Returns: A Variant array with elements of the
' list to be created.
'*****************************************************
Private Function MyStrRevPoint(s As String) As Variant
Dim i As Variant
Dim revs As String
Dim point As Variant
point = Split(s, "::")
For Each i In point
If revs = "" Then
revs = i & revs
Else
revs = i & "::" & revs
End If
Next
MyStrRevPoint = Split(revs, "::")
End Function
'*****************************************************
' Purpose: Creates a list from a string expression
'
' Inputs:
' s: the string in list format.
' Returns: list of given elements.
'*****************************************************
Private Function ListCreate(mliststr As String) As NList
Dim i As Variant
Dim point As Variant
point = MyStrRevPoint(mliststr)
'For Each i In point
' Check (i)
'Next
For Each i In point
If i <> "nil" Then
Cons (i)
End If
Next
End Function
'*****************************************************
' Purpose: Adds an element to the beginning of a list.
'
' Inputs: s: an element as a string.
'
' Returns: A list with the element in the beginning.
'*****************************************************
Public Function Cons(ByVal s As Variant) As NList
On Error GoTo ErrorHandle
If TypeName(s) = "NList" Then
If mListType <> "NList NList" Then
Err.Raise 13
End If
mHelpList = s
Do Until mHelpList = "nil"
mHelpCol.Add mHelpList.Head
mHelpList.Tail_Cut
Loop
Set mHelpList = Nothing
mHelpCol.Add ("nil")
If mListCol.Count = 0 Then
mListCol.Add ("nil")
End If
mListCol.Add mHelpCol, before:=1
Set mHelpCol = Nothing
Else
Check (s)
If Left(s, 2) = "&H" And mListCol.Count < 2 Then
If mListType <> "Byte NList" And mListType <> "Variant NList" Then
Err.Raise 13
End If
End If
s = SetType(s)
If mListCol.Count < 1 Then
mListCol.Add ("nil")
mListCol.Add s, before:=1
Else
mListCol.Add s, before:=1 ', before:=mListCol.Count
End If
End If
ErrorHandle:
If Err.Number = 13 Then ' type mismatch
Err.Raise 13, , "Type mismatch" & _
vbCrLf & "Your list is an " & mListType
End If
End Function
Property Get ListType() As String 'If mListCol.Count > 1 Then
ListType = mListType
ErrorHandle:
If Err.Number = 13 Then ' type mismatch
Err.Raise 13, , "Type mismatch" & _
vbCrLf & "Your list is an " & ListType
End If
End Property
'*****************************************************
' Purpose: Reverses a list of type NList.
'
' Returns: Reversed list of type NList.
'*****************************************************
Public Function Rev() As NList
Dim i As Integer
For i = mListCol.Count - 1 To 1 Step -1
mHelpCol.Add mListCol.Item(i)
Next
mHelpCol.Add "nil"
Set mListCol = mHelpCol
Set mHelpCol = New Collection
End Function
Public Function toString() As String
Dim i As Integer
Dim s As String
For i = 1 To mListCol.Count - 1
s = s & mListCol.Item(i)
Next
toString = s
End Function
Private Sub Class_Initialize()
mListType = "Variant NList"
ErrorHandle:
If Err.Number = 13 Then ' type mismatch
Err.Raise 13, , "Type mismatch" & _
vbCrLf & "Your list is an " & ListType
End If
End Sub
|
|
Списки в VB/VBA, ... кто что знает? и что думает? :) 
Загрузка ...
RefList.rar 1,17 Kb
