500 points! need help badly - hardcore vb

Holi, insert element into a string array is already solved here:

https://www.experts-exchange.com/questions/20303896/String-Arrays-and-CopyMemory.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.

Is it easier to collection for string array.

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

hearing...

Okay Holli übersetze ich diese Funktion für Sie.  

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

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

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.

please hold on. i`m busy at work. i will check the code tomorrow.

holli

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

nice job. thanks.

you might also have a look at https://www.experts-exchange.com/jsp/qManageQuestion.jsp?ta=visualbasic&qid=20268936

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.

Thanks for the points.....

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?

not yet.

but what i would really like to have...
would be the ability to for...each-over the array.

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.

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