frmexcel.frm

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

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmexcel 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "输出分数数据库（*.EXCEL)"
   ClientHeight    =   2280
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   7620
   Icon            =   "frmexcel.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2280
   ScaleWidth      =   7620
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  '窗口缺省
   Begin VB.Frame Frame1 
      Caption         =   "导出分数为EXCEL文件"
      Height          =   1935
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   7335
      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        =   4
         Top             =   480
         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        =   3
         Top             =   1200
         Width           =   1455
      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        =   2
         Top             =   1200
         Width           =   1455
      End
      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        =   1
         Top             =   480
         Width           =   2175
      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 = "frmexcel"
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 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,fs from fs "
        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.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)
                     oSheet.Cells(i, 3).Value = rsobj(2)
                     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