laatzen/Pruef2000/source/PruefpunktCollection.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CPruefpunktCol"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
'==============================================================================
'
' File   : PruefpunktCollection.cls
' Author : Andreas Schmidt, lindner & partner
' Date   : 14.04.1999
' Version: 1.00
'
'==============================================================================
'
' Verwaltung einer Menge von CPruefpunkt-Objekten in einer Collection mit
' Funktionalität zum Sortieren der Objekte nach Durchfluss und useCount.
'
'==============================================================================
'
' History:
'
' Author : Andreas Schmidt, lindner & partner
' Date   : 14.04.1999
' Version: 1.00
'
' Erste Version.
'
'==============================================================================

Option Explicit

' Private Member
' --------------
Private m_colPP As Collection


Private Sub Class_Initialize()
    Call init
End Sub

' Alle Member neu initialisieren
'
Private Sub init()
    Set m_colPP = New Collection
End Sub

Public Sub Add(PP As CPruefpunkt)
    PP.m_iNr = m_colPP.Count + 1
    m_colPP.Add PP
    
    Debug.Print "Prüfpunkt Nr " & PP.m_iNr & " hinzugefügt"
End Sub

' @return CPruefpunkt-Objekt an der angegebenen Position
'
Public Function Item(i As Integer) As CPruefpunkt
    On Error Resume Next
    Set Item = m_colPP.Item(i)
End Function

' @return Position des Pruefpunkt-Objekt in der PruefpunktCollection
'
Public Function ItemNr(Pruefpunkt As CPruefpunkt) As Integer
Dim Index As Integer
    For Index = 1 To m_colPP.Count
    If m_colPP.Item(Index) Is Pruefpunkt Then
        ItemNr = Index
        Exit Function
    End If
    Next
End Function


' @return Anzahl der Prüfpunkte
'
Public Function Count() As Integer
    Count = m_colPP.Count
End Function

' @return internes Collection-Objekt
'
Public Function getCollection() As Collection
    Set getCollection = m_colPP
End Function

' @return true = gesuchter Durchfluss ist in der Menge der Pruefpunkte
'
Public Function hasQ(dQ As Double) As Boolean
Dim PP As CPruefpunkt
    For Each PP In getCollection
        If PP.getQ() = dQ Then
            hasQ = True
            Exit Function
        End If
    Next
End Function


' @return Pruefpunkt Objekt aus der Collection mit vorgegebenen Durchfluss
'
Public Function getPP(dQ As Double) As CPruefpunkt
Dim PP As CPruefpunkt
    For Each PP In getCollection
        If PP.getQ() = dQ Then
            Set getPP = PP
            Exit Function
        End If
    Next
    Set getPP = Nothing
End Function


' Prüfpunkte absteigend nach Durchfluss sortieren
'
Public Sub sortQ()
    If g_blnPruefpunkteUnsortiert = False Then
        Call sortQFrom(1)
    End If
End Sub

' Hauptfunktion für das Sortieren nach dem Durchfluss.
' Wir führen hier einen einfachen Bubblesort durch.
'
Private Sub sortQFrom(nIndex As Integer)
    Dim i As Integer
    Dim tmpPP As CPruefpunkt
    
    For i = nIndex To m_colPP.Count
        If i > 1 Then
            If m_colPP.Item(i - 1).getQ() < m_colPP.Item(i).getQ() Then
                If tmpPP Is Nothing Then Set tmpPP = New CPruefpunkt
                Call tmpPP.copyFrom(m_colPP.Item(i))
                Call m_colPP.Item(i).copyFrom(m_colPP.Item(i - 1))
                Call m_colPP.Item(i - 1).copyFrom(tmpPP)
                Call sortQFrom(i - 1)
            End If
        End If
    Next i
End Sub

' Prüfpunkte aufsteigend nach dem useCount-Member sortieren
'
Public Sub sortUseCount()
    Call sortUseCountFrom(1)
End Sub

Public Sub Clear()
    Set m_colPP = Nothing
    Set m_colPP = New Collection
End Sub


' Hauptfunktion für das Sortieren nach dem useCount-Member.
' Wir führen hier einen einfachen Bubblesort durch.
'
Private Sub sortUseCountFrom(nIndex As Integer)
    Dim i As Integer
    Dim tmpPP As CPruefpunkt
    
    For i = nIndex To m_colPP.Count
        If i > 1 Then
            If m_colPP.Item(i - 1).getUseCount() > m_colPP.Item(i).getUseCount() Then
                If tmpPP Is Nothing Then Set tmpPP = New CPruefpunkt
                Call tmpPP.copyFrom(m_colPP.Item(i))
                Call m_colPP.Item(i).copyFrom(m_colPP.Item(i - 1))
                Call m_colPP.Item(i - 1).copyFrom(tmpPP)
                Call sortUseCountFrom(i - 1)
            End If
        End If
    Next i
End Sub



Public Sub Vertausche(Position1 As Integer, Position2 As Integer)
    Dim tmpPP As CPruefpunkt
    Set tmpPP = New CPruefpunkt
    Call tmpPP.copyFrom(m_colPP.Item(Position2))
    Debug.Print "Merke " & tmpPP.getQ
    Debug.Print m_colPP.Item(Position2).getQ
    
    
    Call m_colPP.Item(Position2).copyFrom(m_colPP.Item(Position1))
    Call m_colPP.Item(Position1).copyFrom(tmpPP)
End Sub