ActiveX(VB6)+JavaScript让ＩＥ浏览器与光标阅读器交互
代码开源，欢迎指导。
注意点： ie8 activex 回调 javascript中，不能有 window.console.log();否则会报错。 activex注册步骤 1.IE加入信任 2.信任允许activex 3.copy all dll to system32 4.regsvr32 MyProject.ocx |
/*
*ActiveX回调考生填写理论答案
*/
function setReadText(str){
try{
var c5=str.slice(1,20);//准考证号码
var rightcode=eval("("+$("#column44").val()+")");
var rtotal =rightcode.rows.length;//总题目数
var myresult=str.slice(23,rtotal+23);//考生答案
var myscore=0;//考生总得分
for(var i=0; i<rightcode.rows.length; i++)
{
var myselect=getOptions(myresult.slice(i,i+1));//考生选择的ABCDE
if(rightcode.rows[i].rowtype=='知识类选择题'){
if(myselect==rightcode.rows[i].rowresult){//得分
myscore=parseFloat(myscore)+parseFloat(rightcode.rows[i].rowsnewscore);
myscore=parseFloat(myscore).toFixed(1)
}
}else if(rightcode.rows[i].rowtype=='离散单选'){
if (myselect=="A"){
myscore=parseFloat(myscore)+parseFloat(rightcode.rows[i].rowa)*parseFloat(rightcode.rows[i].rowsnewscore);
}else if(myselect=="B"){
myscore=parseFloat(myscore)+parseFloat(rightcode.rows[i].rowb)*parseFloat(rightcode.rows[i].rowsnewscore);
}else if(myselect=="C"){
myscore=parseFloat(myscore)+parseFloat(rightcode.rows[i].rowc)*parseFloat(rightcode.rows[i].rowsnewscore);
}else if(myselect=="D"){
myscore=parseFloat(myscore)+parseFloat(rightcode.rows[i].rowd)*parseFloat(rightcode.rows[i].rowsnewscore);
}else if(myselect=="E"){
myscore=parseFloat(myscore)+parseFloat(rightcode.rows[i].rowe)*parseFloat(rightcode.rows[i].rowsnewscore);
}
myscore=parseFloat(myscore).toFixed(1);
}
}
//将保存考生成绩
myscore=parseFloat(myscore).toFixed(1);
$.post("table40/table40Action!updTable40Column89ByColumn5.action", {
column5 : c5,
column11 : myscore,
column76 : '1',
column89 : str
}, function(data) {
if (data == 0) {
//window.console.log("保存成绩失败!");
} else {
//window.console.log("success," + data + "考生理论得分：" + myscore);
}
});
}catch(err){
alert(err);
//window.console.log(err);
}
}
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