Option Explicit
 
Public Const IID_IDispatch = "{00020400-0000-0000-C000-000000000046}"
Public Const IID_IPersistStorage = _
  "{0000010A-0000-0000-C000-000000000046}"
Public Const IID_IPersistStream = _
  "{00000109-0000-0000-C000-000000000046}"
Public Const IID_IPersistPropertyBag = _
  "{37D84F60-42CB-11CE-8135-00AA004BB851}"
 
Public Const INTERFACESAFE_FOR_UNTRUSTED_CALLER = &H1
Public Const INTERFACESAFE_FOR_UNTRUSTED_DATA = &H2
Public Const E_NOINTERFACE = &H80004002
Public Const E_FAIL = &H80004005
Public Const MAX_GUIDLEN = 40
 
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
   (pDest As Any, pSource As Any, ByVal ByteLen As Long)
Public Declare Function StringFromGUID2 Lib "ole32.dll" (rguid As _
   Any, ByVal lpstrClsId As Long, ByVal cbMax As Integer) As Long
 
Public Type udtGUID
    data1 As Long
    data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type
 
Public m_fSafeForScripting As Boolean
Public m_fSafeForInitializing As Boolean
 
Sub Main()
    m_fSafeForScripting = True
    m_fSafeForInitializing = True
End Sub

'//////////////////////////////////////////////////////////////////////////////
'//
'// IObjectSafety Interface Implementation
'//
 
'------------------------------------------------------------------------------
' IObjectSafety_GetInterfaceSafetyOptions
'------------------------------------------------------------------------------
Private Sub IObjectSafety_GetInterfaceSafetyOptions( _
                            ByVal riid As Long, _
                            pdwSupportedOptions As Long, _
                            pdwEnabledOptions As Long)
 
    Dim Rc      As Long
    Dim rClsId  As udtGUID
    Dim IID     As String
    Dim bIID()  As Byte
 
    pdwSupportedOptions = INTERFACESAFE_FOR_UNTRUSTED_CALLER Or _
                          INTERFACESAFE_FOR_UNTRUSTED_DATA
 
    If (riid <> 0) Then
        CopyMemory rClsId, ByVal riid, Len(rClsId)
 
        bIID = String$(MAX_GUIDLEN, 0)
        Rc = StringFromGUID2(rClsId, VarPtr(bIID(0)), MAX_GUIDLEN)
        Rc = InStr(1, bIID, vbNullChar) - 1
        IID = left$(UCase(bIID), Rc)
 
        Select Case IID
            Case IID_IDispatch
                pdwEnabledOptions = IIf(m_fSafeForScripting, _
              INTERFACESAFE_FOR_UNTRUSTED_CALLER, 0)
                Exit Sub
            Case IID_IPersistStorage, IID_IPersistStream, _
               IID_IPersistPropertyBag
                pdwEnabledOptions = IIf(m_fSafeForInitializing, _
              INTERFACESAFE_FOR_UNTRUSTED_DATA, 0)
                Exit Sub
            Case Else
                Err.Raise E_NOINTERFACE
                Exit Sub
        End Select
    End If
End Sub
 
'------------------------------------------------------------------------------
' IObjectSafety_SetInterfaceSafetyOptions
'------------------------------------------------------------------------------
Private Sub IObjectSafety_SetInterfaceSafetyOptions( _
                                ByVal riid As Long, _
                                ByVal dwOptionsSetMask As Long, _
                                ByVal dwEnabledOptions As Long)
 
    Dim Rc          As Long
    Dim rClsId      As udtGUID
    Dim IID         As String
    Dim bIID()      As Byte
 
    If (riid <> 0) Then
        CopyMemory rClsId, ByVal riid, Len(rClsId)
 
        bIID = String$(MAX_GUIDLEN, 0)
        Rc = StringFromGUID2(rClsId, VarPtr(bIID(0)), MAX_GUIDLEN)
        Rc = InStr(1, bIID, vbNullChar) - 1
        IID = left$(UCase(bIID), Rc)
 
        Select Case IID
            Case IID_IDispatch
                If ((dwEnabledOptions And dwOptionsSetMask) <> _
                  INTERFACESAFE_FOR_UNTRUSTED_CALLER) Then
                    Err.Raise E_FAIL
                    Exit Sub
                Else
                    If Not m_fSafeForScripting Then
                        Err.Raise E_FAIL
                    End If
                    Exit Sub
                End If
 
            Case IID_IPersistStorage, IID_IPersistStream, _
              IID_IPersistPropertyBag
                If ((dwEnabledOptions And dwOptionsSetMask) <> _
                INTERFACESAFE_FOR_UNTRUSTED_DATA) Then
                    Err.Raise E_FAIL
                    Exit Sub
                Else
                    If Not m_fSafeForInitializing Then
                        Err.Raise E_FAIL
                    End If
                    Exit Sub
                End If
 
            Case Else
                Err.Raise E_NOINTERFACE
                Exit Sub
        End Select
    End If
End Sub

[url]http://www.ptahsoft.ch/test/OBJSAFE.zip[/url]