frmexport.frm

考勤机管理软件,用于统计某段时间某个部门或者某个员工在某段内迟到与早退次数.

      Begin XCOMBOXLib.XCombox cmbTable 
         Height          =   300
         Left            =   1440
         TabIndex        =   10
         Top             =   315
         Width           =   1950
         _Version        =   65536
         _ExtentX        =   3440
         _ExtentY        =   300
         _StockProps     =   68
      End
      Begin VB.CommandButton cmdNext2 
         Caption         =   "下一步"
         Height          =   375
         Left            =   5805
         TabIndex        =   1
         Top             =   4770
         Width           =   1050
      End
      Begin VB.Label Label7 
         AutoSize        =   -1  'True
         Caption         =   "选择表:"
         Height          =   195
         Left            =   765
         TabIndex        =   11
         Top             =   360
         Width           =   585
      End
   End
   Begin VB.Frame Frame 
      Caption         =   "步骤3."
      Height          =   5415
      Index           =   3
      Left            =   1215
      TabIndex        =   7
      Top             =   2250
      Width           =   7350
      Begin MSComctlLib.ProgressBar ProgressBar 
         Height          =   240
         Left            =   1035
         TabIndex        =   9
         Top             =   2385
         Width           =   5145
         _ExtentX        =   9075
         _ExtentY        =   423
         _Version        =   393216
         Appearance      =   1
      End
      Begin VB.CommandButton cmdFinish 
         Caption         =   "完成"
         Height          =   375
         Left            =   4905
         TabIndex        =   8
         Top             =   3150
         Width           =   1050
      End
   End
End
Attribute VB_Name = "frmExport"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim tmpCon As New ADODB.Connection   '定义数据库的连接


Dim rstGrid As New ADODB.Recordset
Dim rstExec As New ADODB.Recordset

Dim ExcelApp As Excel.Application
Dim ExcelSheet As Excel.Worksheet
Dim ExcelWorkbook As Excel.Workbook
    
Dim m_FilePath As String
Dim m_way As Boolean

Private Sub Check1_Click()

End Sub

Private Sub Check_Click()
    
End Sub

Private Sub cmbOnClass_BtnsClick(ByVal nIndex As Integer)
    rstOnClass.Requery
    bufOnClass.DataSource = rstOnClass
    cmbOnClass.DataSource = bufOnClass
    
End Sub

Private Sub cmbTable_Selected()
    
    Dim sTable As String
    Dim i As Integer
    Dim Index As Long
    
    sTable = Trim(cmbTable.Text)
    
    cmbName.DeleteAllItem
    cmbCode.DeleteAllItem
    cmbCard.DeleteAllItem
    
    If LCase(Right(Trim(m_FilePath), 3)) = "xls" Then
    
            If Not (ExcelSheet Is Nothing) Then Set ExcelSheet = Nothing
            Set ExcelSheet = ExcelApp.ActiveWorkbook.Sheets(sTable)
            
        '=====================cmbName=======================
            
            For i = 1 To ExcelSheet.UsedRange.Columns.Count
                If Trim(ExcelSheet.Cells(1, i)) <> "" Then
                   Index = cmbName.AddString(ExcelSheet.Cells(1, i) + vbLf)
                   cmbName.SetItemData Index, i
                End If
            Next
            
        '=====================cmbCode=======================
            
            For i = 1 To ExcelSheet.UsedRange.Columns.Count
                If Trim(ExcelSheet.Cells(1, i)) <> "" Then
                   Index = cmbCode.AddString(ExcelSheet.Cells(1, i) + vbLf)
                   cmbCode.SetItemData Index, i
                End If
            Next
            
        '=====================cmbCard=======================
            
            For i = 1 To ExcelSheet.UsedRange.Columns.Count
                If Trim(ExcelSheet.Cells(1, i)) <> "" Then
                   Index = cmbCard.AddString(ExcelSheet.Cells(1, i) + vbLf)
                   cmbCard.SetItemData Index, i
                End If
            Next
        
        
    ElseIf LCase(Right(Trim(m_FilePath), 3)) = "mdb" Then
    
        If rstExec.State = adStateOpen Then rstExec.Close
        Set rstExec = Nothing
        rstExec.CursorLocation = adUseClient
        rstExec.Open "select top 1 * from " & sTable, tmpCon, adOpenStatic, adLockReadOnly
        

        
        For i = 0 To rstExec.Fields.Count - 1                     '   循环所有列
            cmbName.AddString rstExec.Fields(i).Name + vbLf          '字段名
            cmbCode.AddString rstExec.Fields(i).Name + vbLf
            cmbCard.AddString rstExec.Fields(i).Name + vbLf
        Next
        
    End If
    
    
End Sub

Private Sub cmbVac_BtnsClick(ByVal nIndex As Integer)
    rstVac.Requery
    bufVac.DataSource = rstVac
    cmbVac.DataSource = bufVac
End Sub

Private Sub cmdBack1_Click()
    HideFrame
    Frame(1).Visible = True
End Sub

Private Sub Form_Load()
    Me.Icon = MDI.Icon
    Me.Caption = "导入"
    
    Dim i As Integer
    For i = 1 To Frame.Count
        Frame(i).Move 60, 60
    Next
    
    Option1 = True
    Option3 = True
    txtBaseVal.MaxTextLen = 8
    txtBaseVal.Type = sNumber
    
    Me.Width = Frame(2).Width + 200
    Me.Height = Frame(2).Height + 600
    
    HideFrame
    Frame(1).Visible = True
    
    
End Sub


Private Sub SetOcx()
'=====================cmbName=======================
    cmbTable.DeleteAllItem
    cmbTable.ShowHeadScale = "0,20"
    cmbTable.ShowHeadValue = "DataID,表"
    cmbTable.ShowIndex = 1
    cmbTable.Type = tNormal
    cmbTable.DropWidth = cmbName.Width \ 15

'=====================cmbName=======================
    cmbName.DeleteAllItem
    cmbName.ShowHeadScale = "0,20"
    cmbName.ShowHeadValue = "DataID,某例"
    cmbName.ShowIndex = 1
    cmbName.Type = tNormal
    cmbName.DropWidth = cmbName.Width \ 15
'=====================cmbCode=======================
    cmbCode.DeleteAllItem
    cmbCode.ShowHeadScale = "0,20"
    cmbCode.ShowHeadValue = "DataID,某例"
    cmbCode.ShowIndex = 1
    cmbCode.Type = tNormal
    cmbCode.DropWidth = cmbCode.Width \ 15
'=====================cmbCard=======================
    cmbCard.DeleteAllItem
    cmbCard.ShowHeadScale = "0,20"
    cmbCard.ShowHeadValue = "DataID,某例"
    cmbCard.ShowIndex = 1
    cmbCard.Type = tNormal
    cmbCard.DropWidth = cmbCard.Width \ 15
    
'=====================cmbVac=======================
    cmbVac.DeleteAllItem
    cmbVac.ShowHeadScale = "0,20"
    cmbVac.ShowHeadValue = "VacID,休假名称"
    cmbVac.ShowIndex = 1
    cmbVac.Type = tStatic
    cmbVac.SetBtns "刷新"
    cmbVac.ButtonHeight = 20
    cmbVac.DropWidth = cmbVac.Width \ 15
    Set cmbVac.DataSource = bufVac
    
'=====================cmbOnClass=======================
    cmbOnClass.DeleteAllItem
    cmbOnClass.ShowHeadScale = "0,20"
    cmbOnClass.ShowHeadValue = "OnClassID,排班名称"
    cmbOnClass.ShowIndex = 1
    cmbOnClass.Type = tStatic
    cmbOnClass.SetBtns "刷新"
    cmbOnClass.ButtonHeight = 20
    cmbOnClass.DropWidth = cmbOnClass.Width \ 15
    Set cmbOnClass.DataSource = bufOnClass

End Sub


Private Sub cmdNext1_Click()
On Error GoTo openErr
        
    If Trim(txtPath.Text) = "" Then
        Message "请选择文件!"
        Exit Sub
    End If
    
    If Dir(Trim(txtPath.Text)) = "" Then
        Message "文件不存在!"
        Exit Sub
    End If
    
    m_FilePath = Trim(txtPath.Text)
    SetOcx
    
    If LCase(Right(Trim(m_FilePath), 3)) = "xls" Then

        
        If Not (ExcelWorkbook Is Nothing) Then Set ExcelWorkbook = Nothing
        If Not (ExcelApp Is Nothing) Then Set ExcelApp = Nothing

        Set ExcelApp = CreateObject("Excel.Application")
        Set ExcelWorkbook = ExcelApp.Workbooks.Open(m_FilePath)
        
        cmbTable.DeleteAllItem
       
        Dim i As Integer
        For i = 1 To ExcelWorkbook.Sheets.Count
            cmbTable.AddString ExcelWorkbook.Sheets.Item(i).Name + vbLf
        Next
        

        
    ElseIf LCase(Right(Trim(m_FilePath), 3)) = "mdb" Then
        
        Dim strSQL As String
        
        Dim rstSchema As ADODB.Recordset
        
        strSQL = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & m_FilePath & " ;Persist Security Info=False"
        If tmpCon.State = 1 Then tmpCon.Close
        tmpCon.Open strSQL
                      
                            
        Set rstSchema = tmpCon.OpenSchema(adSchemaTables)
              
        Do Until rstSchema.EOF
          cmbTable.AddString rstSchema!TABLE_NAME + vbLf
          rstSchema.MoveNext
        Loop
        
        If rstSchema.State = 1 Then rstSchema.Close
        Set rstSchema = Nothing
    
    End If
    

    HideFrame
    Frame(2).Visible = True
    Exit Sub
    
openErr:
     If InStr(Err.Description, "密码无效") <> 0 Then
        Message "请先去掉密码再导入!"
        Exit Sub
    End If