Solved

500 points! need help badly - hardcore vb

Posted on 2002-05-31
19
340 Views
Last Modified: 2010-05-02
hi there.
below is a class that encapsulates a long-array.
the class has some neat functions like shift, push, pop, unshift, automatic resizing etc and it works fine.

i wanted to create something similar for string-arrays but i failed. since i need this class, i would appreciate if somebody could implement this string-class for me.

i post the code of the "long"-class to give you an idea of what i want.

i will give many points for this, so i expect something really working.

thanks in advance,

holli

=======================================================================================

Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As Long)

Dim intData() As Long
Dim lngUbound As Long

Private Const MYLEN = 4

'Die Eigenschaft gibt den oberen Rand des Arrays zurück
Public Property Get UpperBound() As Long
    UpperBound = lngUbound
End Property

'Die Eigenschaft gibt den Array-Wert an lngIndex zurück
Public Property Get Value(lngIndex As Long) As Long
    CheckBounds lngIndex, True
    Value = intData(lngIndex)
End Property
'Die Eigenschaft setzt den Array-Wert an lngIndex
Public Property Let Value(lngIndex As Long, intValue As Long)
    CheckBounds lngIndex, True
    intData(lngIndex) = intValue
End Property


' Die Funktion liest den Wert des ersten Elements und gibt ihn zurück.
' Das erste Element wird abgeschnitten.
Public Function Shift() As Long
    Shift = intData(0)
    If lngUbound > 0 Then
        Call CopyMemory(intData(0), intData(1), lngUbound * MYLEN)
        ReDim Preserve intData(lngUbound - 1)
        lngUbound = lngUbound - 1
    ElseIf lngUbound = 0 Then
        lngUbound = -1
    Else
        Err.Raise 9, "IntArray-Class", "No more Elements for Shift"
    End If
End Function

' Die Funktion fügt den Wert newLong an den Anfang des Arrays intData
Public Sub Unshift(ByVal intNewValue As Long)
    CheckBounds lngUbound + 1, True
    Call CopyMemory(intData(1), intData(0), lngUbound * MYLEN)
    intData(0) = intNewValue
End Sub

' Die Funktion liest den Wert des letzten Elements und gibt ihn zurück.
' Das letzte Element wird abgeschnitten.
Public Function Pop() As Long
    If lngUbound > 0 Then
        Pop = intData(lngUbound)
        ReDim Preserve intData(lngUbound - 1)
        lngUbound = lngUbound - 1
    ElseIf lngUbound = 0 Then
        Pop = intData(lngUbound)
        lngUbound = lngUbound - 1
    Else
        Err.Raise 9, "IntArray-Class", "No more Elements for Pop"
    End If
End Function

' Die Funktion fügt den Wert newLong an das Ende des Arrays intData
Public Function Push(ByVal intNewValue As Long) As Long
    CheckBounds lngUbound + 1, True
    intData(lngUbound) = intNewValue
    Push = lngUbound
End Function

' Die Funktion schneidet einen Wert aus einem Array und gibt ihn zurück
Public Function Extract(lngIndex As Long) As Long
    Dim intEmpty() As Long
    CheckBounds lngIndex
   
    Extract = intData(lngIndex)
   
    If lngIndex <> lngUbound Then Call CopyMemory(intData(lngIndex), intData(lngIndex + 1), (lngUbound - lngIndex) * MYLEN)
   
    If lngIndex = 0 And lngUbound = 0 Then
        ReDim intData(0)
        intData = intEmpty
        lngUbound = -1
    Else
        ReDim Preserve intData(lngUbound - 1)
        lngUbound = lngUbound - 1
    End If
End Function

' Die Funktion setzt einen Wert an lngIndex und gibt den alten zurück
Public Function Swap(lngIndex As Long, intValue As Long) As Long
    CheckBounds lngIndex, True
    Swap = intData(lngIndex)
    intData(lngIndex) = intValue
End Function


' Die Funktion fügt einen Wert an lngIndex ein
Public Sub Inject(lngIndex As Long, intValue As Long)
    CheckBounds lngUbound + 1, True
   
    If lngIndex <> lngUbound Then
        CopyMemory intData(lngIndex + 1), intData(lngIndex), (lngUbound - lngIndex) * MYLEN
    End If
   
    intData(lngIndex) = intValue
End Sub


' Die Funktion fügt einen Wert an lngIndex ein
Public Function InjectSorted(intValue As Long) As Long
    Dim lngIndex As Long
   
    CheckBounds lngUbound + 1, True
    lngIndex = SearchBinaryPos(intValue)
   
    If lngIndex <> lngUbound Then
        CopyMemory intData(lngIndex + 1), intData(lngIndex), (lngUbound - lngIndex) * MYLEN
    End If
   
    intData(lngIndex) = intValue
    InjectSorted = lngIndex
End Function


' Die Funktion schneidet den durch ExtractFrom und ExtractLength festgelegten Auschschnitt
' aus dem Array intData und gibt ihn zurück und.
Public Function ExtractArray(lngExtractFrom As Long, intExtractLength As Long) As Long()
    ExtractArray = myExtractArray(lngExtractFrom, intExtractLength, False)
End Function

Private Function myExtractArray(lngExtractFrom As Long, intExtractLength As Long, Optional blJustCopy = False) As Long()
    Dim intExtractedArray() As Long, intEmpty() As Long
           
    On Error GoTo FehlerBehandlung
       
    'Oberen Rand checken und ggf. neu setzen
    CheckBounds lngExtractFrom + intExtractLength - 1
   
    'Leeres Array zurückgeben wenn Länge=0
    If intExtractLength <= 0 Then myExtractArray = intExtractedArray: Exit Function
   
    ' Auschnitt zurückgeben
    ReDim intExtractedArray(intExtractLength - 1)
    Call CopyMemory(intExtractedArray(0), intData(lngExtractFrom), intExtractLength * MYLEN)
    myExtractArray = intExtractedArray
       
    If blJustCopy Then Exit Function
   
    'Wenn alles extrahieren
    If lngExtractFrom + intExtractLength - 1 = lngUbound And lngExtractFrom = 0 Then
   
        ' Array wird ganz gelöscht
        lngUbound = -1
        ReDim intData(0)
        intData = intEmpty
   
    Else
   
        If lngExtractFrom + intExtractLength <= UBound(intData) Then
            'Daten nach "vorne" kopieren
            Call CopyMemory(intData(lngExtractFrom), intData((lngExtractFrom + intExtractLength)), (lngUbound - intExtractLength - lngExtractFrom + 1) * MYLEN)
        End If
       
        ' Ein Teil bleibt übrig
        ' Array verkleinern
        ReDim Preserve intData(UBound(intData) - intExtractLength)
        lngUbound = lngUbound - intExtractLength
    End If
   
    Exit Function

FehlerBehandlung:
    Select Case Err.Number
    Case Else
        Select Case MsgBox("Unerwarteter Fehler " & Err.Number & ": " & Err.Description & vbCrLf & _
            "in Projekt1.clsIntArray.ExtractArray." & vbCrLf & _
            "Fehler aufgetreten in Zeile: " & Erl, _
            vbAbortRetryIgnore + vbCritical, "Fehler")
        Case vbAbort
            Screen.MousePointer = vbDefault
            Exit Function
        Case vbRetry
            Resume
        Case vbIgnore
            Resume Next
        End Select
    End Select
   
End Function

' Die Funktion kopiert den ExtractFrom und ExtractLength festgelegten Auschschnitt
' aus dem Array intData und gibt ihn zurück und.
Public Function CopyArray(lngExtractFrom As Long, intExtractLength As Long) As Long()
    CopyArray = myExtractArray(lngExtractFrom, intExtractLength, True)
End Function

' Die Funktion fügt das Array Injectarray an der Stelle insertAt ein
Public Sub InsertArray(lngInsertAt As Long, intInjectArray() As Long)
    Dim lngLastUbound As Long, lngMoveElements As Long, lngInjectElements As Long
   
    lngLastUbound = lngUbound
    lngInjectElements = UBound(intInjectArray) + 1
    lngMoveElements = lngLastUbound - lngInsertAt + 1
   
    CheckBounds lngLastUbound + lngInjectElements, True
   
    If lngMoveElements > 0 Then
        Call CopyMemory(intData(lngInsertAt + lngInjectElements), intData(lngInsertAt), lngMoveElements * MYLEN)
    End If
   
    Call CopyMemory(intData(lngInsertAt), intInjectArray(0), lngInjectElements * MYLEN)

End Sub


' Gibt true zurück wenn das Array definiert ist
Public Function IsDefined() As Boolean
    Dim lngFoo As Long
   
    On Error GoTo FehlerBehandlung
   
    lngFoo = UBound(intData)
    IsDefined = True
    Exit Function

FehlerBehandlung:
End Function


Public Function SearchBinary(ByVal intItem As Long)
    Dim i As Long, mi As Long, le As Long, ri As Long
    le = 0
    ri = lngUbound
    Do
        mi = (le + ri) \ 2
        If intItem < intData(mi) Then
            ri = mi - 1
        Else
            le = mi + 1
        End If
    Loop Until (intData(mi) = intItem) Or (le > ri)
   
    If intData(mi) = intItem Then
        SearchBinary = mi
    Else
        SearchBinary = -1
    End If
End Function


Private Function SearchBinaryPos(ByVal intItem As Long)
    Dim i As Long, mi As Long, le As Long, ri As Long
    le = 0: ri = lngUbound
    Do
        mi = (le + ri) \ 2
        If intItem <= intData(mi) Then
            If mi = 0 Then
                SearchBinaryPos = 0
            Else
                If intItem >= intData(mi - 1) Then
                    SearchBinaryPos = mi
                    Exit Function
                End If
            End If
            ri = mi - 1
        Else
            le = mi + 1
        End If
    Loop Until (intData(mi) = intItem) Or (le > ri)
   
    If ri = lngUbound Then SearchBinaryPos = lngUbound
End Function


Public Function SearchLinear(ByVal intItem As Long)
    Dim i As Long, mi As Long, le As Long, ri As Long
    SearchLinear = -1
    For i = 0 To lngUbound
        If intData(i) = intItem Then
            SearchLinear = i
            Exit Function
        End If
    Next
End Function

Public Sub Sort()
    Dim bis As Long, i As Long, j As Long, k As Long
    Dim h As Long
   
    bis = UBound(intData)
    k = bis \ 2
    While k > 0
        For i = 0 To bis - k
            j = i
            While (j >= 0) And (intData(j) > intData(j + k))
               
                h = intData(j)
                intData(j) = intData(j + k)
                intData(j + k) = h
               
                If j > k Then
                    j = j - k
                Else
                    j = 0
                End If
            Wend
        Next
        k = k \ 2
    Wend
    'Sorted = True
End Sub

Public Function Clear()
    Dim intEmpty() As Long
    ReDim intData(0)
    intData = intEmpty
    lngUbound = -1
End Function

Private Sub Class_Initialize()
    lngUbound = -1
End Sub

Private Sub Class_Terminate()
    Dim intEmpty() As Long
    ReDim intData(0)
    intData = intEmpty
End Sub

Private Sub CheckBounds(lngIndex As Long, Optional blRaiseBound As Boolean)
    On Error GoTo FehlerBehandlung
    Dim intFoo(1) As Long
    If lngIndex > lngUbound Then
        If blRaiseBound Then
            ReDim Preserve intData(lngIndex)
            lngUbound = lngIndex
        Else
            intFoo(2) = 88 ' Fehler auslösen
        End If
    ElseIf lngIndex < 0 Then
        intFoo(2) = 88 ' Fehler auslösen
    End If
    Exit Sub

FehlerBehandlung:
    Err.Raise Err.Number, "IntArray-Class", Err.Description
End Sub

0
Comment
Question by:holli
19 Comments
 
LVL 17

Expert Comment

by:inthedark
ID: 7046654
Holi, insert element into a string array is already solved here:

http://www.experts-exchange.com/visualbasic/Q_20303896.html

But if you want a simplefied syntax the first thing to agree is the syntax you would be happy with.

It shows how to acheive your aimas by using a pointer to the string array. e.g. A$(Pointer(Element)) But you could achiev a seemless interface by encapuslating your string witng a class like this:

Dim A as MagicStringArray

With syntax like this:

A.Insert "Fred", [AtElement]

A.Delete Element

' And you could loop through the array like this

For C = 0 to A.Count-1
    Msgbox A(C)
Next c

Now you should respond with you preferred syntax and we can then mode the previous example to fit your syntax.
0
 
LVL 26

Expert Comment

by:EDDYKT
ID: 7046716
Is it easier to collection for string array.
0
 
LVL 6

Author Comment

by:holli
ID: 7047023
inthedark, the code you provided in the other thread crashes if you use it in a class.

the syntax i want is exactly the same as in the LongArray-class above, same interface, same functionality, just with strings.

eddykt,
i know. it´s done that way now, but i don`t like collections.

holli
0
 
LVL 16

Expert Comment

by:Richie_Simonetti
ID: 7047746
hearing...
0
 
LVL 17

Expert Comment

by:inthedark
ID: 7048254
Okay Holli übersetze ich diese Funktion für Sie.  
0
 
LVL 17

Expert Comment

by:inthedark
ID: 7048398
Here is a sub to run a QA test on the new class

The new class will be in th next post.

Private Sub Command1_Click()

' Sub to test

Dim A As New zMagicString


' Need to test the following:

' UpperBound() As Long

MsgBox "must be -1 " + CStr(A.UpperBound)

' The function inserts a value on lngIndex
' Sub Inject(lngIndex As Long, sValue As String)
A.Inject 0, "BBBB"
MsgBox "must be BBBB and 0 " + A(0) + "  " + CStr(A.UpperBound)

' Get Value(lngIndex As Long) As String
' Let Value(lngIndex As Long, sValue As String)

A(0) = "CCCCC"
MsgBox "must be CCCCC " + A(0) + vbCrLf + A.Expose

'The function reads the value of the first element and returns it.
'The first element is cut off.
' Function Shift() As String

A.Inject A.UpperBound + 1, "AAAA"
MsgBox A.Expose
MsgBox "Must be CCCC / AAAAA  " + A.Shift + " / " + A(0)

' The function adds the value newLong to the at the beginning of the array intData
' Sub Unshift(ByVal sNewValue As String)
A.Unshift "BBBB"
MsgBox "Must be BBBB / AAAAA" + A(0) + " / " + A(1)


' The function reads the value of the last element and returns it.
' The last element is cut off.
' Function Pop() As String

MsgBox "MUST BE AAAA  " + A.Pop

' The function adds the value newstring to the end of the array
'Function Push(sNewValue As String) As Long

A.Push "WWWW"
MsgBox "MUST BE WWWW : " + A(A.UpperBound)

' Sub Clear()
A.Clear

A.Inject 0, "AAAA"
A.Inject 1, "BBBB"
A.Inject 2, "CCCC"

' The function cuts a value from an array and returns it
' Function Extract(lngIndex As Long) As String
MsgBox "MUST BE BBBB " + A.Extract(1)

MsgBox "MUST BE AAAA/CCCC and 1 " + A(0) + "/" + A(1) + "   " + CStr(A.UpperBound)

' Die Funktion setzt einen Wert an lngIndex und gibt den alten zur|ck
' Function Swap(lngIndex As Long, sValue As Long) As String

A.Swap 1, "NEWVALUE"
MsgBox "MUST BE AAAA/NEWVALUE and 1 " + A(0) + "/" + A(1) + "   " + CStr(A.UpperBound), vbInformation, "SWAP"

' Die Funktion f|gt einen Wert an lngIndex ein
' Function InjectSorted(sValue As String) As Long
A.Clear

Dim c As Long, m$
For c = 0 To 10
    m$ = CStr(Rnd)
    A.InjectSorted m$
Next c

m$ = ""
For c = 0 To 10
    m$ = m$ + A(c) + vbCrLf
Next c
MsgBox m$, vbInformation, "Inject Sorted"


Dim ea
Dim nm$

' Die Funktion kopiert den ExtractFrom und ExtractLength festgelegten Auschschnitt
' aus dem Array intData und gibt ihn zur|ck und.
' Copy the data from
' Function CopyArray(lngExtractFrom As Long, intExtractLength As Long) As String()


ea = A.CopyArray(0, A.UpperBound)
nm$ = ""
For c = 0 To UBound(ea)
    nm$ = nm$ + ea(c) + vbCrLf
Next c

If nm$ <> m$ Then
    MsgBox "Copy Array Failed"
Else
    MsgBox "Copy Array Passed"
End If

' Die Funktion schneidet den durch ExtractFrom und ExtractLength festgelegten Auschschnitt
' aus dem Array intData und gibt ihn zur|ck und.
' Function ExtractArray(lngExtractFrom As Long, intExtractLength As Long) As Long()


ea = A.ExtractArray(0, A.UpperBound)
nm$ = ""
For c = 0 To 10
    nm$ = nm$ + ea(c) + vbCrLf
Next c

If nm$ <> m$ Or A.UpperBound <> -1 Then
    MsgBox "Extract Array Failed" + nm$ + vbCrLf + vbCrLf + nm$
Else
    MsgBox "Extract Array Passed"
End If


' Die Funktion f|gt das Array Injectarray an der Stelle insertAt ein
' Sub InsertArray(lngInsertAt As Long, sInjectArray() As String)

A.Clear

A.Inject 0, "AAAA"
A.Inject 1, "DDDD"

ReDim ea(1)

ea(0) = "BBBB"
ea(1) = "CCCC"

A.InsertArray 1, ea

If A(0) <> "AAAA" Or A(1) <> "BBBB" Or A(2) <> "CCCC" Or A(3) <> "DDDD" Then
    MsgBox "Insert array faild"
Else
    MsgBox "Insert array passed"
End If


' Gibt true zur|ck wenn das Array definiert ist
' Function IsDefined() As Boolean

MsgBox "msut be true: " + CStr(A.IsDefined)

' RETURNS THE POSITION OF A Key
' if the key is not found the result is -1
' Function SearchBinary(sItem As String) As Long

MsgBox "Must be 2 : " + CStr(A.SearchBinary("CCCC"))
MsgBox "Must be -1 : " + CStr(A.SearchBinary("MISSINGKEY"))

' Function SearchLinear(sItem As String) As Long

' Sub Sort()

m$ = ""
For c = 0 To 10
    m$ = CStr(Rnd)
    A.Inject c, m$
Next c

A.Sort

m$ = ""
For c = 0 To 10
    m$ = m$ + A(c) + vbCrLf
Next c

MsgBox m$, vbInformation, "Inject Sorted"


End Sub


0
 
LVL 17

Expert Comment

by:inthedark
ID: 7048401
Paste the following code into a text file then rename the file as zMagicString.CLS

Add the class to your project and run the QA SUB previously posted.

Best of luck.


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


Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As Long)

Dim intPointer() As Long
Dim sData() As String
Dim lngUbound As Long
Dim lngUbound_sData As Long
Dim lngReleasedElements() As Long
Dim lngReleasedItems As Long
Private Const MYLEN = 4

Public Function Expose() As String

Dim m$
Dim lngCounter As Long
If lngUbound < 0 Then
    Expose = "Empty"
Else
    m$ = ""
    For lngCounter = 0 To lngUbound
        m$ = m$ + CStr(lngCounter) + ": " + Value(lngCounter) + vbCrLf
    Next
    Expose = m$
End If

End Function


Private Function GetNextPointer() As Long

' returns the next pointer to be used in sdata

' have any items been released that we should use next
If lngReleasedItems >= 0 Then
    GetNextPointer = lngReleasedElements(lngReleasedItems)
    lngReleasedItems = lngReleasedItems - 1
    If lngReleasedItems < 0 Then
        Erase lngReleasedElements
    Else
        ReDim Preserve lngReleasedElements(lngReleasedItems)
    End If
Else
    ' no released items so we need add oneto the end of sData
    lngUbound_sData = lngUbound_sData + 1
    If lngUbound_sData < 1 Then
        ReDim sData(lngUbound_sData)
    Else
        ReDim Preserve sData(lngUbound_sData)
    End If
    GetNextPointer = lngUbound_sData
End If

End Function

'Die Eigenschaft gibt den oberen Rand des Arrays zur|ck
Public Property Get UpperBound() As Long
   UpperBound = lngUbound
End Property

'Die Eigenschaft gibt den Array-Wert an lngIndex zur|ck
Public Property Get Value(lngIndex As Long) As String
Attribute Value.VB_UserMemId = 0
Attribute Value.VB_MemberFlags = "200"
   CheckBounds lngIndex, True
   Value = sData(intPointer(lngIndex))
End Property
'
'Die Eigenschaft setzt den Array-Wert an lngIndex
'The default property sets the array value on lngIndex
Public Property Let Value(lngIndex As Long, sValue As String)
   
   ' Store current size
   Dim lngCurrentSize As Long
   
   lngCurrentSize = lngUbound
   CheckBounds lngIndex, True
   If lngCurrentSize <> lngUbound Then
         intPointer(lngIndex) = GetNextPointer()
   End If
   sData(intPointer(lngIndex)) = sValue
End Property



' Die Funktion liest den Wert des ersten Elements und gibt ihn zur|ck.
' Das erste Element wird abgeschnitten.
'The function reads the value of the first element and returns it.
'The first element is cut off.
Public Function Shift() As String
   If lngUbound < 0 Then
       Err.Raise 9, "IntArray-Class", "No more Elements for Shift"
   Else
        Shift = Extract(0)
   End If
   
End Function

' Die Funktion f|gt den Wert newLong an den Anfang des Arrays intData
' The function adds the value newLong to the at the beginning of the array intData
Public Sub Unshift(sNewValue As String)
   Inject 0, sNewValue
End Sub

' Die Funktion liest den Wert des letzten Elements und gibt ihn zur|ck.
' Das letzte Element wird abgeschnitten.
' The function reads the value of the last element and returns it.
' The last element is cut off.
Public Function Pop() As String

    If lngUbound >= 0 Then
        Pop = Extract(lngUbound)
    Else
        Err.Raise 9, "IntArray-Class", "No more Elements for Pop"
    End If
End Function

' Die Funktion f|gt den Wert newLong an das Ende des Arrays intData
' The function adds the value newstring to the end of the array
Public Function Push(sNewValue As String) As Long
   Push = lngUbound + 1
   Inject Push, sNewValue
End Function

' Die Funktion schneidet einen Wert aus einem Array und gibt ihn zur|ck
' The function cuts a value from an array and returns it
Public Function Extract(lngIndex As Long) As String
   Dim intEmpty() As Long
   CheckBounds lngIndex
   
   Extract = sData(intPointer(lngIndex))
   
   Dim lngReleasedElement As Long
   lngReleasedElement = intPointer(lngIndex)
   
   If lngIndex <> lngUbound Then
        Call CopyMemory(intPointer(lngIndex), intPointer(lngIndex + 1), (lngUbound - lngIndex) * MYLEN)
   End If
   
    ' if this is the last one in clear the array
   
   If lngUbound = 0 Then
        Clear
   Else
        ' or saved the unused pointer
        lngReleasedItems = lngReleasedItems + 1
        If lngReleasedItems > 0 Then
             ReDim Preserve lngReleasedElements(lngReleasedItems)
        Else
             ReDim lngReleasedElements(lngReleasedItems)
        End If
         
        lngReleasedElements(lngReleasedItems) = lngReleasedElement
        lngUbound = lngUbound - 1
        ReDim Preserve intPointer(lngUbound)
    End If
End Function

' Die Funktion setzt einen Wert an lngIndex und gibt den alten zur|ck
Public Function Swap(lngIndex As Long, sValue As String) As String
   CheckBounds lngIndex, True
   Swap = sData(intPointer(lngIndex))
   sData(intPointer(lngIndex)) = sValue
End Function


' Die Funktion f|gt einen Wert an lngIndex ein
' The function inserts a value on lngIndex
Public Sub Inject(lngIndex As Long, sValue As String)
   
   CheckBounds lngUbound + 1, True
   
   If lngIndex <> lngUbound Then
       CopyMemory intPointer(lngIndex + 1), intPointer(lngIndex), (lngUbound - lngIndex) * MYLEN
   End If
   intPointer(lngIndex) = GetNextPointer()
   sData(intPointer(lngIndex)) = sValue
   
End Sub


' Die Funktion f|gt einen Wert an lngIndex ein
Public Function InjectSorted(sValue As String) As Long
   Dim lngIndex As Long
   
   ' the is a potential bug here need to check that
   
   
   ' can searchbinarypos cope with and empty element?
   lngIndex = SearchBinaryPos(sValue)

   ' I think this should be done after search
   CheckBounds lngUbound + 1, True
   
    If lngIndex <> lngUbound Then
        CopyMemory intPointer(lngIndex + 1), intPointer(lngIndex), (lngUbound - lngIndex) * MYLEN
    End If
   
    intPointer(lngIndex) = GetNextPointer()
    sData(intPointer(lngIndex)) = sValue
    InjectSorted = lngIndex

End Function


' Die Funktion schneidet den durch ExtractFrom und ExtractLength festgelegten Auschschnitt
' aus dem Array intData und gibt ihn zur|ck und.
Public Function ExtractArray(lngExtractFrom As Long, intExtractLength As Long)
    ExtractArray = CopyArray(lngExtractFrom, intExtractLength)
    Clear
End Function

' Die Funktion kopiert den ExtractFrom und ExtractLength festgelegten Auschschnitt
' aus dem Array intData und gibt ihn zur|ck und.
' Copy the data from
Public Function CopyArray(lngExtractFrom As Long, intExtractLength As Long)
    Dim vCopyArray
   
    vCopyArray = Split(Space$(intExtractLength), Space$(1))
   
   
   
    Dim lngIndex As Long
    Dim lngNumberToDo As Long
    Dim lngPos As Long
   
    lngIndex = lngExtractFrom
    lngNumberToDo = intExtractLength
    lngPos = 0
    Do While lngNumberToDo >= 0
        vCopyArray(lngPos) = sData(intPointer(lngPos + lngExtractFrom))
        lngNumberToDo = lngNumberToDo - 1
        lngPos = lngPos + 1
    Loop
    CopyArray = vCopyArray
End Function

' Die Funktion f|gt das Array Injectarray an der Stelle insertAt ein
Public Sub InsertArray(lngInsertAt As Long, sInjectArray As Variant)
   Dim lngLastUbound As Long, lngMoveElements As Long, lngInjectElements As Long
   Dim lngCurrent As Long, lngCounter As Long
   lngLastUbound = lngUbound
   lngInjectElements = UBound(sInjectArray) + 1
   lngMoveElements = lngLastUbound - lngInsertAt + 1
   
   CheckBounds lngLastUbound + lngInjectElements, True
   
   ' create space in the pointer stack
   
   If lngMoveElements > 0 Then
       Call CopyMemory(intPointer(lngInsertAt + lngInjectElements), intPointer(lngInsertAt), lngMoveElements * MYLEN)
   End If
   lngCurrent = lngInsertAt
   lngCounter = 0
   Do
        intPointer(lngCurrent) = GetNextPointer()
        sData(intPointer(lngCurrent)) = sInjectArray(lngCounter)
        lngCurrent = lngCurrent + 1
        lngCounter = lngCounter + 1
        If lngCounter > UBound(sInjectArray) Then Exit Do
   Loop
   
   
End Sub


' Gibt true zur|ck wenn das Array definiert ist
Public Function IsDefined() As Boolean
    If lngUbound >= 0 Then
        IsDefined = True
    Else
        IsDefined = False
    End If
End Function


' RETURNS THE POSITION OF A Key
' if the key is not found the result is -1
Public Function SearchBinary(sItem As String) As Long
   Dim midpoint As Long, lowest As Long, highest As Long
   
    ' ARE THERE ANY RECORDS?
    If lngUbound < 0 Then
        SearchBinary = -1
        Exit Function
    End If
   
   lowest = 0
   highest = lngUbound
   Do
       midpoint = (lowest + highest) \ 2
       If sItem < sData(intPointer(midpoint)) Then
           highest = midpoint - 1
       Else
           lowest = midpoint + 1
       End If
   Loop Until (sData(intPointer(midpoint)) = sItem) Or (lowest > highest)
   
   If sData(intPointer(midpoint)) = sItem Then
       SearchBinary = midpoint
   Else
       SearchBinary = -1
   End If
End Function


Private Function SearchBinaryPos(sItem As String) As Long


   Dim mi As Long, le As Long, ri As Long
   
     ' ARE THERE ANY RECORDS?
    If lngUbound < 0 Then
        SearchBinaryPos = lngUbound + 1
        Exit Function
    End If
   
    ' ALLOW QUICK INSERT AFTER END
    If sItem > sData(intPointer(lngUbound)) Then
        SearchBinaryPos = lngUbound + 1
        Exit Function
    End If
   
   le = 0: ri = lngUbound
   Do
       mi = (le + ri) \ 2
       If sItem <= sData(intPointer(mi)) Then
           If mi = 0 Then
               SearchBinaryPos = 0
           Else
               If sItem >= sData(intPointer(mi - 1)) Then
                   SearchBinaryPos = mi
                   Exit Function
               End If
           End If
           ri = mi - 1
       Else
           le = mi + 1
       End If
   Loop Until (sData(intPointer(mi)) = sItem) Or (le > ri)
   
   If ri = lngUbound Then SearchBinaryPos = lngUbound + 1
End Function


Public Function SearchLinear(sItem As String) As Long
   Dim i As Long, mi As Long, le As Long, ri As Long
   SearchLinear = -1
   If lngUbound < 0 Then
        Exit Function
   End If

   For i = 0 To lngUbound
       If sData(intPointer(i)) = sItem Then
           SearchLinear = i
           Exit Function
       End If
   Next
   
End Function

Public Sub Sort()
   Dim i As Long, j As Long, k As Long
   Dim h As Long
   
   If lngUbound < 0 Then Exit Sub
   
   k = lngUbound \ 2
   While k > 0
       For i = 0 To lngUbound - k
           j = i
           While (j >= 0) And (sData(intPointer(j)) > sData(intPointer(j + k)))
               
               h = intPointer(j)
               intPointer(j) = intPointer(j + k)
               intPointer(j + k) = h
               
               If j > k Then
                   j = j - k
               Else
                   j = 0
               End If
           Wend
       Next
       k = k \ 2
   Wend
   'Sorted = True
End Sub

Public Sub Clear()
   lngUbound = -1
   lngUbound_sData = -1
   lngReleasedItems = -1

   Erase intPointer
   Erase sData
   Erase lngReleasedElements
End Sub

Private Sub Class_Initialize()
   lngUbound = -1
   lngUbound_sData = -1
   lngReleasedItems = -1
End Sub

Private Sub Class_Terminate()
   
   'Dim intEmpty() As Long
   'ReDim intPointer(0)
   'intData = intEmpty
   Erase intPointer
   Erase sData
   
End Sub

Private Sub CheckBounds(lngIndex As Long, Optional blRaiseBound As Boolean)
   On Error GoTo FehlerBehandlung 'Error Handling
   Dim intFoo(1) As Long
   If lngIndex > lngUbound Then
       If blRaiseBound Then
           ReDim Preserve intPointer(lngIndex)
           'ReDim Preserve sData(lngIndex)
           lngUbound = lngIndex
       Else
           intFoo(2) = 88 ' Fehler auslvsen (force errors release)
       End If
   ElseIf lngIndex < 0 Then
       intFoo(2) = 88 ' Fehler auslvsen (force errors release)
   End If
   Exit Sub

FehlerBehandlung:
   Err.Raise Err.Number, "IntArray-Class", Err.Description
End Sub

0
 
LVL 17

Expert Comment

by:inthedark
ID: 7049177
holli the problem with your class is that it may not work with future versions of VB becuase they may store longs differently. Also the memory move function could be lots faster by using a c++ or Assembler function.
0
 
LVL 6

Author Comment

by:holli
ID: 7052013
please hold on. i`m busy at work. i will check the code tomorrow.

holli
0
Threat Intelligence Starter Resources

Integrating threat intelligence can be challenging, and not all companies are ready. These resources can help you build awareness and prepare for defense.

 
LVL 17

Expert Comment

by:inthedark
ID: 7052946
Improvement to the extract function, see *** below:

Public Function Extract(lngIndex As Long) As String
  Dim intEmpty() As Long
  CheckBounds lngIndex
 
  Extract = sData(intPointer(lngIndex))
  sData(intPointer(lngIndex)) = "" ' *** Add this line

  Dim lngReleasedElement As Long
0
 
LVL 17

Accepted Solution

by:
inthedark earned 500 total points
ID: 7061260
How did it go?
0
 
LVL 6

Author Comment

by:holli
ID: 7073403
0
 
LVL 17

Expert Comment

by:inthedark
ID: 7074937
If you need extra speed it would be possible to rewrite this so that it work work about 1000% faster.  But it cost loads of hours - about $20,000 as the string and array handling would have to be written in assembler. But I could improve big-time on the Microsoft API functions.
0
 
LVL 17

Expert Comment

by:inthedark
ID: 7074938
Thanks for the points.....
0
 
LVL 17

Expert Comment

by:inthedark
ID: 7259678
holli, I tested this class and found that it could sort 10000 strings in just 0.5 seconds. Its very fast.....

Did you find any bugs?
0
 
LVL 6

Author Comment

by:holli
ID: 7260784
not yet.
0
 
LVL 6

Author Comment

by:holli
ID: 7260785
but what i would really like to have...
would be the ability to for...each-over the array.
0
 
LVL 17

Expert Comment

by:inthedark
ID: 7260798
For each works real slow beacuse you need an object for each element. But I will think about a method of fooling VB without actually creating the objects. p.s. creating or destroying 1000's of objects will brings windows to a stop.
0
 
LVL 6

Author Comment

by:holli
ID: 7262002
not necessarily an object, actually you can iterate arrays with variants but therefore you would have to expose it :-(
0

Featured Post

What Is Threat Intelligence?

Threat intelligence is often discussed, but rarely understood. Starting with a precise definition, along with clear business goals, is essential.

Join & Write a Comment

Introduction In a recent article (http://www.experts-exchange.com/A_7811-A-Better-Concatenate-Function.html) for the Excel community, I showed an improved version of the Excel Concatenate() function.  While writing that article I realized that no o…
Article by: Martin
Here are a few simple, working, games that you can use as-is or as the basis for your own games. Tic-Tac-Toe This is one of the simplest of all games.   The game allows for a choice of who goes first and keeps track of the number of wins for…
Get people started with the process of using Access VBA to control Excel using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Excel. Using automation, an Access application can laun…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

744 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

13 Experts available now in Live!

Get 1:1 Help Now