ExtControl.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 = "ExtControl"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Public WithEvents mycontrol As VBControlExtender
Attribute mycontrol.VB_VarHelpID = -1
Dim another As Object
Dim myname$, mytypedef$
Dim Callback As GuiM2000
Dim mIndex As Long
Friend Property Get GetCallBack() As GuiM2000
Set GetCallBack = Callback
End Property
Public Property Get index() As Long
index = mIndex
End Property
Friend Property Let index(ByVal RHS As Long)
mIndex = RHS
End Property
Friend Property Get ControlName() As String
ControlName = myname
End Property
Friend Property Get TypeDef() As String
TypeDef = mytypedef$
End Property
Friend Sub Attach(b As Control, aName$, typ$, mform As GuiM2000, Optional indx As Long = -1)
Err.Clear
On Error Resume Next
Set mycontrol = b
If Err.Number Then
Err.Clear
Set another = b
End If
mIndex = indx
Set Callback = mform
myname$ = aName$
End Sub
Property Get FixEvent() As Boolean
FixEvent = mycontrol Is Nothing
End Property
Property Get Value() As Object
Attribute Value.VB_UserMemId = 0
On Error Resume Next
If Not another Is Nothing Then
Set Value = another
Else
Set Value = mycontrol
End If
End Property
Public Sub deconstruct()
Set Callback = Nothing
Set mycontrol = Nothing
Set another = Nothing
End Sub

Private Sub mycontrol_ObjectEvent(Info As EventInfo)
Dim Values(), M As Long, uk1 As Object
Dim check As Variant
'Debug.Print Info.Name, mycontrol.Name
If LCase(Info.Name) = "lostfocus" Or LCase(Info.Name) = "lostfocus1" Then
If mycontrol.enabled And mycontrol.Visible Then
    Callback.LastActive = mycontrol.Name  'myname$
    Else
    If Callback.LastActive = vbNullString Then
Callback.LastActive = "gList2"
End If
    On Error Resume Next
    If Callback.Controls(Callback.LastActive).Visible Then
        Dim a As Object
        Set a = Callback.Controls(Callback.LastActive)
        If a Is Nothing Then
            Callback.LastActive = ""
        ElseIf a.enabled Then
            a.SetFocus
        End If
    End If
End If
End If



If Info.EventParameters.Count > 0 Then
ReDim Values(0 To Info.EventParameters.Count)
Dim evinf As EventParameter
M = 0

For Each evinf In Info.EventParameters
    On Error Resume Next
    check = evinf
    If Err.Number Then
    Err.Clear
    On Error GoTo 100
    Set Values(M) = evinf
    Else
    Values(M) = check
    End If
    
    'If MemLong(MemLong(VarPtr(check) + 8) + 24) = 0 Then
    '    Err.Clear
    '    Values(M) = "Error"
    'Else
    '    If MyIsObject(evinf.Value) Then
    '        Set Values(M) = evinf.Value
    '    Else
    '        Values(M) = evinf.Value
    '    End If
    'End If
100
    If Err Then
        Err.Clear
        Values(M) = "Error"
    End If
    
    M = M + 1
Next evinf
If mIndex <> -1 Then
    Callback.CallbackNow myname$ + "." + Info.Name + "(" & mIndex & ")", Values()
Else
    Callback.CallbackNow myname$ + "." + Info.Name + "()", Values()
End If
Err.Clear
On Error Resume Next
With Info.EventParameters
For M = M - 1 To 0
    If IsObject(Values(M)) Then
        If Not .item(M).Value Is Values(M) Then
            Set check = .item(M)
            
            Set check.Value = Values(M)
        End If
        Err.Clear
    Else
        .item(M).Value = Values(M)
    End If
Next M
End With
ElseIf mIndex <> -1 Then
    Callback.Callback myname$ + "." + Info.Name + "(" & mIndex & ")"
Else
    Callback.Callback myname$ + "." + Info.Name + "()"
End If
End Sub
Public Property Let Default(RHS)
On Error Resume Next
If Not Callback Is Nothing Then
If CBool(RHS) Then Callback.Default = mycontrol.Name
End If
End Property