Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0738: Arrays referenzieren

VB 5/6-Tipp 0738: Arrays referenzieren

 von Oliver Meyer

Schwierigkeitsgrad:

Verwendete API-Aufrufe: VarPtr (ArrPtr), RtlMoveMemory, RtlZeroMemory

Download: Download des Beispielprojektes [3,39 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: Schaltfläche "Command4"
' Steuerelement: Schaltfläche "Command3"
' Steuerelement: Schaltfläche "Command2"
' Steuerelement: Schaltfläche "Command1"
Option Explicit
Private Type TAnyType
  XVar As Long
  YVar As Single
  ZVar As Double
  SVar As String
End Type

Private Sub Command1_Click()
    Call TestLongArray
End Sub

Private Sub Command2_Click()
    Call TestStringArray
End Sub

Private Sub Command3_Click()
    Call TestUDTypeArray
End Sub

Private Sub Command4_Click()
    Call TestObjectArray
End Sub

Private Sub TestLongArray()
    Dim lngArr1() As Long
    Dim lngArr2() As Long
    ReDim lngArr1(0 To 1)
    lngArr1(0) = 123456
    lngArr1(1) = 456789
    
    'der Zeiger wird von lngArr1 ausgelesen und in lngArr2 hineinkopiert,
    'das manipulierte Array ist lngArr2
    SAPtr(ArrPtr(lngArr2)) = SAPtr(ArrPtr(lngArr1))
    MsgBox CStr(lngArr1(0)) & "    " & CStr(lngArr1(1))
    MsgBox CStr(lngArr2(0)) & "    " & CStr(lngArr2(1))
    
    'Achtung Wichtig:
    'den Zeiger des Manipulierten Arrays wieder Nullen, sonst gibt es
    'einen Absturz der IDE und des Programmes, beim Versuch von VB
    'beide Arrays zu löschen, bzw den Speicher wieder frei zu geben.
    'entweder wieder über das Property, oder mit einer Nuller-Funktion
    'SAPtr(ArrPtr(lngArr2)) = 0
    Call ZeroSAPtr(ArrPtr(lngArr2))
End Sub

Private Sub TestStringArray()
    Dim strArr1() As String
    Dim strArr2() As String
    ReDim strArr1(0 To 1)
    strArr1(0) = "der erste String"
    strArr1(1) = "der zweite String"
    
    'der Zeiger wird von strArr1 ausgelesen und in strArr2 hineinkopiert,
    'das manipulierte Array ist strArr2
    SAPtr(StrArrPtr(strArr2)) = SAPtr(StrArrPtr(strArr1))
    MsgBox strArr1(0) & "    " & strArr1(1)
    MsgBox strArr2(0) & "    " & strArr2(1)
    
    'Achtung Wichtig:
    'den Zeiger des Manipulierten Arrays wieder Nullen, sonst gibt es
    'einen Absturz der IDE und des Programmes, beim Versuch von VB
    'beide Arrays zu löschen, bzw den Speicher wieder frei zu geben.
    'entweder wieder über das Property, oder mit einer Nuller-Funktion
    'SAPtr(StrArrPtr(strArr2)) = 0
    Call ZeroSAPtr(StrArrPtr(strArr2))
End Sub

Private Sub TestUDTypeArray()
    Dim udtArr1() As TAnyType
    Dim udtArr2() As TAnyType
    ReDim udtArr1(0 To 1)
    udtArr1(0).XVar = 123456
    udtArr1(0).YVar = 123456.789
    udtArr1(0).ZVar = 123456789.123456
    udtArr1(0).SVar = "der erste String"
    udtArr1(1).XVar = 654321
    udtArr1(1).YVar = 987654.321
    udtArr1(1).ZVar = 987654321.987654
    udtArr1(1).SVar = "der zweite String"
    
    'der Zeiger wird von udtArr1 ausgelesen und in udtArr2 hineinkopiert,
    'das manipulierte Array ist udtArr2
    SAPtr(ArrPtr(udtArr2)) = SAPtr(ArrPtr(udtArr1))
    MsgBox TAnyTypeToString(udtArr1(0)) & vbCrLf & _
           TAnyTypeToString(udtArr1(1))
    MsgBox TAnyTypeToString(udtArr2(0)) & vbCrLf & _
           TAnyTypeToString(udtArr2(1))
           
    'Achtung Wichtig:
    'den Zeiger des Manipulierten Arrays wieder Nullen, sonst gibt es
    'einen Absturz der IDE und des Programmes, beim Versuch von VB
    'beide Arrays zu löschen, bzw den Speicher wieder frei zu geben.
    'entweder wieder über das Property, oder mit einer Nuller-Funktion
    'SAPtr(StrArrPtr(strArr2)) = 0
    Call ZeroSAPtr(ArrPtr(udtArr2))
End Sub

Private Function TAnyTypeToString(A As TAnyType) As String
    Dim m As String
    m = m & CStr(A.XVar) & vbCrLf
    m = m & CStr(A.YVar) & vbCrLf
    m = m & CStr(A.ZVar) & vbCrLf
    m = m & A.SVar & vbCrLf
    TAnyTypeToString = m
End Function

Private Sub TestObjectArray()
    Dim objArr1() As Class1
    Dim objArr2() As Class1
    ReDim objArr1(0 To 1)
    Set objArr1(0) = New_Class1(123456789.123456)
    Set objArr1(1) = New_Class1(987654321.987654)
    
    'der Zeiger wird von objArr1 ausgelesen und in objArr2 hineinkopiert,
    'das manipulierte Array ist objArr2
    SAPtr(ArrPtr(objArr2)) = SAPtr(ArrPtr(objArr1))
    MsgBox objArr1(0).ToString & vbCrLf & _
           objArr1(1).ToString
    MsgBox objArr2(0).ToString & vbCrLf & _
           objArr2(1).ToString
           
    'Achtung Wichtig:
    'den Zeiger des Manipulierten Arrays wieder Nullen, sonst gibt es
    'einen Absturz der IDE und des Programmes, beim Versuch von VB
    'beide Arrays zu löschen, bzw den Speicher wieder frei zu geben.
    'entweder wieder über das Property, oder mit einer Nuller-Funktion
    'SAPtr(StrArrPtr(strArr2)) = 0
    Call ZeroSAPtr(ArrPtr(objArr2))

End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------- Anfang Modul "ModArray" alias ModArray.bas --------
Option Explicit

Public Declare Sub RtlMoveMemory Lib "kernel32" ( _
    ByRef Dst As Any, ByRef Src As Any, ByVal BytLength As Long)
    
Public Declare Sub RtlZeroMemory Lib "kernel32" ( _
    ByRef Dst As Any, ByVal BytLength As Long)
    
'die Funktion ArrPtr geht bei allen Arrays außer bei String-Arrays
Public Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" ( _
    ByRef Arr() As Any) As Long

'deswegen hier eine Hilfsfunktion für StringArrays
Public Function StrArrPtr(ByRef strArr As Variant) As Long
    Call RtlMoveMemory(StrArrPtr, ByVal VarPtr(strArr) + 8, 4)
End Function

'jetzt kann das Property SAPtr für Alle Arrays verwendet werden,
'um den Zeiger auf den Safe-Array-Descriptor eines Arrays einem
'anderen Array zuzuweisen.
Public Property Get SAPtr(ByVal pArr As Long) As Long
    Call RtlMoveMemory(SAPtr, ByVal pArr, 4)
End Property

Public Property Let SAPtr(ByVal pArr As Long, ByVal RHS As Long)
    Call RtlMoveMemory(ByVal pArr, RHS, 4)
End Property

Public Sub ZeroSAPtr(ByVal pArr As Long)
    Call RtlZeroMemory(ByVal pArr, 4)
End Sub

'####################'   Class1 Helper   '####################'
Public Function New_Class1(ByVal dVal As Double) As Class1
    Set New_Class1 = New Class1
    New_Class1.DblVal = dVal
End Function
'--------- Ende Modul "ModArray" alias ModArray.bas ---------
'--------- Anfang Klasse "Class1" alias Class1.cls  ---------
Option Explicit

'nur eine Dummy-Klasse
Public DblVal As Double

Public Function ToString()
  ToString = CStr(DblVal)
End Function
'---------- Ende Klasse "Class1" alias Class1.cls  ----------
'-------------- Ende Projektdatei Projekt1.vbp --------------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 1 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.