VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CActiveScriptSite"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'CopyRight 2003 David Zimmer
'Author:   David Zimmer <dzzie@yahoo.com>
'Site:     http://sandsprite.com
'
'License: You are free to use this code and type library in any commercial or
'         non commercial applications as you wish so long as this header remains
'         intact.
'
'Note do not delete the empty subs or functions, they need to be there because they
'are part fo the interface we have claimed to have implemented...
'
' couple claude.ai bugfixes Jan 2026 see readme.
' added error details chatgpt March 2026

'==============================================================================
' CActiveScriptSite.cls - IActiveScript host for JScript
' Modified from dzzie's VBScript version to support JScript
'==============================================================================
Option Explicit

Implements IActiveScriptSite
Implements IActiveScriptSiteWindow

Private IScript As IActiveScript
Private IParse As IActiveScriptParse
Private cObjects As New Collection

Public Enum eScriptLanguage
    slVBScript = 0
    slJScript = 1
End Enum

Event ScriptError(e As CScriptError)
    
Public LastError As CScriptError

Public Sub ClearError()
    Set LastError = New CScriptError
End Sub

Private Sub Class_Initialize()
    InitEngine slJScript  ' Default to JScript
End Sub

Public Sub InitEngine(Optional eLang As eScriptLanguage = slJScript)
    Dim hRes As Long
    Dim oUnk As vbActiveScript3.IUnknown
    Dim clsidEngine As vbActiveScript3.UUID
    Dim uuidActScr As vbActiveScript3.UUID
    
    ' Select engine CLSID
    Select Case eLang
        Case slJScript
            CLSIDFromProgID "JScript", clsidEngine
        Case slVBScript
            CLSIDFromProgID "VBScript", clsidEngine
    End Select
    
    CLSIDFromString IID_IActiveScript, uuidActScr
    
    ' Create script engine instance
    hRes = CoCreateInstance(clsidEngine, Nothing, CLSCTX_INPROC_SERVER, uuidActScr, oUnk)
    
    Set IScript = oUnk
    IScript.SetScriptSite Me
    
    Set IParse = IScript
    IParse.InitNew
End Sub

Public Sub RunCode(Scode As String)
    Dim exep As vbActiveScript3.EXCEPINFO
    
    ClearError
    IParse.ParseScriptText Scode, _
                           Empty, _
                           Nothing, _
                           Empty, _
                           0, _
                           0, _
                           0, _
                           Null, _
                           exep
End Sub

Public Function Eval(sExpression As String) As Variant
    Dim exep As vbActiveScript3.EXCEPINFO
    Dim vAnswer As Variant
    
    ClearError
    IParse.ParseScriptText sExpression, _
                           Empty, _
                           Nothing, _
                           "", _
                           0, _
                           0, _
                           SCRIPTTEXT_ISEXPRESSION Or SCRIPTTEXT_ISVISIBLE, _
                           vAnswer, _
                           exep
    
    Eval = vAnswer
End Function

Public Sub SetScriptState(scrState As SCRIPTSTATE)
    IScript.SetScriptState scrState
End Sub

Public Sub AddObject(sName As String, obj As Object)
    cObjects.Add obj, sName
    IScript.AddNamedItem StrPtr(sName), SCRIPTITEM_ISVISIBLE Or SCRIPTITEM_GLOBALMEMBERS
End Sub

'------------------------------------------------------------------------------
' IActiveScriptSite Implementation
'------------------------------------------------------------------------------

Private Sub IActiveScriptSite_GetItemInfo(ByVal pstrName As String, _
    ByVal dwReturnMask As vbActiveScript3.SCRIPTINFO, ppiunkItem As Long, ppti As Long)
    
    Dim IDisp As vbActiveScript3.IDispatch
    Dim obj As Object
    
    On Error Resume Next
    Set obj = cObjects(pstrName)
    
    If Err.Number = 0 Then
        If dwReturnMask = SCRIPTINFO_IUNKNOWN Then
            Set IDisp = obj
            ppiunkItem = ObjPtr(IDisp)
            IDisp.AddRef
        End If
        Set obj = Nothing
    Else
        Debug.Print "Object not found: " & pstrName
    End If
End Sub

Private Function IActiveScriptSite_GetLCID() As Long
    IActiveScriptSite_GetLCID = E_NOTIMPL
End Function

Private Function IActiveScriptSite_GetDocVersionString() As String
End Function

Private Sub IActiveScriptSite_OnEnterScript()
End Sub

Private Sub IActiveScriptSite_OnLeaveScript()
End Sub

Private Sub IActiveScriptSite_OnScriptError(ByVal pscripterror As vbActiveScript3.IActiveScriptError)

    Dim ex As vbActiveScript3.EXCEPINFO
    Dim srcCtx As Long
    Dim lineNum As Long
    Dim charPos As Long
    Dim srcLine As String
    Dim e As CScriptError

    On Error GoTo hell

    pscripterror.GetExceptionInfo ex
    pscripterror.GetSourcePosition srcCtx, lineNum, charPos
    srcLine = pscripterror.GetSourceLineText()

    Set e = New CScriptError
    e.Description = ex.Description
    e.Source = ex.Source
    'e.HelpFile = ex.HelpFile
    'e.HelpContext = ex.dwHelpContext
    e.Scode = ex.Scode
    'e.SourceContext = srcCtx
    e.LineNumber = lineNum + 1
    e.CharPosition = charPos + 1
    e.SourceLine = srcLine

    Set LastError = e
    RaiseEvent ScriptError(e)
    Exit Sub

hell:
    Debug.Print "OnScriptError failed: " & Err.Number & " - " & Err.Description
End Sub

'Private Sub IActiveScriptSite_OnScriptError(pscripterror As Long)
'
'    Dim ase As vbActiveScript3.IActiveScriptError
'    Dim ex As vbActiveScript3.EXCEPINFO
'    Dim errObj As CScriptError
'    Dim srcCtx As Long
'    Dim lineNum As Long
'    Dim charPos As Long
'    Dim srcLine As String
'    Dim pErr As Long
'
'    On Error GoTo hell
'
'    'pscripterror is already the interface pointer
'    MoveMemory ase, pscripterror, 4
'
'    Debug.Print " pscripterror: " & Hex(pscripterror)
'
'    ase.GetExceptionInfo ex
'    ase.GetSourcePosition srcCtx, lineNum, charPos
'    srcLine = ase.GetSourceLineText()
'
'    Set errObj = New CScriptError
'    errObj.Description = ex.Description
'    errObj.Source = ex.Source
'    errObj.LineNumber = lineNum + 1
'    errObj.CharPosition = charPos + 1
'    errObj.SourceLine = srcLine
'    errObj.Scode = ex.Scode
'    'errObj.SourceContext = srcCtx
'
'    Set LastError = errObj
'    RaiseEvent ScriptError(errObj)
'
'done:
'    On Error Resume Next
'    MoveMemory ase, 0&, 4
'    Exit Sub
'
'hell:
'    Debug.Print "OnScriptError failed: " & Err.Number & " - " & Err.Description
'    Resume done
'End Sub

Private Sub IActiveScriptSite_OnScriptTerminate(pvarResult As Variant, _
    pexcepinfo As vbActiveScript3.EXCEPINFO)
End Sub

Private Sub IActiveScriptSite_OnStateChange(ByVal ssScriptState As vbActiveScript3.SCRIPTSTATE)
End Sub

'------------------------------------------------------------------------------
' IActiveScriptSiteWindow Implementation
'------------------------------------------------------------------------------

Private Sub IActiveScriptSiteWindow_EnableModeless(ByVal fEnable As vbActiveScript3.BOOL)
End Sub

Private Function IActiveScriptSiteWindow_GetWindow() As Long
    IActiveScriptSiteWindow_GetWindow = 0
End Function
