VB 5/6-Tipp 0474: Beliebiges Array in eine Datei speichern und einlesen

von Benjamin Wilger

Beschreibung

Wer jetzt einen ellenlangen Code, mit vielen Schleifen, erwartet hat, kennt wohl die wunderbaren Fähigkeiten der Befehle Put und Get nicht. Denn damit ist es wirklich sehr einfach möglich, jeden Array, egal welcher Datentyp(Ausnahme: UDTs) und egal wie viele Dimensionen, zu speichern und natürlich auch einzulesen! Wer aber beim Einlesen die exakte Dimensionierung des Ursprungsarrays nicht kennt, muss etwas tricksen. Dieser Code benötigt beim Speichern nur die Angabe der Anzahl der Dimensionen. Die Arraygrößen werden in die Datendatei gespeichert. Beim Einlesen ist es nicht nötig irgendwelche Angaben zum Array zu geben. Das Array wird automatisch dimensioniert(max. 10 Dimensionen).
Dieses Beispiel speichert nur String-Arrays. Aber es ist sehr einfach, die bestehende Funktion umzuschreiben(quasi nur den Datentyp ändern).

Schwierigkeitsgrad:

Schwierigkeitsgrad 2

Verwendete API-Aufrufe:

RtlMoveMemory

Download:

Download des Beispielprojektes [4,34 KB]

'Dieser Quellcode 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: Textfeld "txtInfo"
' Steuerelement: Listen-Steuerelement "List2"
' Steuerelement: Listen-Steuerelement "List1"
' Steuerelement: Schaltfläche "Command2"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Beschriftungsfeld "Label1"
'Code von Benjamin Wilger
'Benjamin@ActiveVB.de
'Copyright (C) 2002
Option Explicit

Private Sub Command1_Click()
    Dim myArray(-5 To 50, 10000 To 10050, 50 To 53) As String

    Dim i1 As Long, i2 As Long, i3 As Long
    
    txtInfo.Text = "Array und Liste werden mit gefüllt..."
    DoEvents
    
    'Liste ausleeren
    List1.Clear
    
    '"Zufallsgenerator" initialisieren
    Randomize Timer
    
    'Das Array mit zufälligen Werten füllen
    For i1 = LBound(myArray, 1) To UBound(myArray, 1)
        For i2 = LBound(myArray, 2) To UBound(myArray, 2)
            For i3 = LBound(myArray, 3) To UBound(myArray, 3)
                myArray(i1, i2, i3) = Int(Rnd * 1000)
                List1.AddItem myArray(i1, i2, i3) & ", (" & i1 & ", " & i2 & ", " & i3 & ")"
            Next i3
        Next i2
    Next i1
    
    txtInfo.Text = "Das Array wird gespeichert"
    DoEvents
    'Werte schreiben
    SaveStringArray App.Path & "\Test.dat", myArray
    
    txtInfo.Text = "Bereit..."
End Sub

Private Sub Command2_Click()
    Dim myArray() As String
    Dim i1 As Long, i2 As Long, i3 As Long, i As Long
    
    'Zweite Liste leeren
    List2.Clear
    
    txtInfo.Text = "Das Array wird gelesen"
    DoEvents
    
    'Einlesen lassen
    ReadStringArray App.Path & "\Test.dat", myArray
    
    txtInfo.Text = "Liste wird mit Arraydaten gefüllt..."
    DoEvents
    
    'Per Schleife alle Array-Elemente durchgehen und diese in die Liste schreiben
    For i1 = LBound(myArray, 1) To UBound(myArray, 1)
        For i2 = LBound(myArray, 2) To UBound(myArray, 2)
            For i3 = LBound(myArray, 3) To UBound(myArray, 3)
                List2.AddItem myArray(i1, i2, i3) & ", (" & i1 & ", " & i2 & ", " & i3 & ")"
            Next i3
        Next i2
    Next i1

    txtInfo.Text = "Bereit..."
End Sub

Private Sub List1_Click()
    On Error Resume Next
    List2.ListIndex = List1.ListIndex
End Sub

Private Sub List2_Click()
    On Error Resume Next
    List1.ListIndex = List2.ListIndex

End Sub

Private Sub Text1_Change()

End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'------- Anfang Modul "SaveArray" alias SaveArray.bas -------
'Code von Benjamin Wilger
'Benjamin@ActiveVB.de
'Copyright (C) 2001-2002
Option Explicit

Private Declare Sub RtlMoveMemory Lib "kernel32" (dest As Any, source As Any, ByVal bytes As Long)

Public Sub ReadStringArray(ByVal Filename As String, StringArray() As String)
    Dim FNum As Integer
    Dim LBounds() As Long, DimCount As Integer
    Dim UBounds() As Long
    
    'Freie Dateinummer herausfinden
    FNum = FreeFile
    'Datei mit binärem Zugriff öffnen
    Open Filename For Binary As FNum
    'Anzahl der Dimensionen auslesen
    Get FNum, , DimCount
    'Array für die LBounds-Daten
    ReDim LBounds(0 To DimCount - 1)
    'Array für die UBounds-Daten
    ReDim UBounds(0 To DimCount - 1)
    '... einlesen
    Get FNum, , LBounds 'Erst die LBounds und dann die UBounds
    Get FNum, , UBounds
    'nun das Zielarray den Informationen entsprechend dimensionieren
    Select Case DimCount
        Case 1
            ReDim StringArray(LBounds(0) To UBounds(0))
        Case 2
            ReDim StringArray(LBounds(0) To UBounds(0), _
                    LBounds(1) To UBounds(1))
        Case 3
            ReDim StringArray(LBounds(0) To UBounds(0), _
                    LBounds(1) To UBounds(1), _
                    LBounds(2) To UBounds(2))
        Case 4
            ReDim StringArray(LBounds(0) To UBounds(0), _
                    LBounds(1) To UBounds(1), _
                    LBounds(2) To UBounds(2), _
                    LBounds(3) To UBounds(3))
        Case 5
            ReDim StringArray(LBounds(0) To UBounds(0), _
                    LBounds(1) To UBounds(1), _
                    LBounds(2) To UBounds(2), _
                    LBounds(3) To UBounds(3), _
                    LBounds(4) To UBounds(4))
        Case 6
            ReDim StringArray(LBounds(0) To UBounds(0), _
                    LBounds(1) To UBounds(1), _
                    LBounds(2) To UBounds(2), _
                    LBounds(3) To UBounds(3), _
                    LBounds(4) To UBounds(4), _
                    LBounds(5) To UBounds(5))
        Case 7
            ReDim StringArray(LBounds(0) To UBounds(0), _
                    LBounds(1) To UBounds(1), _
                    LBounds(2) To UBounds(2), _
                    LBounds(3) To UBounds(3), _
                    LBounds(4) To UBounds(4), _
                    LBounds(5) To UBounds(5), _
                    LBounds(6) To UBounds(6))
        Case 8
            ReDim StringArray(LBounds(0) To UBounds(0), _
                    LBounds(1) To UBounds(1), _
                    LBounds(2) To UBounds(2), _
                    LBounds(3) To UBounds(3), _
                    LBounds(4) To UBounds(4), _
                    LBounds(5) To UBounds(5), _
                    LBounds(6) To UBounds(6), _
                    LBounds(7) To UBounds(7))
        Case 9
            ReDim StringArray(LBounds(0) To UBounds(0), _
                    LBounds(1) To UBounds(1), _
                    LBounds(2) To UBounds(2), _
                    LBounds(3) To UBounds(3), _
                    LBounds(4) To UBounds(4), _
                    LBounds(5) To UBounds(5), _
                    LBounds(6) To UBounds(6), _
                    LBounds(7) To UBounds(7), _
                    LBounds(8) To UBounds(8))
        Case 10
            ReDim StringArray(LBounds(0) To UBounds(0), _
                    LBounds(1) To UBounds(1), _
                    LBounds(2) To UBounds(2), _
                    LBounds(3) To UBounds(3), _
                    LBounds(4) To UBounds(4), _
                    LBounds(5) To UBounds(5), _
                    LBounds(6) To UBounds(6), _
                    LBounds(7) To UBounds(7), _
                    LBounds(8) To UBounds(8), _
                    LBounds(9) To UBounds(9))
        Case Else
            Err.Raise vbObjectError + 100, , "Zu viele Dimensionen!"
    End Select
    'das Array einlesen lassen.
    Get FNum, , StringArray
    'Datei schließen
    Close FNum
    
End Sub

Public Sub SaveStringArray(ByVal Filename As String, StringArray() As String)
    Dim FNum As Integer
    Dim Dimensions As Long
    
    Dimensions = Dimension(StringArray)
    
    If Dimensions > 10 Then
        Err.Raise vbObjectError + 100, , "Zu viele Dimensionen!"
    End If
    'Freie Dateinummer herausfinden
    FNum = FreeFile
    'Falls bereits vorhanden, die Datei löschen, da sonst ältere Werte
    'vielleicht bestehen bleiben
    If Dir(Filename) <> "" Then Kill Filename
    'Datei zum binären Zugriff öffnen, ggf. erstellen
    Open Filename For Binary As FNum
    Put FNum, , CInt(Dimensions) 'Anzahl der Dimensionen schreiben
    
    Put FNum, , CLng(LBound(StringArray, 1)) 'Untergrenzen speichern
    If Dimensions >= 2 Then Put FNum, , CLng(LBound(StringArray, 2))
    If Dimensions >= 3 Then Put FNum, , CLng(LBound(StringArray, 3))
    If Dimensions >= 4 Then Put FNum, , CLng(LBound(StringArray, 4))
    If Dimensions >= 5 Then Put FNum, , CLng(LBound(StringArray, 5))
    If Dimensions >= 6 Then Put FNum, , CLng(LBound(StringArray, 6))
    If Dimensions >= 7 Then Put FNum, , CLng(LBound(StringArray, 7))
    If Dimensions >= 8 Then Put FNum, , CLng(LBound(StringArray, 8))
    If Dimensions >= 9 Then Put FNum, , CLng(LBound(StringArray, 9))
    If Dimensions = 10 Then Put FNum, , CLng(LBound(StringArray, 10))
    
    Put FNum, , CLng(UBound(StringArray, 1)) 'Obergrenzen speichern
    If Dimensions >= 2 Then Put FNum, , CLng(UBound(StringArray, 2))
    If Dimensions >= 3 Then Put FNum, , CLng(UBound(StringArray, 3))
    If Dimensions >= 4 Then Put FNum, , CLng(UBound(StringArray, 4))
    If Dimensions >= 5 Then Put FNum, , CLng(UBound(StringArray, 5))
    If Dimensions >= 6 Then Put FNum, , CLng(UBound(StringArray, 6))
    If Dimensions >= 7 Then Put FNum, , CLng(UBound(StringArray, 7))
    If Dimensions >= 8 Then Put FNum, , CLng(UBound(StringArray, 8))
    If Dimensions >= 9 Then Put FNum, , CLng(UBound(StringArray, 9))
    If Dimensions = 10 Then Put FNum, , CLng(UBound(StringArray, 10))
    'Den kompletten Array speichern
    Put FNum, , StringArray
    'Datei wieder schließen
    Close FNum
    
End Sub

'Normale String, Integer/Long, Byte und Double/Single Arrays können
'in Variant konvertiert werden, sodass wir mit dieser Methode
'die Dimensionen herausfinden können.
'Vielen Dank an Jost Schwider(www.vb-tec.de) für diesen Code!
' -> http://vb-tec.de/arrdim.htm
Private Function Dimension(ByRef avarArray As Variant) As Integer
    Dim Ptr As Long
    
    If IsArray(avarArray) Then
        Ptr = VarPtr(avarArray) + 8     'VB-Array
        RtlMoveMemory Ptr, ByVal Ptr, 4 'SafeArrayDescriptor
        RtlMoveMemory Ptr, ByVal Ptr, 4 'SafeArray-Struktur
        If Ptr Then RtlMoveMemory Dimension, ByVal Ptr, 2
    Else
        Err.Raise 13 'Type mismatch
    End If
End Function

'Falls Du den Code abwandelst, das das Zielarray nicht mehr
'in ein Variant konvertiert werden kann(beispielsweise bei UDTs),
'benutze diese Funktion. Sie ermittelt die Dimensionen mit der Brechstangen-
'Methode :-)
Private Function DimensionBrechstange(ByRef avarArray As Variant) As Long
    Dim i As Long
    Dim tmpBound As Integer
    
    On Error Resume Next
    Do
        i = i + 1
        tmpBound = UBound(avarArray, i)
    Loop Until Err
    Err.Clear
    
    DimensionBrechstange = i - 1
End Function


'-------- Ende Modul "SaveArray" alias SaveArray.bas --------
'-------------- Ende Projektdatei Projekt1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6

Ihre Meinung

Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.

Fehler in der Prozedur ReadStringArray - KBSM 21.10.12 22:26 8 Antworten

Archivierte Nutzerkommentare

Klicken Sie diesen Text an, wenn Sie die 2 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.

Kommentar von Roman Kooster am 06.01.2004 um 10:28

Hallo!

Bei mir erkennt VB die Befehle SaveStringArray oder ReadStringArray nicht. Ich benutzt VB6 und Windows ME und bin leider noch Anfänger.

Woran kann das liegen?

Vielen Dank

Roman

Kommentar von Alex am 06.07.2002 um 23:35

Hi Benjamin!
Kennst Du auch eine Methode (API-Funktion), um eine Gruppe von Zeichen aus einer Datei im Binary-Mode zu LÖSCHEN?