Attribute VB_Name = "mControlEventsFreeze"
' mControlEventsFreeze.bas
'
' Freezes and thaws all event connections on any ActiveX control.
' Useful when programmatically manipulating a control's properties
' without triggering client event handlers.
'
' Usage:
'   Dim FreezeState As ControlFreezeState
'   Dim WasFrozen As Boolean
'   WasFrozen = FreezeAllEvents(MyControl, FreezeState)
'   If WasFrozen Then ThawAllEvents FreezeState
'
' Requires reference to oleexp.tlb
' (IConnectionPointContainer, IConnectionPoint, IEnumConnections,
'  CONNECTDATA, UUID, IProvideClassInfo, ITypeInfo, TYPEATTR)

Option Explicit

Private Const IMPLTYPEFLAG_FSOURCE As Long = 2

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    ByRef Destination As Any, ByVal SourcePointer As Long, ByVal Length As Long)

Private Declare Function StringFromGUID2 Lib "ole32.dll" ( _
    ByRef rguid As UUID, ByVal lpsz As Long, ByVal cbMax As Long) As Long

Private Declare Function CLSIDFromString Lib "ole32.dll" ( _
    ByVal lpsz As Long, ByRef pclsid As UUID) As Long

Private Type FrozenConnection
    ConnectionPoint As IConnectionPoint
    Sink As IUnknown
    Cookie As Long
End Type

Public Type ControlFreezeState
    Connections() As FrozenConnection
    Count As Long
End Type

' ============================================================
' Public API
' ============================================================

Public Function FreezeAllEvents(ByRef TargetControl As Object, _
    ByRef FreezeState As ControlFreezeState) As Boolean

    Dim EventsIIDText As String
    Dim EventsIID As UUID
    Dim ConnectionPointContainer As IConnectionPointContainer
    Dim EventsConnectionPoint As IConnectionPoint

    On Error GoTo ErrorHandler

    FreezeState.Count = 0
    ReDim FreezeState.Connections(0 To 7)

    EventsIIDText = ResolveEventsIID(TargetControl)
    If Len(EventsIIDText) = 0 Then GoTo ErrorHandler

    CLSIDFromString StrPtr(EventsIIDText), EventsIID

    Set ConnectionPointContainer = TargetControl
    Set EventsConnectionPoint = ConnectionPointContainer.FindConnectionPoint(EventsIID)
    If EventsConnectionPoint Is Nothing Then GoTo ErrorHandler

    CaptureAndDisconnect EventsConnectionPoint, FreezeState

    FreezeAllEvents = True
    Exit Function

ErrorHandler:
    FreezeAllEvents = False

End Function

Public Sub ThawAllEvents(ByRef FreezeState As ControlFreezeState)

    Dim ConnectionIndex As Long

    For ConnectionIndex = 0 To FreezeState.Count - 1
        FreezeState.Connections(ConnectionIndex).Cookie = _
            FreezeState.Connections(ConnectionIndex).ConnectionPoint.Advise( _
                FreezeState.Connections(ConnectionIndex).Sink)
    Next ConnectionIndex

    FreezeState.Count = 0
    Erase FreezeState.Connections

End Sub

' ============================================================
' Private implementation
' ============================================================

Private Function ResolveEventsIID(ByRef TargetControl As Object) As String

    Dim ClassInfoProvider As IProvideClassInfo
    Dim CoClassTypeInfo As ITypeInfo
    Dim CoClassAttrPointer As Long
    Dim CoClassAttr As TYPEATTR
    Dim ImplCount As Integer
    Dim ImplIndex As Long
    Dim ImplFlags As Long
    Dim RefTypeHandle As Long
    Dim EventsTypeInfo As ITypeInfo
    Dim EventsAttrPointer As Long
    Dim EventsAttr As TYPEATTR

    On Error GoTo ErrorHandler

    Set ClassInfoProvider = TargetControl
    If ClassInfoProvider Is Nothing Then GoTo ErrorHandler

    Set CoClassTypeInfo = ClassInfoProvider.GetClassInfo()
    If CoClassTypeInfo Is Nothing Then GoTo ErrorHandler

    CoClassAttrPointer = CoClassTypeInfo.GetTypeAttr()
    CopyMemory CoClassAttr, CoClassAttrPointer, Len(CoClassAttr)
    ImplCount = CoClassAttr.cImplTypes
    CoClassTypeInfo.ReleaseTypeAttr CoClassAttrPointer

    For ImplIndex = 0 To ImplCount - 1

        ImplFlags = CoClassTypeInfo.GetImplTypeFlags(ImplIndex)

        If (ImplFlags And IMPLTYPEFLAG_FSOURCE) <> 0 Then

            RefTypeHandle = CoClassTypeInfo.GetRefTypeOfImplType(ImplIndex)
            Set EventsTypeInfo = CoClassTypeInfo.GetRefTypeInfo(RefTypeHandle)

            EventsAttrPointer = EventsTypeInfo.GetTypeAttr()
            CopyMemory EventsAttr, EventsAttrPointer, Len(EventsAttr)
            ResolveEventsIID = UUIDToString(EventsAttr.iid)
            EventsTypeInfo.ReleaseTypeAttr EventsAttrPointer

            Exit Function

        End If

    Next ImplIndex

    ResolveEventsIID = ""
    Exit Function

ErrorHandler:
    Debug.Print "ResolveEventsIID ERROR "; Err.Number; ": "; Err.Description
    ResolveEventsIID = ""

End Function

Private Sub CaptureAndDisconnect(ByVal ConnectionPoint As IConnectionPoint, _
    ByRef FreezeState As ControlFreezeState)

    Dim ConnectionsEnum As IEnumConnections
    Dim ConnectionData As CONNECTDATA
    Dim FetchedCount As Long

    Set ConnectionsEnum = ConnectionPoint.EnumConnections()

    Do
        FetchedCount = 0
        ConnectionsEnum.Next 1, ConnectionData, FetchedCount
        If FetchedCount = 0 Then Exit Do

        If FreezeState.Count > UBound(FreezeState.Connections) Then
            ReDim Preserve FreezeState.Connections(0 To UBound(FreezeState.Connections) + 8)
        End If

        Set FreezeState.Connections(FreezeState.Count).ConnectionPoint = ConnectionPoint
        Set FreezeState.Connections(FreezeState.Count).Sink = ConnectionData.pUnk
        FreezeState.Connections(FreezeState.Count).Cookie = ConnectionData.dwCookie
        FreezeState.Count = FreezeState.Count + 1

        ConnectionPoint.Unadvise ConnectionData.dwCookie

    Loop

End Sub

Private Function UUIDToString(ByRef SourceUUID As UUID) As String

    Dim Buffer As String
    Dim CharsWritten As Long

    Buffer = String$(39, vbNullChar)
    CharsWritten = StringFromGUID2(SourceUUID, StrPtr(Buffer), 39)

    If CharsWritten > 0 Then
        UUIDToString = Left$(Buffer, CharsWritten - 1)
    Else
        UUIDToString = ""
    End If

End Function