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 = 0IsReading = FalseMyTimer.Interval = 50MyCount = 0MyText = ""getMyList ("")
End Sub
'取得控件版本
Public Sub getVersion()MsgBox "光标阅读机控件V 1.0.1"
End Sub
Private Sub cmdRead_Click()If IsReading ThenOMR_StopReadOMR_StopMotorcmdRead.Caption = "阅　读"MyTimer.Enabled = FalseIsReading = FalseElseIf OMR_ReadNoWait() = 0 Then    'OKcmdRead.Caption = "停止阅读"MyTimer.Enabled = TrueIsReading = TrueElsetxtResult.Text = Space(100)strlen = OMR_CRetMess(OMR_GetLastError(), txtResult.Text)MsgBox txtResult.Text, vbCritical, "阅读失败"End IfEnd If
End Sub
'-----------读卡设备断开--------------
Private Sub Command1_Click()cmdInstall.Enabled = TrueCommand1.Enabled = FalsecmdRead.Enabled = FalseOMR_StopReadOMR_StopMotorOMR_ClosetxtResult.Text = txtResult.Text & Chr(13) & Chr(10) & "读卡设备断开！"txtResult.SelStart = Len(txtResult)
End Sub
Private Sub MyTimer_Timer()Dim sResultStr As StringDim lResultNum As LongDim sUserID As String   '准考证号码MyTimer.Enabled = FalseSelect Case OMR_IsReading()Case 0:     '阅读完毕sResultStr = Space(1000)lResultNum = OMR_GetResult(sResultStr, True)MyText = Mid(sResultStr, 1, 300) '取得有效文本If Check1 = Checked ThenOMR_StopMotorcmdRead.Caption = "阅　读"MyTimer.Enabled = FalseIsReading = FalsetxtResult.Text = txtResult.Text & "【" & MyTexttxtResult.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 IfElsesUserID = Mid(sResultStr, 2, 19) '取得准考证号码txtResult.Text = txtResult.Text & Chr(13) & Chr(10) & "【" & sUserIDtxtResult.Text = txtResult.Text & "】"txtResult.SelStart = Len(txtResult)'----------判断是否是正确的准考证----------If (InStr(sUserID, " ") > 0) ThenOMR_StopMotorcmdRead.Caption = "阅　读"MyTimer.Enabled = FalseIsReading = FalsetxtResult.Text = txtResult.Text & "ERROR 1：准考证填写错误！"txtResult.SelStart = Len(txtResult)UserControl.Parent.Script.myAlert ("ERROR 1：准考证填写错误！")ElseIf (InStr(MyList, sUserID) <= 0) ThenOMR_StopMotorcmdRead.Caption = "阅　读"MyTimer.Enabled = FalseIsReading = FalsetxtResult.Text = txtResult.Text & "ERROR 2：准考证不存在！"txtResult.SelStart = Len(txtResult)UserControl.Parent.Script.myAlert ("ERROR 2：准考证不存在！")ElseIf (InStr(MyListed, sUserID) > 0) ThenOMR_StopMotorcmdRead.Caption = "阅　读"MyTimer.Enabled = FalseIsReading = FalsetxtResult.Text = txtResult.Text & "ERROR 3：准考证号码重复！"txtResult.SelStart = Len(txtResult)UserControl.Parent.Script.myAlert ("ERROR 3：准考证号码重复！")ElseMyListed = MyListed & "," & sUserID '记录已经读取的准考证号码MyCount = MyCount + 1 '累计读取卡片数Label2.Caption = MyCount   '显示读卡数If Left(sResultStr, 1) = "O" ThenIf OMR_ReadNoWait() = 0 Then    'OKcmdRead.Caption = "停止阅读"MyTimer.Enabled = TrueIsReading = 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 IfElseMsgBox "阅读失败", vbCritical, "警告"End IfElseOMR_StopMotorcmdRead.Caption = "阅　读"MyTimer.Enabled = FalseIsReading = FalsesResultStr = Space(100)strlen = OMR_CRetMess(OMR_GetLastError(), sResultStr)txtResult.Text = sResultStrEnd IfEnd IfEnd IfCase -1:    '阅读失败cmdRead.Caption = "阅　读"MyTimer.Enabled = FalseIsReading = FalsesResultStr = Space(100)strlen = OMR_CRetMess(OMR_GetLastError(), sResultStr)txtResult.Text = sResultStrMsgBox sResultStr, vbCritical, "阅读失败"Case 1:     '正在阅读End Select'-----------------IsReading时启动timer----------------If IsReading ThenMyTimer.Enabled = TrueEnd If
End Sub
'-----------------取得所有的准考证号码-----------------
Public Sub getMyList(str)If Len(str) > 0 ThenMyList = strElseMyList = Text1.TextEnd If
End Sub
'-----------------初始化设备并加载格式文件-------------------
Public Sub cmdInstall_Click()cmdInstall.Enabled = FalseDevice = OMR_Installed(0)Select Case DeviceCase Is = 0:'MsgBox "初始化失败", vbInformationtxtResult.Text = "连接读卡设备失败！"cmdInstall.Enabled = TrueCase Is > 0:'MsgBox "OMR初始化成功", vbInformationtxtResult.Text = "连接读卡设备成功！"OMR_Clear   '需调用多个格式文件时，仅在第一次时调用  OMR_ClearIf OMR_LoadForm("C:\KSCJ200.sht", "") <> 0 ThenMsgBox "不能装载格式文件--C:\KSCJ200.sht", vbCritical, "警告"cmdInstall.Enabled = TrueElse'MsgBox "装载格式文件成功", vbInformation, "提示"txtResult.Text = txtResult.Text & Chr(13) & Chr(10) & "加载格式文件成功！"cmdRead.Enabled = TrueCommand1.Enabled = TruecmdInstall.Enabled = FalseEnd IfCase Else:MsgBox "请设置您的OMR设备类型", vbInformationcmdInstall.Enabled = TrueEnd Select
End Sub
Public Function Script(code As String) As StringDim obj As ObjectSet obj = CreateObject("MSScriptControl.ScriptControl")obj.AllowUI = Trueobj.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 LongDim rClsId  As udtGUIDDim IID     As StringDim bIID()  As BytepdwSupportedOptions = INTERFACESAFE_FOR_UNTRUSTED_CALLER Or _INTERFACESAFE_FOR_UNTRUSTED_DATAIf (riid <> 0) ThenCopyMemory rClsId, ByVal riid, Len(rClsId)bIID = String$(MAX_GUIDLEN, 0)Rc = StringFromGUID2(rClsId, VarPtr(bIID(0)), MAX_GUIDLEN)Rc = InStr(1, bIID, vbNullChar) - 1IID = Left$(UCase(bIID), Rc)Select Case IIDCase IID_IDispatchpdwEnabledOptions = IIf(m_fSafeForScripting, _INTERFACESAFE_FOR_UNTRUSTED_CALLER, 0)Exit SubCase IID_IPersistStorage, IID_IPersistStream, _IID_IPersistPropertyBagpdwEnabledOptions = IIf(m_fSafeForInitializing, _INTERFACESAFE_FOR_UNTRUSTED_DATA, 0)Exit SubCase ElseErr.Raise E_NOINTERFACEExit SubEnd SelectEnd If
End Sub
Private Sub IObjectSafety_SetInterfaceSafetyOptions(ByVal riid As _Long, ByVal dwOptionsSetMask As Long, ByVal dwEnabledOptions As Long)Dim Rc          As LongDim rClsId      As udtGUIDDim IID         As StringDim bIID()      As ByteIf (riid <> 0) ThenCopyMemory rClsId, ByVal riid, Len(rClsId)bIID = String$(MAX_GUIDLEN, 0)Rc = StringFromGUID2(rClsId, VarPtr(bIID(0)), MAX_GUIDLEN)Rc = InStr(1, bIID, vbNullChar) - 1IID = Left$(UCase(bIID), Rc)Select Case IIDCase IID_IDispatchIf ((dwEnabledOptions And dwOptionsSetMask) <> _INTERFACESAFE_FOR_UNTRUSTED_CALLER) ThenErr.Raise E_FAILExit SubElseIf Not m_fSafeForScripting ThenErr.Raise E_FAILEnd IfExit SubEnd IfCase IID_IPersistStorage, IID_IPersistStream, _IID_IPersistPropertyBagIf ((dwEnabledOptions And dwOptionsSetMask) <> _INTERFACESAFE_FOR_UNTRUSTED_DATA) ThenErr.Raise E_FAILExit SubElseIf Not m_fSafeForInitializing ThenErr.Raise E_FAILEnd IfExit SubEnd IfCase ElseErr.Raise E_NOINTERFACEExit SubEnd SelectEnd If
End Sub