Wenn ich 2 Datenfelder in Variant Variablen bekomme (z.B. als Funktionsparameter), wie kann ich effizient testen, ob es sich bei beiden um dasselbe Datenfeld handelt, ohne den Inhalt der beiden zu zerstören?
Und die wichtige Zusatzfrage: weiß jemand eine Möglichkeit (ausser Funktionsparameter ByRef), um einer Variant Variablen ein Datenfeld zuzuweisen, ohne dieses zu kopieren?
Beispiel mit einer sehr hässlichen 'fbIsSameArray' Funktion:
Public Sub fTest()
Dim toObject1 As Collection
Set toObject1 = New Collection
Dim toObject2 As Collection
Set toObject2 = New Collection
Dim tavSource As Variant
Let tavSource = Array( _
0, toObject1, toObject2, "drei", 4, Nothing)
Dim tavTarget As Variant
Dim tavResult As Variant
Let tavResult = Array(toObject1, toObject2, Nothing)
Call fCollectObjects(tavTarget, tavSource)
Debug.Assert fbVerifyObjects(tavResult, tavTarget)
Debug.Print "Collect 1 ok"
Call fCollectObjects(tavSource, tavSource)
Debug.Assert fbVerifyObjects(tavResult, tavTarget)
Debug.Assert fbVerifyObjects(tavResult, tavSource)
Debug.Print "Collect 2 ok"
Let tavTarget = Empty
Debug.Assert IsEmpty(tavSource)
Debug.Print "Same Array ok"
' assertion fails because 'tavTarget' and 'tavSource'
' are copies due to internal parameter assignment
' (and thereby array copying).
' preferably they should identical but how?
End Sub
Private Function fbVerifyObjects( _
ByRef pavResult As Variant, ByRef pavArray As Variant)
Let fbVerifyObjects = LBound(pavResult) = LBound(pavArray) _
And UBound(pavResult) = UBound(pavArray)
If fbVerifyObjects Then
Dim tnOffset As Long
Let tnOffset = LBound(pavResult)
Do
If tnOffset > UBound(pavResult) Then
Exit Function
End If
If Not pavResult(tnOffset) Is pavArray(tnOffset) Then
Let fbVerifyObjects = False
Exit Function
End If
Let tnOffset = tnOffset + 1
Loop
End If
End Function
Public Sub fCollectObjects( _
ByRef pavTarget As Variant, ByRef pavSource As Variant)
If (Not IsEmpty(pavTarget) And Not IsArray(pavTarget)) _
Or IsEmpty(pavSource) Or Not IsArray(pavSource) Then
Let pavTarget = Empty
Exit Sub
End If
Dim tnCount As Long
Let tnCount = 0
Dim tnSourceOffset As Long
Let tnSourceOffset = LBound(pavSource)
Do
If tnSourceOffset > UBound(pavSource) Then
Exit Do
End If
If IsObject(pavSource(tnSourceOffset)) Then
Let tnCount = tnCount + 1
End If
Let tnSourceOffset = tnSourceOffset + 1
Loop
If fbIsSameArray(pavTarget, pavSource) Then
Dim tavTarget As Variant
ReDim tavTarget(LBound(pavSource) _
To LBound(pavSource) + tnCount - 1) As Variant
Call fCopyObjects(tavTarget, pavSource)
Let pavTarget = tavTarget
Else
ReDim pavTarget(LBound(pavSource) _
To LBound(pavSource) + tnCount - 1) As Variant
Call fCopyObjects(pavTarget, pavSource)
End If
End Sub
Private Sub fCopyObjects( _
ByRef pavTarget As Variant, ByRef pavSource As Variant)
Dim tnTargetOffset As Long
Let tnTargetOffset = LBound(pavTarget)
Dim tnSourceOffset As Long
Let tnSourceOffset = LBound(pavSource)
Do
If tnTargetOffset > UBound(pavTarget) Then
Exit Sub
End If
If IsObject(pavSource(tnSourceOffset)) Then
Set pavTarget(tnTargetOffset) = _
pavSource(tnSourceOffset)
Let tnTargetOffset = tnTargetOffset + 1
End If
Let tnSourceOffset = tnSourceOffset + 1
Loop
End Sub
Public Function fbIsSameArray( _
ByRef pavOne As Variant, ByRef pavTwo As Variant) As Boolean
Let fbIsSameArray = False
If IsEmpty(pavOne) Then
If IsEmpty(pavTwo) Then
Let pavOne = Null
Let fbIsSameArray = IIf(IsNull(pavTwo), True, False)
Let pavOne = Empty
End If
Exit Function
End If
If IsEmpty(pavTwo) Then
Exit Function
End If
' both are not 'Empty' here, so array test is possible
If Not IsArray(pavOne) Or Not IsArray(pavTwo) Then
Exit Function
End If
Dim tiFrom As Long
Let tiFrom = LBound(pavOne)
Dim tiInto As Long
Let tiInto = UBound(pavOne)
If tiFrom <> LBound(pavTwo) Or tiInto <> UBound(pavTwo) Then
Exit Function
End If
' now it gets ugly:
' if the items of the arrays contains arrays, an item-
' assignment test yields array copies by back assignment.
' so grow one and see whether the other one grows too.
ReDim Preserve pavOne(tiFrom To tiInto + 1)
Let fbIsSameArray = _
IIf(UBound(pavOne) = UBound(pavTwo), True, False)
ReDim Preserve pavOne(tiFrom To tiInto)
End Function
|