form呀.frm

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

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmxhdc 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "导出填涂信息（标答/所选）"
   ClientHeight    =   2160
   ClientLeft      =   45
   ClientTop       =   435
   ClientWidth     =   7635
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2160
   ScaleWidth      =   7635
   StartUpPosition =   3  '窗口缺省
   Begin VB.Frame Frame1 
      Caption         =   "导出分数为EXCEL文件"
      Height          =   1935
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   7335
      Begin VB.TextBox textFilePath 
         BeginProperty Font 
            Name            =   "楷体_GB2312"
            Size            =   15.75
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   495
         Left            =   2520
         TabIndex        =   4
         Top             =   480
         Width           =   2175
      End
      Begin VB.CommandButton cmdOK 
         Caption         =   "导  出"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   10.5
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   495
         Left            =   3000
         TabIndex        =   3
         Top             =   1200
         Width           =   1455
      End
      Begin VB.CommandButton cmdCancel 
         Caption         =   "取  消"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   10.5
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   495
         Left            =   5160
         TabIndex        =   2
         Top             =   1200
         Width           =   1455
      End
      Begin VB.CommandButton cmdPath 
         Caption         =   "..."
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   10.5
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   495
         Left            =   5160
         TabIndex        =   1
         Top             =   480
         Width           =   1455
      End
      Begin MSComDlg.CommonDialog CommonDialog1 
         Left            =   5520
         Top             =   2040
         _ExtentX        =   847
         _ExtentY        =   847
         _Version        =   393216
      End
      Begin VB.Label Label2 
         BackColor       =   &H00FFC0C0&
         BackStyle       =   0  'Transparent
         Caption         =   "请选择保存文件名:"
         BeginProperty Font 
            Name            =   "楷体_GB2312"
            Size            =   12
            Charset         =   134
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   495
         Left            =   120
         TabIndex        =   5
         Top             =   600
         Width           =   2175
      End
   End
End
Attribute VB_Name = "frmxhdc"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public strFilepath As String
Private Sub cmdCancel_Click()
Unload Me
End Sub

Private Sub cmdOK_Click()
 Dim i As Integer
    Dim rsobj As New ADODB.Recordset
    Dim sql As String
   Dim yyji As String
                     Dim bdji 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 lx,kh,ttxx from ttxx "
        Set rsobj = TransactSQL(sql)
        If rsobj.EOF = False Then '判断是否有统计记录
    
                     
    
    Dim sqln As Integer
                      Dim rsn As ADODB.Recordset
                      Dim lx As String
                      lx = rsobj(0)
                      sqln = "select jieguo from bdkey where lx='" & lx & "'"
                      Set rsn = getRS(sqln)
                      If rsn.RecordCount = 0 Then
                        MsgBox "无标准答案！", vbOKOnly, "提示"
                        Exit Sub
                        Else
                        bdji = rsn(0)
                        Debug.Print bdji
                      End If
    
    
    
            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.Cells(2, 3).Value = "标答与添涂选择"
                oSheet.Columns("A:A").ColumnWidth = 12
                oSheet.Columns("B:B").ColumnWidth = 20
                 oSheet.Columns("C:C").ColumnWidth = 20
                rsobj.MoveFirst
                For i = 3 To rsobj.RecordCount + 2
                      
                    oSheet.Cells(i, 1).Value = rsobj(0)
                    oSheet.Cells(i, 2).Value = rsobj(1)
                     yyji = rsobj(2)
                     Dim aa  As String
                     Dim bb As String
                     Dim keynew As String
                     Dim m As Integer
                     For m = 1 To 200
                     aa = Mid(yyji, m, 1)
                     bb = Mid(bdji, m, 1)
                     keynew = keynew & aa & bb & "&"
                     Next m
                     oSheet.Cells(i, 3).Value = keynew
                    
                     rsobj.MoveNext
                Next i
                
            With oSheet                                                         '设置边框
                  
                  .Range(.Cells(1, 1), .Cells(rsobj.RecordCount + 2, 6)).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