frminput.frm

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

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Object = "{0ECD9B60-23AA-11D0-B351-00A0C9055D8E}#6.0#0"; "MSHFLXGD.OCX"
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Begin VB.Form frminput 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "导入数据库"
   ClientHeight    =   4380
   ClientLeft      =   4785
   ClientTop       =   3345
   ClientWidth     =   4995
   Icon            =   "frminput.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4380
   ScaleWidth      =   4995
   Begin VB.Frame Frame1 
      Height          =   3615
      Left            =   120
      TabIndex        =   5
      Top             =   0
      Width           =   4815
      Begin VB.CommandButton cmdinput 
         Caption         =   "文件导入"
         Height          =   495
         Left            =   3240
         TabIndex        =   9
         Top             =   720
         Width           =   1335
      End
      Begin VB.CommandButton Command1 
         Caption         =   "清空数据库"
         Height          =   495
         Left            =   3240
         TabIndex        =   7
         Top             =   1560
         Width           =   1335
      End
      Begin VB.CommandButton Command2 
         Caption         =   "退出"
         Height          =   495
         Left            =   3240
         TabIndex        =   6
         Top             =   2520
         Width           =   1215
      End
      Begin MSHierarchicalFlexGridLib.MSHFlexGrid MSHFlexGrid1 
         Height          =   2895
         Left            =   240
         TabIndex        =   8
         Top             =   480
         Width           =   2535
         _ExtentX        =   4471
         _ExtentY        =   5106
         _Version        =   393216
         BackColor       =   16777215
         Cols            =   1
         FixedCols       =   0
         BackColorSel    =   -2147483639
         GridColorFixed  =   8388608
         FillStyle       =   1
         _NumberOfBands  =   1
         _Band(0).Cols   =   1
      End
   End
   Begin ComctlLib.ProgressBar Prginput 
      Height          =   375
      Left            =   240
      TabIndex        =   0
      Top             =   3720
      Width           =   2535
      _ExtentX        =   4471
      _ExtentY        =   661
      _Version        =   327682
      Appearance      =   1
   End
   Begin MSComDlg.CommonDialog cdlinput 
      Left            =   6360
      Top             =   0
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.Label Label4 
      Height          =   255
      Left            =   1080
      TabIndex        =   4
      Top             =   4440
      Width           =   855
   End
   Begin VB.Label Label1 
      Caption         =   "纪录"
      Height          =   255
      Left            =   1800
      TabIndex        =   3
      Top             =   4200
      Width           =   375
   End
   Begin VB.Label Label3 
      Caption         =   "0"
      Height          =   255
      Left            =   1200
      TabIndex        =   2
      Top             =   4200
      Width           =   735
   End
   Begin VB.Label Label2 
      Caption         =   "共导入"
      Height          =   255
      Left            =   600
      TabIndex        =   1
      Top             =   4200
      Width           =   615
   End
End
Attribute VB_Name = "frminput"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub cmdinput_Click()
          '导入按钮
    Dim tempxlApp As New excel.Application
    Dim tempxlWorkbook As New excel.Workbook
    Dim tempxlSheet As New excel.Worksheet
    
    Dim strXlsName As String           'Excel 文件名
    Dim strSheet As String             '表名
    Dim strname As String
    Dim strTmp As String
    Dim rsViewP As ADODB.Recordset
    Dim n As Integer                   '行数
    Dim i As Integer
  On Error Resume Next
    
    cdlinput.CancelError = True                   'cdlInPut为CommonDialog控件
    
    '属性DialogTitle是要弹出的对话框的标题
    cdlinput.DialogTitle = "选择 Microsoft Excel 文件"
    
    '缺省的文件名为空
    cdlinput.FileName = ""
    cdlinput.Filter = "Excel 文件 (*.xls)|*.xls"
    
    'Flags属性的用法依据不同的对话框而变
    cdlinput.Flags = cdlOFNHideReadOnly + cdlOFNFileMustExist
    cdlinput.ShowOpen
    If Err = cdlCancel Then Exit Sub
    Dim strpicname As String
    strpicname = cdlinput.FileName
    
    strSheet = Trim(InputBox("请指定所打开的Excel文件中的一个工作表,如excel1：", "指定工作表"))
    If strSheet = "" Then
        MsgBox ("你必须指定一个工作表！如excel1"), vbOKOnly + vbExclamation, "提醒！"
        Exit Sub
    End If
    n = InputBox("输入需导入行数：", "行数", 6295)
    Prginput.Visible = True                           'prgInput为进程条控件
    Prginput.Max = n
    '打开Excel 文件
    Set tempxlWorkbook = tempxlApp.Workbooks.Open(strpicname)
    tempxlApp.DisplayAlerts = False
    Set tempxlSheet = tempxlWorkbook.Worksheets(strSheet)
    tempxlSheet.Select
    
    Prginput.Value = 1
    '把Excel表格中的数据导入表EachDay
    For i = 2 To n + 1
         Dim strcode As String                '准考证号码
        strcode = tempxlSheet.Cells(i, 1)
        If strcode = "" Then
                 Set tempxlSheet = Nothing
                 Set tempxlWorkbook = Nothing
                  tempxlApp.quit
                 Set tempxlApp = Nothing
                    Prginput.Value = n
                    Prginput.Visible = False
        Exit Sub
        End If
        Dim sql As String
        Dim rs As ADODB.Recordset
            sql = "select * from kh  where kh='" & strcode & "'"
            Set rs = getRS(sql)
            If rs.EOF = True Then
                '把记录添加到kh表中
                rs.AddNew
                rs.Fields(0) = strcode
                rs.Update
                rs.Close
            Else
                MsgBox ("此准考证号码已经存在！号码：" & strcode), vbOKOnly + vbExclamation, "提醒！"
            End If
            rs.Close
        Prginput.Value = i - 2
    Next i
    sql = "select *  from kh"
    Call showtopic
    Call showdata(sql)
    '释放对象,关闭excel
    Set tempxlSheet = Nothing
    Set tempxlWorkbook = Nothing
    tempxlApp.quit
    Set tempxlApp = Nothing
    
    Prginput.Value = n
    Prginput.Visible = False
    Label3.Caption = n
    showdata (sql)
End Sub
Public Sub showdata(strquery As String)
     Dim rs As ADODB.Recordset
     Dim num As Integer
    Set rs = getRS(strquery)
      num = rs.RecordCount
     If rs.RecordCount = 0 Then
           With Me.MSHFlexGrid1
               .Rows = 0
               Call showtopic
           End With
          Label4.Caption = num
     Else
        With Me.MSHFlexGrid1
        .Rows = 1
               While Not rs.EOF
                    .Rows = .Rows + 1
                    .TextMatrix(.Rows - 1, 0) = rs(0)
                    rs.MoveNext
                Wend
         End With
        
         Label4.Caption = num
         rs.Close
         Prginput.Visible = False
        End If
        Dim a As String
       
End Sub
Public Sub showtopic()
Dim i As Integer
    
With Me.MSHFlexGrid1
        .Rows = 1
       .TextMatrix(0, 0) = "准考证号码"
      .ColWidth(0) = 1200
      .Rows = 1
     End With
End Sub

Private Sub Command1_Click()
    Dim answer As String
answer = MsgBox("确定要清空数据库中的所有数据吗？清空后将无法恢复", vbYesNo, "警告")
If answer = vbYes Then
sql = "delete  * from kh"
Dim rs As ADODB.Recordset
  TransactSQL (sql)
sql = "select * from kh"
Call showtopic
End If
End Sub

Private Sub Command2_Click()
  Unload Me
End Sub

Private Sub Form_Load()
Dim sql As String
sql = "select kh  from  kh "
Call showtopic
Call showdata(sql)
End Sub