Tipp-Upload: VB 5/6 0075: Stringarrays aneinander hängen

Über den Tipp  

Dieser Tippvorschlag ist noch unbewertet.

Der Vorschlag ist in den folgenden Kategorien zu finden:

• Sonstiges

Dem Tippvorschlag wurden folgende Schlüsselwörter zugeordnet:
Stringarray, verschieben, CopyMemory

Der Vorschlag wurde erstellt am: 07.08.2007 12:50.
Die letzte Aktualisierung erfolgte am 07.12.2018 12:11.

Zurück zur Übersicht

Beschreibung  

In einigen Fällen müssen zwei Stringarrays aneinander gehängt werden. Das geht in der Regel nur durch aufwendiges Durchlaufen in einer For-/Next-Schleife.
Dank der CopyMemory-API geht es jedoch gerade bei großen Datenmengen schneller.
ACHTUNG: Die Methode eignet sich nur zum Verschieben, NICHT zum Kopieren.

Schwierigkeitsgrad

Verwendete API-Aufrufe: GetMem4 (GetSafeArrayPointer), RtlMoveMemory, RtlZeroMemory

Download: Download des Beispielprojektes [2,02 KB]

' Dieser Source stammt von http://www.activevb.de
' und kann frei verwendet werden. Für eventuelle Schäden
' wird nicht gehaftet.

' Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
' Ansonsten viel Spaß und Erfolg mit diesem Source!

' ------------- Anfang Projektdatei Projekt1.vbp -------------

' --------- Anfang Formular "Form1" alias Form1.frm  ---------

' Steuerelement: Schaltfläche "Command2"
' Steuerelement: Rahmensteuerelement "Frame2"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Rahmensteuerelement "Frame1"
' Steuerelement: Listen-Steuerelement "List2" auf Frame2
' Steuerelement: Listen-Steuerelement "List1" auf Frame1

' ************************************************
' * Beispielprojekt zum Tipp-Vorschlag           *
' * "String-Arrays aneinander hängen"            *
' *                                              *
' * (C) 2004 by Claus von der Burchard           *
' *             und Kai Liebenau                 *
' * email: claus@cvdb.de                         *
' *                                              *
' ************************************************

Option Explicit

Private Declare Sub RtlMoveMemory Lib "kernel32.dll" ( _
                    ByVal Destination As Any, _
                    ByVal Source As Any, _
                    ByVal Length As Long)

Private Declare Sub RtlZeroMemory Lib "kernel32.dll" ( _
                    ByVal Destination As Any, _
                    ByVal Length As Long)

Private Declare Sub GetSafeArrayPointer Lib "msvbvm60.dll" _
                    Alias "GetMem4" ( _
                    ByRef pArray() As Any, _
                    ByRef sfaPtr As Long)

Private a()     As String
Private b()     As String

Private Sub Form_Load()

    Dim I1      As Long

    ReDim a(10)
    ReDim b(10)

    For I1 = 0 To 10
        a(I1) = CStr(I1)
        b(I1) = "B" & CStr(I1)
    Next

    Call ShowArrays

End Sub

Private Sub Command1_Click()

    Call AddArray(a, b)
    Call ShowArrays

End Sub

Private Sub Command2_Click()

    Call Form_Load

End Sub

Private Sub ShowArrays()

    Dim I1  As Long

    List1.Clear
    List2.Clear

    For I1 = SafeLBound(a, 0) To SafeUBound(a)
        List1.AddItem a(I1)
    Next

    For I1 = SafeLBound(b, 0) To SafeUBound(b)
        List2.AddItem b(I1)
    Next

End Sub

Private Sub AddArray( _
  ByRef BaseArray() As String, _
  ByRef AddArray() As String _
)

    Dim UBndBase    As Long
    Dim UBndAdd     As Long
    Dim LBndBase    As Long
    Dim LBndAdd     As Long

    If Not IsDimArray(AddArray()) Then Exit Sub

    UBndBase = SafeUBound(BaseArray) + 1
    UBndAdd = SafeUBound(AddArray) + 1
    LBndBase = SafeLBound(BaseArray, 0)
    LBndAdd = SafeLBound(AddArray, 0)

    ReDim Preserve BaseArray(LBndBase To UBndBase + UBndAdd - LBndAdd - 1)

    Call RtlMoveMemory(VarPtr(BaseArray(UBndBase)), VarPtr(AddArray(LBndAdd)), (UBndAdd - _
        LBndAdd) * 4)

    Call RtlZeroMemory(VarPtr(AddArray(LBndAdd)), (UBndAdd - LBndAdd) * 4)

    Erase AddArray()

End Sub

Private Function IsDimArray(Inp() As String) As Boolean

    Dim sfaPtr  As Long

    Call GetSafeArrayPointer(Inp(), sfaPtr)

    IsDimArray = CBool(sfaPtr)

End Function

Private Function SafeUBound(Inp() As String, Optional NotDimValue As Long = -1)

    Dim sfaPtr  As Long

    Call GetSafeArrayPointer(Inp(), sfaPtr)

    If sfaPtr = 0 Then SafeUBound = NotDimValue Else SafeUBound = UBound(Inp)

End Function

Private Function SafeLBound(Inp() As String, Optional NotDimValue As Long = -1)

    Dim sfaPtr  As Long

    Call GetSafeArrayPointer(Inp(), sfaPtr)

    If sfaPtr = 0 Then SafeLBound = NotDimValue Else SafeLBound = LBound(Inp)

End Function

' ---------- Ende Formular "Form1" alias Form1.frm  ----------

' -------------- Ende Projektdatei Projekt1.vbp --------------

	

Diskussion  

Diese Funktion ermöglicht es, Fragen, die die Veröffentlichung des Tipps betreffen, zu klären, oder Anregungen und Verbesserungsvorschläge einzubringen. Nach der Veröffentlichung des Tipps werden diese Beiträge nicht weiter verlinkt. Allgemeine Fragen zum Inhalt sollten daher hier nicht geklärt werden.

Um eine Diskussion eröffnen zu können, müssen sie angemeldet sein.