frmkey.frm

此源码是针对配套的光学标记阅读机使用

Private Sub cmdOK_Click()
 Dim i As Integer
    Dim rsobj As New ADODB.Recordset
    Dim sql As String
   
    Dim oExcel As Object
    Dim oBook As Object
    Dim oSheet As Object
    
On Error GoTo Command1_Click_Error
    If Me.textFilePath = "" Then                                               '判断输入
        MsgBox "请选择文件保存位置！", vbOKOnly + vbExclamation, "提示！"
    Else
        sql = "select * from bdkey "
        Set rsobj = TransactSQL(sql)
        If rsobj.EOF = False Then                                              '判断是否有统计记录
        
            Set oExcel = CreateObject("Excel.Application")
            Set oBook = oExcel.Workbooks.add
            Set oSheet = oBook.Worksheets(1)
            Set oSheet = oExcel.Application.Workbooks(1).Worksheets("Sheet1")
                 
            oSheet.Range("A1:B1").Select                                       '设置单元格
            With oExcel.Selection
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlBottom
                .WrapText = False
                .Orientation = 0
                .AddIndent = False
                .ShrinkToFit = False
                .MergeCells = False
            End With
            
            oExcel.Selection.Merge                                            '设置标题
            oSheet.Range("A1:B1").Select
            oExcel.ActiveCell.FormulaR1C1 = "标准答案填涂信息"
            
            With oExcel.ActiveCell.Characters(Start:=1, Length:=26).Font
                .Name = "宋体"
                .FontStyle = "加粗"
                .Size = 18
                .Strikethrough = False
                .Superscript = False
                .Subscript = False
                .OutlineFont = False
                .Shadow = False
                .Underline = xlUnderlineStyleNone
                .ColorIndex = xlAutomatic
            End With
            
            Set oSheet = oExcel.Application.Workbooks(1).Worksheets("Sheet1") '设置表格
            
    
                oSheet.Cells(2, 1).Value = " "
                oSheet.Cells(2, 2).Value = "答案填涂信息"
                oSheet.Columns("A:A").ColumnWidth = 10
                oSheet.Columns("B:B").ColumnWidth = 250
               
               
                rsobj.MoveFirst
                For i = 3 To rsobj.RecordCount + 2
                    oSheet.Cells(i, 1).Value = rsobj(0)
                    oSheet.Cells(i, 2).Value = rsobj(1)
                  
                   
                    rsobj.MoveNext
                Next i
                
            With oSheet                                                         '设置边框
                .Range(.Cells(1, 1), .Cells(rsobj.RecordCount + 2, 2)).Borders.LineStyle = xlContinuous
            End With
            
            oBook.SaveAs strFilepath                                            '保存文件
            
            If MsgBox("是否转到导出的Excel文件？", vbOKCancel) = vbOK Then
            Unload Me
            oExcel.Visible = True
            Else
            MsgBox "已经成功导出记录！", vbOKOnly + vbExclamation, "提示！"
            Unload Me
            End If
            Exit Sub
        Else
            MsgBox "数据库中没有记录！", vbOKOnly + vbExclamation, "提示！"
            Me.ZOrder 0
        End If
    End If
Command1_Click_Error:
    Exit Sub
End Sub

Private Sub cmdPath_Click()
 CommonDialog1.CancelError = True
On Error GoTo ErrHandler
    CommonDialog1.Flags = cdlOFNHideReadOnly
    CommonDialog1.Filter = "All Files (*.*)|*.*|Excel Files" & _
    "(*.xls)|*.xls"
    CommonDialog1.FilterIndex = 2
    CommonDialog1.ShowSave
    Me.textFilePath = CommonDialog1.FileName
    strFilepath = CommonDialog1.FileName                            '设置保存路径
    Exit Sub

ErrHandler:
    Exit Sub
End Sub

Private Sub cmdread_Click()
    Dim strlen As Long
    txtResult.Text = " "
    If IsReading Then
        OMR_StopRead
        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()
Unload Me

End Sub

Private Sub Command2_Click()
Dim answer As String
answer = MsgBox("确定要清空标准答案数据库吗？清空后将无法恢复", vbYesNo, "警告")
If answer = vbYes Then

Dim rs As ADODB.Recordset
sql = "delete * from bdkey"
TransactSQL (sql)
MsgBox "数据库已经清空！", vbOKOnly + vbExclamation
End If
End Sub

Private Sub Command3_Click()
   Frame3.Enabled = True
   Dim sql As String
    sql = "select lx from bdkey"
    Set rs = getRS(sql)

    If rs.RecordCount = 0 Then
      Me.Cmbtype.AddItem "", 0
    Else
       For i = 1 To rs.RecordCount
       If rs(0) = "" Then
         Me.Cmbtype.AddItem "未知", i - 1
       Else
          Me.Cmbtype.AddItem rs(0), i - 1
          
       End If
      rs.MoveNext
      
   Next i

rs.Close
End If
End Sub

Private Sub Form_Load()
    IsReading = False
    'MyTimer.Enabled = True
    mytimer.Interval = 50
    Me.txtResult.Text = ""
    Frame3.Enabled = False
    
End Sub

Private Sub MyTimer_Timer()
 
    Dim sResultStr As String
    Dim lResultNum As Long
    mytimer.Enabled = False
    Select Case OMR_IsReading()
    Case 0:     '阅读完毕
        sResultStr = Space(2000)
        lResultNum = OMR_GetResult(sResultStr, True)
       ' If Len(txtResult.Text) > 0 Then
        '    txtResult.Text = txtResult.Text & Chr(13) & Chr(10) & sResultStr
       ' Else
        '    txtResult.Text = sResultStr
       ' End If
        If Left(sResultStr, 1) = "O" Then
               sResultStr = Mid(sResultStr, 2)
                 txtResult.Text = Mid(sResultStr, 1, 200)
                 Call savekey(sResultStr)
            If OMR_ReadNoWait() = 0 Then    'OK
                cmdread.Caption = "停止阅读"
                mytimer.Enabled = True
                IsReading = True
            Else
                MsgBox "阅读失败", vbCritical, "警告"
            End If
        Else
            cmdread.Caption = "阅读标准答案"
            mytimer.Enabled = False
            IsReading = False
            sResultStr = Space(100)
            strlen = OMR_CRetMess(OMR_GetLastError(), sResultStr)
            txtResult.Text = sResultStr
        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
    
    mytimer.Enabled = True
End Sub

Private Sub TabStrip1_Click()

End Sub
Public Sub showtopic(jieguo As String)
Dim i As Integer
 Dim bd As String
With Me.MSHFlexGrid1
        .Rows = 201
       .TextMatrix(0, 0) = "题数"
       .TextMatrix(0, 1) = "答案"
       For i = 1 To 200
           bd = Mid(jieguo, i, 1)
           bd = cosde(bd)
         .TextMatrix(i, 0) = i
         .TextMatrix(i, 1) = bd
       Next i
       
      .ColWidth(0) = 600
      .ColWidth(1) = 1000
     
     End With
End Sub
Public Sub showbd(jieguo As String)
    With Me.MSHFlexGrid1
           Dim bd As String
           For i = 1 To 200
               bd = Mid(jieguo, i, 1)
                bd = cosde(bd)
             .TextMatrix(i, 1) = bd
        Next i
    End With
End Sub