ActiveX(VB6)+JavaScript让ＩＥ浏览器与光标阅读器交互

Option Explicit
On Error Resume Next
Implements IObjectSafety
Dim Device As Long
Dim IsReading As Boolean
Dim MyList As String '鉴定计划中包含的所有准考证号码
Dim MyListed As String '已经读取过的准考证号码
Dim MyCount As Integer '读卡记数
Dim MyText As String '设备读取字符
Dim strlen As Long
 
'控件初始化
Private Sub UserControl_Initialize()
    Device = 0
    IsReading = False
    MyTimer.Interval = 50
    MyCount = 0
    MyText = ""
    getMyList ("")
End Sub
'取得控件版本
Public Sub getVersion()
    MsgBox "光标阅读机控件V 1.0.1"
End Sub
Private Sub cmdRead_Click()
     
    If IsReading Then
        OMR_StopRead
        OMR_StopMotor
        cmdRead.Caption = "阅　读"
        MyTimer.Enabled = False
        IsReading = False
    Else
        If OMR_ReadNoWait() = 0 Then    'OK
            cmdRead.Caption = "停止阅读"
            MyTimer.Enabled = True
            IsReading = True
        Else
            txtResult.Text = Space(100)
            strlen = OMR_CRetMess(OMR_GetLastError(), txtResult.Text)
            MsgBox txtResult.Text, vbCritical, "阅读失败"
        End If
    End If
End Sub
'-----------读卡设备断开--------------
Private Sub Command1_Click()
    cmdInstall.Enabled = True
    Command1.Enabled = False
    cmdRead.Enabled = False
    OMR_StopRead
    OMR_StopMotor
    OMR_Close
    txtResult.Text = txtResult.Text & Chr(13) & Chr(10) & "读卡设备断开！"
    txtResult.SelStart = Len(txtResult)
End Sub
Private Sub MyTimer_Timer()
    Dim sResultStr As String
    Dim lResultNum As Long
    Dim sUserID As String   '准考证号码
     
    MyTimer.Enabled = False
    Select Case OMR_IsReading()
    Case 0:     '阅读完毕
        sResultStr = Space(1000)
        lResultNum = OMR_GetResult(sResultStr, True)
        MyText = Mid(sResultStr, 1, 300) '取得有效文本
         
        If Check1 = Checked Then
            OMR_StopMotor
            cmdRead.Caption = "阅　读"
            MyTimer.Enabled = False
            IsReading = False
            txtResult.Text = txtResult.Text & "【" & MyText
            txtResult.Text = txtResult.Text & "】正确答案读取成功！"
            txtResult.SelStart = Len(txtResult)
            If (Option1.Value = True) Then '理论回调
                UserControl.Parent.Script.setRightRecord (MyText)
            ElseIf (Option2.Value = True) Then '实操回调
                UserControl.Parent.Script.setRightRecord1 (MyText)
            ElseIf (Option3.Value = True) Then '外语回调
                UserControl.Parent.Script.setRightRecord2 (MyText)
            End If
        Else
            sUserID = Mid(sResultStr, 2, 19) '取得准考证号码
            txtResult.Text = txtResult.Text & Chr(13) & Chr(10) & "【" & sUserID
            txtResult.Text = txtResult.Text & "】"
            txtResult.SelStart = Len(txtResult)
            '----------判断是否是正确的准考证----------
            If (InStr(sUserID, " ") > 0) Then
                OMR_StopMotor
                cmdRead.Caption = "阅　读"
                MyTimer.Enabled = False
                IsReading = False
                txtResult.Text = txtResult.Text & "ERROR 1：准考证填写错误！"
                txtResult.SelStart = Len(txtResult)
                UserControl.Parent.Script.myAlert ("ERROR 1：准考证填写错误！")
            ElseIf (InStr(MyList, sUserID) <= 0) Then
                OMR_StopMotor
                cmdRead.Caption = "阅　读"
                MyTimer.Enabled = False
                IsReading = False
                txtResult.Text = txtResult.Text & "ERROR 2：准考证不存在！"
                txtResult.SelStart = Len(txtResult)
                UserControl.Parent.Script.myAlert ("ERROR 2：准考证不存在！")
            ElseIf (InStr(MyListed, sUserID) > 0) Then
                OMR_StopMotor
                cmdRead.Caption = "阅　读"
                MyTimer.Enabled = False
                IsReading = False
                txtResult.Text = txtResult.Text & "ERROR 3：准考证号码重复！"
                txtResult.SelStart = Len(txtResult)
                UserControl.Parent.Script.myAlert ("ERROR 3：准考证号码重复！")
            Else
                MyListed = MyListed & "," & sUserID '记录已经读取的准考证号码
                MyCount = MyCount + 1 '累计读取卡片数
                Label2.Caption = MyCount   '显示读卡数
                If Left(sResultStr, 1) = "O" Then
                    If OMR_ReadNoWait() = 0 Then    'OK
                        cmdRead.Caption = "停止阅读"
                        MyTimer.Enabled = True
                        IsReading = True
                         
                        '-------------------回调js--------------
                        If (Option1.Value = True) Then '理论回调
                            UserControl.Parent.Script.setReadText (sResultStr)
                        ElseIf (Option2.Value = True) Then '实操回调
                            UserControl.Parent.Script.setReadText1 (sResultStr)
                        ElseIf (Option3.Value = True) Then '外语回调
                            UserControl.Parent.Script.setReadText2 (sResultStr)
                        End If
                         
                    Else
                        MsgBox "阅读失败", vbCritical, "警告"
                    End If
                Else
                    OMR_StopMotor
                    cmdRead.Caption = "阅　读"
                    MyTimer.Enabled = False
                    IsReading = False
                    sResultStr = Space(100)
                    strlen = OMR_CRetMess(OMR_GetLastError(), sResultStr)
                    txtResult.Text = sResultStr
                End If
                 
            End If
        End If
    Case -1:    '阅读失败
        cmdRead.Caption = "阅　读"
        MyTimer.Enabled = False
        IsReading = False
        sResultStr = Space(100)
        strlen = OMR_CRetMess(OMR_GetLastError(), sResultStr)
        txtResult.Text = sResultStr
        MsgBox sResultStr, vbCritical, "阅读失败"
         
    Case 1:     '正在阅读
    End Select
     
    '-----------------IsReading时启动timer----------------
    If IsReading Then
        MyTimer.Enabled = True
    End If
End Sub
'-----------------取得所有的准考证号码-----------------
Public Sub getMyList(str)
    If Len(str) > 0 Then
        MyList = str
    Else
        MyList = Text1.Text
    End If
End Sub
'-----------------初始化设备并加载格式文件-------------------
Public Sub cmdInstall_Click()
    cmdInstall.Enabled = False
    Device = OMR_Installed(0)
    Select Case Device
    Case Is = 0:
        'MsgBox "初始化失败", vbInformation
        txtResult.Text = "连接读卡设备失败！"
        cmdInstall.Enabled = True
    Case Is > 0:
        'MsgBox "OMR初始化成功", vbInformation
        txtResult.Text = "连接读卡设备成功！"
        OMR_Clear   '需调用多个格式文件时，仅在第一次时调用  OMR_Clear
        If OMR_LoadForm("C:\KSCJ200.sht", "") <> 0 Then
            MsgBox "不能装载格式文件--C:\KSCJ200.sht", vbCritical, "警告"
            cmdInstall.Enabled = True
        Else
            'MsgBox "装载格式文件成功", vbInformation, "提示"
            txtResult.Text = txtResult.Text & Chr(13) & Chr(10) & "加载格式文件成功！"
            cmdRead.Enabled = True
            Command1.Enabled = True
            cmdInstall.Enabled = False
        End If
         
    Case Else:
        MsgBox "请设置您的OMR设备类型", vbInformation
        cmdInstall.Enabled = True
    End Select
End Sub
Public Function Script(code As String) As String
    Dim obj As Object
    Set obj = CreateObject("MSScriptControl.ScriptControl")
    obj.AllowUI = True
    obj.Language = "JavaScript"
    Script = obj.Eval(code)
End Function
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
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