PropReference.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "PropReference"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Dim ObjectRef As Long
Dim lastpropname As String
Dim vtref As Long
Dim mIndex As Variant
Public UseIndex As Boolean
Dim Init As Boolean
'Dim IamMethod  As Boolean  ' not used
Dim hardlink As Object, useobj As Boolean, isobjret As Boolean
Private mLastObj As Object
Public arr As Boolean
Private UseExtControl As Boolean
'Dim oEnum As IUnknown
Private IndexList As mIndexes
Private IndexNew As Boolean
Function IsObj()
    IsObj = useobj
End Function
Friend Property Get CurObject() As Object
If useobj Then
Set CurObject = hardlink
Else
Set CurObject = var(ObjectRef)
End If
End Property
Property Get ObjectType() As String
On Error Resume Next
Dim v As Variant, that As FastCollection, other As StructCollection
If Not hardlink Is Nothing Then
    If TypeOf hardlink Is ExtControl Then
    ObjectType = "*" + Typename(hardlink.mycontrol)
    Else
    
    If TypeOf hardlink Is FastCollection Then
        Set that = hardlink
        ObjectType = "[?*Inventory]"
    ElseIf TypeOf hardlink Is StructCollection Then
        Set other = hardlink
        ObjectType = "[?*" + Typename(other.StructObj) + "]"
    Else
        ObjectType = "[?*" + Typename(hardlink) + "]"
    End If
    End If
Else
    If TypeOf var(ObjectRef) Is ExtControl Then
    ObjectType = "[?*" + Typename(var(ObjectRef).mycontrol) + "]"
    Else
    ObjectType = "[?*" + Typename(var(ObjectRef)) + "]"
    End If
End If
End Property
Property Get ZeroRef() As Boolean
    ZeroRef = vtref = 0
End Property

Sub Construct(ref As Long, vtrefnumber As Long, indirect As Boolean, UseExtCtrl As Boolean, PropName$)
If useobj Then Exit Sub
UseExtControl = UseExtCtrl
Init = True
lastpropname = PropName$
ObjectRef = ref
If indirect Then
vtref = -vtrefnumber
Else
vtref = vtrefnumber
End If
End Sub
Property Get IHaveFname() As Boolean
    IHaveFname = Len(lastpropname) > 0
End Property
Property Get FN() As String
    FN = lastpropname
End Property

Sub ConstructObj(obj As Object, vtrefnumber As Long, UseExtCtrl, PropName$)
Init = True

lastpropname = PropName$
UseIndex = False
isobjret = False
mIndex = Empty
UseExtControl = UseExtCtrl
ObjectRef = 0
Set hardlink = obj
useobj = True
Set mLastObj = Nothing
vtref = vtrefnumber
'Debug.Print Typename(obj), vtref
End Sub
Public Property Get lastobj() As Object
Set lastobj = mLastObj
End Property
Public Property Get lastobjfinal() As Object
Set lastobjfinal = mLastObj
Set mLastObj = Nothing
End Property
Public Sub clearlastobject()
Set mLastObj = Nothing
End Sub
Public Property Get ValueObjNoError() As Object
Dim v, oerr As Boolean
oerr = skiperror
skiperror = True
Dim RETVAR As Variant, retvar2, obj As Object
Dim check As Boolean
Set mLastObj = Nothing
isobjret = False
If Init Then
    If UseIndex Then
        If Not IndexNew Then
            'ValueObj = 0
            Set mLastObj = Me
            'Set ValueObj = Me
            isobjret = True
            skiperror = oerr
            Exit Property
        ElseIf useobj Then
            IndexNew = False
            Set ValueObjNoError = ReadPropIndexObjObj(hardlink, vtref, mIndex, UseExtControl)
            
        Else
            IndexNew = False
            Set obj = var(ObjectRef)
            Set ValueObjNoError = ReadPropIndexObjObj(obj, vtref, mIndex, UseExtControl)
          
        End If
    Else
        If useobj Then
            If ReadPropObj(hardlink, vtref, RETVAR, UseExtControl) Then
                If IsObject(RETVAR) Then
                    isobjret = True
                    'ValueObj = 0
                    Set mLastObj = RETVAR
                Else
                    If TypeOf RETVAR Is IUnknown Then
                        isobjret = True
                     '   ValueObj = 0
                        Set mLastObj = RETVAR
                        skiperror = oerr
                        Exit Property
                    End If
                    'ValueObj = RETVAR
                End If
            End If
        Else
            If ReadProp(ObjectRef, vtref, RETVAR, UseExtControl) Then
                If IsObject(RETVAR) Then
                    isobjret = True
                    'ValueObj = 0
                    Set mLastObj = RETVAR
                Else
                    On Error Resume Next
                    If TypeOf RETVAR Is IUnknown Then
                        isobjret = True
                     '   ValueObj = 0
                        Set mLastObj = RETVAR
                        skiperror = oerr
                        Exit Property
                    End If
                    Err.Clear
                   ' ValueObj = RETVAR
                End If
            End If
        End If
    End If
End If
skiperror = oerr
End Property

Public Property Get ValueObj() As Object
Dim v
Dim RETVAR As Variant, retvar2, obj As Object
Dim check As Boolean
Set mLastObj = Nothing
isobjret = False
If Init Then
    If UseIndex Then
        If Not IndexNew Then
            'ValueObj = 0
            Set mLastObj = Me
            'Set ValueObj = Me
            isobjret = True
            Exit Property
        ElseIf useobj Then
            IndexNew = False
            Set ValueObj = ReadPropIndexObjObj(hardlink, vtref, mIndex, UseExtControl)
        Else
            IndexNew = False
            Set obj = var(ObjectRef)
            Set ValueObj = ReadPropIndexObjObj(obj, vtref, mIndex, UseExtControl)
          
        End If
    Else
        If useobj Then
            If ReadPropObj(hardlink, vtref, RETVAR, UseExtControl) Then
                If IsObject(RETVAR) Then
                    isobjret = True
                    'ValueObj = 0
                    Set mLastObj = RETVAR
                    
                Else
                    If TypeOf RETVAR Is IUnknown Then
                        isobjret = True
                     '   ValueObj = 0
                        Set mLastObj = RETVAR: Exit Property
                    End If
                    'ValueObj = RETVAR
                End If
            End If
        Else
            If ReadProp(ObjectRef, vtref, RETVAR, UseExtControl) Then
                If IsObject(RETVAR) Then
                    isobjret = True
                    'ValueObj = 0
                    Set mLastObj = RETVAR
                Else
                    On Error Resume Next
                    If TypeOf RETVAR Is IUnknown Then
                        isobjret = True
                     '   ValueObj = 0
                        Set mLastObj = RETVAR: Exit Property
                    End If
                    Err.Clear
                   ' ValueObj = RETVAR
                End If
            End If
        End If
    End If
End If
End Property
Public Property Get ValueNoError() As Variant
Dim v, oerr As Boolean
oerr = skiperror
skiperror = True
Dim RETVAR As Variant, retvar2, obj As Object
Dim check As Boolean
Set mLastObj = Nothing
isobjret = False
If Init Then
    If UseIndex Then
        If Not IndexNew Then
            ValueNoError = 0
            Set mLastObj = Me
            isobjret = True
            skiperror = oerr

            Exit Property
        ElseIf useobj Then
            IndexNew = False

            ValueNoError = ReadPropIndexObj(hardlink, vtref, mIndex, UseExtControl)
        Else
            IndexNew = False
            ValueNoError = ReadPropIndex(ObjectRef, vtref, mIndex, UseExtControl, check, RETVAR)
            If check And IsObject(RETVAR) Then
                On Error Resume Next
                Set obj = RETVAR
                If ReadOneParameter(obj, (0), vbNullString, retvar2) Then
                    ValueNoError = retvar2
                Else
                    isobjret = True
                    Set mLastObj = RETVAR
                End If
            End If
        End If
    Else
        If useobj Then
            If ReadPropObj(hardlink, vtref, RETVAR, UseExtControl) Then
                If IsObject(RETVAR) Then
                    isobjret = True
                    ValueNoError = 0
                    Set mLastObj = RETVAR
                Else
                    If TypeOf RETVAR Is IUnknown Then
                        isobjret = True
                        ValueNoError = 0
                        Set mLastObj = RETVAR
                        skiperror = oerr
                        Exit Property
                    End If
                    ValueNoError = RETVAR
                End If
            End If
        Else
            If ReadProp(ObjectRef, vtref, RETVAR, UseExtControl) Then
                If IsObject(RETVAR) Then
                    isobjret = True
                    ValueNoError = 0
                    Set mLastObj = RETVAR
                Else
                    On Error Resume Next
                    If TypeOf RETVAR Is IUnknown Then
                        isobjret = True
                        ValueNoError = 0
                        Set mLastObj = RETVAR
                        skiperror = oerr
                        Exit Property
                    End If
                    Err.Clear
                    ValueNoError = RETVAR
                End If
            End If
        End If
    End If
End If
skiperror = oerr
End Property

Public Property Get Value() As Variant
Dim v
Dim RETVAR As Variant, retvar2, obj As Object
Dim check As Boolean
Set mLastObj = Nothing
isobjret = False
If Init Then
    If UseIndex Then
        If Not IndexNew Then
            Value = 0
            Set mLastObj = Me
            isobjret = True
            Exit Property
        ElseIf useobj Then
            IndexNew = False
            Value = ReadPropIndexObj(hardlink, vtref, mIndex, UseExtControl)
            
        Else
            IndexNew = False
            Value = ReadPropIndex(ObjectRef, vtref, mIndex, UseExtControl, check, RETVAR)
            If check And IsObject(RETVAR) Then
                On Error Resume Next
                Set obj = RETVAR
                If ReadOneParameter(obj, (0), vbNullString, retvar2) Then
                    Value = retvar2
                Else
                    isobjret = True
                    Set mLastObj = RETVAR
                End If
            End If
        End If
    Else
        If useobj Then
            If ReadPropObj(hardlink, vtref, RETVAR, UseExtControl) Then
                If IsObject(RETVAR) Then
                    isobjret = True
                    Value = 0
                    Set mLastObj = RETVAR
                Else
                    If TypeOf RETVAR Is IUnknown Then
                        isobjret = True
                        Value = 0
                        Set mLastObj = RETVAR: Exit Property
                    End If
                    Value = RETVAR
                End If
            End If
        Else
            If ReadProp(ObjectRef, vtref, RETVAR, UseExtControl) Then
                If IsObject(RETVAR) Then
                    isobjret = True
                    Value = 0
                    Set mLastObj = RETVAR
                Else
                    On Error Resume Next
                    If TypeOf RETVAR Is IUnknown Then
                        isobjret = True
                        Value = 0
                        Set mLastObj = RETVAR: Exit Property
                    End If
                    Err.Clear
                    Value = RETVAR
                End If
            End If
        End If
    End If
End If
End Property

Public Property Let Value(vNewValue As Variant)
Dim usehandler As mHandler
If MemInt(VarPtr(vNewValue)) = 36 Then
    If TypeOf vNewValue Is ExtArray Then
        nMath2.DumpVBArray VarPtr(vNewValue)
    End If
ElseIf MyIsObject(vNewValue) Then
If Not vNewValue Is Nothing Then
If TypeOf vNewValue Is mHandler Then
Set usehandler = vNewValue
If usehandler.t1 = 3 Then
 'vNewValue = usehandler.objref.VariantArray()
 If TypeOf usehandler.objref Is mArray Then
 usehandler.objref.ExportVariant vNewValue
 Else
 Set vNewValue = usehandler.objref
 End If
End If
ElseIf TypeOf vNewValue Is mArray Then
 'vNewValue = vNewValue.VariantArray()
vNewValue.ExportVariant vNewValue

End If
End If
End If
If Init Then
If Not UseIndex Then
If useobj Then
WritePropObj hardlink, vtref, vNewValue, UseExtControl
Else
WriteProp ObjectRef, vtref, vNewValue, UseExtControl
End If
ElseIf Not IndexNew Then
    MyEr "Missing index", "¸÷áóá ôïí äåßêôç"
    Exit Property
ElseIf useobj Then
IndexNew = False
WritePropIndexObj hardlink, vtref, vNewValue, mIndex, UseExtControl
Else
IndexNew = False
WritePropIndex ObjectRef, vtref, vNewValue, mIndex, UseExtControl
End If
End If

End Property
Public Property Let ValueStr(s As String)
Dim vNewValue
vNewValue = vbNullString
SwapString2Variant s, vNewValue
If Init Then
If Not UseIndex Then
If useobj Then
    WritePropObj hardlink, vtref, vNewValue, UseExtControl
Else
    WriteProp ObjectRef, vtref, vNewValue, UseExtControl
End If
ElseIf Not IndexNew Then
' do nothing
    MyEr "Missing index", "¸÷áóá ôïí äåßêôç"
    Exit Property
ElseIf useobj Then
    IndexNew = False
    WritePropIndexObj hardlink, vtref, vNewValue, mIndex, UseExtControl
Else
    IndexNew = False
    WritePropIndex ObjectRef, vtref, vNewValue, mIndex, UseExtControl
End If
End If


End Property
'Public Property Get isMethod() As Boolean
'isMethod = IamMethod
'End Property

'Public Property Let isMethod(ByVal vNewValue As Boolean)
'IamMethod = vNewValue
'End Property


Private Sub Class_Terminate()
Set hardlink = Nothing
End Sub
Public Sub IndexOpt()
IndexNew = True
mIndex = 0
OptVariant mIndex
End Sub
Public Property Get index() As Variant
index = mIndex
End Property
Public Sub ArrayIndex(ParamArray RHS())
    mIndex = RHS
End Sub

Public Property Let index(ByVal RHS As Variant)
IndexNew = True
mIndex = RHS
End Property
Friend Sub PushIndexes(idx As mIndexes)
If idx Is Nothing Then Exit Sub
IndexNew = True
UseIndex = True
If IndexList Is Nothing Then
    If idx.Count = 1 Then
       idx.Dump 0, mIndex
    Else
    idx.GetArr mIndex
    End If
End If
End Sub
Sub IndexAgain()
    IndexNew = True
End Sub

Public Property Get LastHasObject() As Variant
LastHasObject = isobjret
End Property
Function Copy() As PropReference
Set Copy = New PropReference
If useobj Then
    Copy.ConstructObj hardlink, vtref, UseExtControl, FN
Else
    Copy.Construct ObjectRef, Abs(vtref), Sgn(vtref) < 0, UseExtControl, FN
End If
Copy.UseIndex = False
End Function