dbimpexp.frm

access数据库转换成excel表格

    
      ' Uncomment this line to make Excel visible.
     'excelApp.Visible = True

    excelApp.Workbooks.Open FileName:=txtSourceSpec1

      ' Check for later versions.
    If Val(excelApp.Application.Version) >= 8 Then
        Set excelSheet = excelApp.ActiveSheet
    Else
        Set excelSheet = excelApp
    End If
    
    colCount = columnCount(excelSheet, Val(txtNumofCols))
    excelApp.ActiveWorkbook.Close False
    excelApp.Quit
    Set excelSheet = Nothing
    Set excelApp = Nothing
    Screen.MousePointer = vbDefault
    If colCount = 0 Then
         MsgBox "No any column found in Excel table"
         Exit Sub
    ElseIf colCount < Val(txtNumofCols) Then
         MsgBox "Only " & CStr(colCount) & " columns found in Excel table" & vbCrLf & _
            "which is less then " & Chr(34) & "No. of Columns" & Chr(34) & " entered."
         Exit Sub
    End If
    
    row = 1
    BeginTrans
    Do
        If excelSheet.Cells(row, 1) Is Nothing Then
             Exit Do
        Else
             If excelSheet.Cells(row, 1) = Null Then
                  Exit Do
             ElseIf excelSheet.Cells(row, 1) = "" Then
               ' Chances are we will rely on this to exit loop
                  Exit Do
             End If
        End If
        
        rs.AddNew
        For col = 1 To Val(txtNumofCols)
               ' Check to limit to actual No. of fields available
             If col > fldCount Then
                  Exit For
             End If
             
               ' Test each col in the row
             If excelSheet.Cells(row, col) Is Nothing Then
                  Exit For                ' No more col, change row
             Else
                  If excelSheet.Cells(row, col) = Null Then
                       Exit For
                  ElseIf excelSheet.Cells(row, col) = "" Then
                       Exit For
                  End If
             End If
             
             mValue = excelSheet.Cells(row, col)
             rs.Fields(startingFieldNum + col - 1).Value = mValue
        Next col
        rs.Update
        If row = 100 Then
             CommitTrans
             BeginTrans
        End If
        row = row + 1
    Loop
    CommitTrans
    
      ' Close without saving
    excelApp.ActiveWorkbook.Close False
    excelApp.Quit
    Set excelSheet = Nothing
    Set excelApp = Nothing

      ' Note don't close cnn yet, user may click again
    Screen.MousePointer = vbDefault
    lblProgressMsg.Visible = False
    MsgBox "Copied " & CStr(row - 1) & " rows"
    Exit Sub
    
errHandler:
    Screen.MousePointer = vbDefault
    lblProgressMsg.Visible = False
    DBErrMsgProc ""
End Sub



'==========================================================================
' Remarks: You may try to make use of the following property values instead
'--------------------------------------------------------------------------
'row = inSheet.UsedRange.row
'col = inSheet.UsedRange.Column
'totalrows = inSheet.UsedRange.Rows.Count
'totalcols = inSheet.UsedRange.Columns.Count
'--------------------------------------------------------------------------
Private Function TestColumnNum(ByVal inSheet As Object) As Integer
    On Error Resume Next
    Dim col As Integer
    Dim row As Integer
    Dim ctn As Integer
    row = 1
     ' We start value outside main loop as we don't examine the
     ' examined columns here - to gain speed
    col = 1
    ctn = 0
    Do
        If inSheet.Cells(row, 1) Is Nothing Then
             Exit Do
        Else
             If inSheet.Cells(row, 1) = Null Then
                  Exit Do
             ElseIf inSheet.Cells(row, 1) = "" Then
               ' Chances are we will rely on this to exit loop
                  Exit Do
             End If
        End If
        
        Do
               ' Test each col in the row
             If inSheet.Cells(row, col) Is Nothing Then
                  Exit Do                ' No more col, change row
             Else
                  If inSheet.Cells(row, col) = Null Then
                       Exit Do
                  ElseIf inSheet.Cells(row, col) = "" Then
                       Exit Do
                  End If
             End If
             If ctn < col Then
                  ctn = ctn + 1
             End If
             col = ctn + 1
        Loop
        row = row + 1
          ' Limit the test of rows
        If row > 1000 Then
             Exit Do
        End If
    Loop
    TestColumnNum = ctn
End Function




Private Function columnCount(ByVal inSheet As Object, inNumofCols As Integer) As Integer
    On Error Resume Next
    Dim col As Integer
    Dim row As Integer
    Dim ctn As Integer
    row = 1
     ' We start value outside main loop as we don't examine the
     ' examined columns here - to gain speed
    col = 1
    ctn = 0
    Do
        If inSheet.Cells(row, 1) Is Nothing Then
             Exit Do
        Else
             If inSheet.Cells(row, 1) = Null Then
                  Exit Do
             ElseIf inSheet.Cells(row, 1) = "" Then
               ' Chances are we will rely on this to exit loop
                  Exit Do
             End If
        End If
        
        Do
               ' Don't waste time to go beyond
             If col > Val(inNumofCols) Then
                  Exit Do
             End If
               ' Test each col in the row
             If inSheet.Cells(row, col) Is Nothing Then
                  Exit Do                ' No more col, change row
             Else
                  If inSheet.Cells(row, col) = Null Then
                       Exit Do
                  ElseIf inSheet.Cells(row, col) = "" Then
                       Exit Do
                  End If
             End If
             If ctn < col Then
                  ctn = ctn + 1
             End If
             col = ctn + 1
        Loop
        row = row + 1
          ' Limit the test of rows
        If row > 1000 Then
             Exit Do
        End If
    Loop
    columnCount = ctn
End Function



Private Sub cmdGetSourceSpec1_Click()
    Dim excelApp As Object
    Dim excelSheet As Object
    Dim colCount As Integer
    mFileSpec = GetFileSpec("xls")
    If mFileSpec = "" Then
         Exit Sub
    End If
    If Not IsFileThere(mFileSpec) Then
         MsgBox mFileSpec & " not found"
         Exit Sub
    End If
    txtSourceSpec1.Text = mFileSpec
    
      ' Test available No. of columns and display it as default
    Screen.MousePointer = vbHourglass
    On Error Resume Next
    Set excelApp = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
         Set excelApp = CreateObject("Excel.Application")
    End If
    excelApp.Workbooks.Open FileName:=txtSourceSpec1
    If Val(excelApp.Application.Version) >= 8 Then
        Set excelSheet = excelApp.ActiveSheet
    Else
        Set excelSheet = excelApp
    End If
    colCount = TestColumnNum(excelSheet)
      ' Close without saving
    excelApp.ActiveWorkbook.Close False
    excelApp.Quit
    Set excelSheet = Nothing
    Set excelApp = Nothing
    Screen.MousePointer = vbDefault
    
    txtNumofCols = colCount
    txtNumofCols.SetFocus
End Sub



Private Sub cmdGetTargetSpec1_Click()
    On Error GoTo errHandler
    mFileSpec = GetFileSpec("mdb")
    If mFileSpec = "" Then
        Exit Sub
    End If
    If Not IsFileThere(mFileSpec) Then
         MsgBox mFileSpec & " not found"
         Exit Sub
    End If
    txtTargetSpec1 = mFileSpec
    
    Screen.MousePointer = vbHourglass
    
       ' Check if there is already a connection: In addition to changing cboTables1,
       ' the user may click Command button again to get another DB file while currently
       ' there is already a connection.  In this case, we have to close current cnn first.
       ' Since cboTables1 is cleared each time when the menu is invoked, so if we come
       ' here from the menu, cboTables1 should be an empty.  Otherwise, we have not
       ' not exited yet when we come here again.
    If cboTables1.ListCount > 0 Then
         cboTables1.Clear
         cboStartingFromFields.Clear
         cnn.Close
    End If
       
       ' For initial display of a tables listing
    cnnStr = "PROVIDER=Microsoft.Jet.OLEDB.3.51;" & "Data Source=" & _
            txtTargetSpec1 & ";"
    cnn.CursorLocation = adUseClient
    cnn.Open cnnStr
    
    mSuspend = True
    cboTables1.Clear
    Set rsSchema = cnn.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, "TABLE"))
    Do Until rsSchema.EOF
        If UCase(Left(rsSchema!Table_name, 4)) <> "MSYS" Then
           If UCase(Left(rsSchema!Table_name, 11)) <> "SWITCHBOARD" Then
               cboTables1.AddItem rsSchema!Table_name
           End If
        End If
        rsSchema.MoveNext
    Loop
    rsSchema.Close
    
    If cboTables1.ListCount = 0 Then
        Screen.MousePointer = vbDefault
        cnn.Close
        mSuspend = False
        MsgBox "Access file has no table yet"
        Exit Sub
    End If
    cboTables1.ListIndex = 0
    
    rs.Open "select * from [" & cboTables1.Text & "]", cnn, adOpenStatic, adLockOptimistic
    fillCboStartingfromFields1
    mSuspend = False
    
    Screen.MousePointer = vbDefault
    Exit Sub
    
errHandler:
    Screen.MousePointer = vbDefault
    If Err <> 32755 Then
        DBErrMsgProc ""
    End If
End Sub




Private Sub txtNumofCols_KeyPress(KeyAscii As Integer)
     KeyAscii = FilterNumericKey(KeyAscii)
End Sub



 ' If user changes cboTables1, update cboFields
Private Sub cboTables1_Click()
    On Error Resume Next
    If mSuspend = True Then Exit Sub
         'The followig does not allow update
     'Set rs = cnn.Execute("SELECT * FROM [" & cboTables1.Text & "]", 1, 1)
         ' If combo is filled there must be a connection currently, so it is
         ' safe to issue cnn.Close here
    cnn.Close
    cnnStr = "PROVIDER=Microsoft.Jet.OLEDB.3.51;" & "Data Source=" & _
            txtTargetSpec1 & ";" & adModeReadWrite
    cnn.CursorLocation = adUseClient
    cnn.Open cnnStr
    rs.Open "select * from [" & cboTables1.Text & "]", cnn, adOpenStatic, adLockOptimistic
    fillCboStartingfromFields1
End Sub



Private Sub fillCboStartingfromFields1()
    Dim i As Integer
    cboStartingFromFields.Clear
    For i = 0 To rs.Fields.Count - 1
         cboStartingFromFields.AddItem rs.Fields(i).Name
    Next i
    If cboStartingFromFields.ListCount > 0 Then
         cboStartingFromFields.ListIndex = 0
    End If
End Sub



'-----------------------------------------------------
' Import Excel table into a new Access table
'-----------------------------------------------------
Private Sub mnuImportFromExcelToNewTable_Click()
    NoFrame
    fraImportFromExcelToNewTable.Visible = True
    picBackGround.Visible = False
    cboTables2.Clear
    txtTargetSpec2.Text = ""
    txtNewTable2.Text = ""
    txtSourceSpec2.SetFocus
End Sub



Private Sub cmdImportFromExcelProceed2_Click()
    On Error GoTo errHandler
    Dim db As Database
    Dim excelApp As Object
    Dim excelSheet As Object
    Dim colCount As Integer
    Dim i As Integer, j As Integer
    
    If Len(txtSourceSpec2) = 0 Then
         MsgBox "No Excel file spec yet"
         Exit Sub
    ElseIf Not IsFileThere(txtSourceSpec2) Then
         MsgBox "Excel file not found"
         Exit Sub
    End If
    
    If Len(txtTargetSpec2) = 0