dbimpexp.frm

access数据库转换成excel表格

         Appearance      =   0  'Flat
         Caption         =   "..."
         Height          =   315
         Left            =   7230
         TabIndex        =   1
         TabStop         =   0   'False
         Top             =   870
         Width           =   255
      End
      Begin VB.Label lblFrom 
         Caption         =   "From:"
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   285
         Index           =   0
         Left            =   450
         TabIndex        =   8
         Top             =   900
         Width           =   585
      End
      Begin VB.Label lblTo 
         Caption         =   "To:"
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   225
         Index           =   0
         Left            =   660
         TabIndex        =   7
         Top             =   2250
         Width           =   345
      End
      Begin VB.Label lblTable 
         Caption         =   "Table"
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   255
         Index           =   0
         Left            =   1170
         TabIndex        =   6
         Top             =   1470
         Width           =   1185
      End
   End
   Begin VB.Label lblProgressMsg 
      Caption         =   "Don't disturb .....in progress with switched processes......"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00000080&
      Height          =   255
      Left            =   300
      TabIndex        =   54
      Top             =   120
      Width           =   6015
   End
   Begin VB.Menu mnuFile 
      Caption         =   "&File"
      Begin VB.Menu mnuImportFromExcelToOldTable 
         Caption         =   "&Import from Excel into existing table"
      End
      Begin VB.Menu mnuImportFromExcelToNewTable 
         Caption         =   "I&mport from Excel into a new table"
      End
      Begin VB.Menu mnuFileSep1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuExportToExcel 
         Caption         =   "&Export to Excel"
      End
      Begin VB.Menu mnuFileSep2 
         Caption         =   "-"
      End
      Begin VB.Menu mnuImportFromTxtSingleField 
         Caption         =   "Import &from text file (single field)"
      End
      Begin VB.Menu mnuExportToTxtSingleField 
         Caption         =   "Export &to text file (single field)"
      End
      Begin VB.Menu mnuFileSep3 
         Caption         =   "-"
      End
      Begin VB.Menu mnuImportFromTxtDelimited 
         Caption         =   "Import from text file (&delimted)"
      End
      Begin VB.Menu mnuFileSep4 
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileExit 
         Caption         =   "E&xit"
      End
   End
   Begin VB.Menu mnuHelp 
      Caption         =   "&Help"
      Begin VB.Menu mnuHelpHelp 
         Caption         =   "&Help"
      End
   End
End
Attribute VB_Name = "frmDBImpExp"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' DBImpExp.frm
'
' By Herman Liu
'
' A utility to import/export Access database from/to other application formats, e.g. Excel
' and text files.  With sample files and help, as well as ample remarks.
'
' It is advisable to run the sample files first (and read remarks in each frame). Once you
' are familiar with the pertinent rules, you may then begin to use the program to process
' your other files.
'
' In this program where a tables listing is required, the Enabled property of Textbox
' control is set to False, so as to enforce the use of Command button to select a MDB
' database file.
'
' In addition to the native DAO database (Access), DAO can access data from a number of
' other database or non-database sources, such as the ODBC databases (e.g. SQL server,
' Oracle, Sybase), Lotus spreadsheet, Excel table and the text file.
'
' There are basically three ways to open non-native databases: (a) open it directly, (b)
' attach it to a native database, and (c) create queries containing linking information
' (though differences exist in between, for example, between DAO SQL & ANSI SQL: "?" &
' "*" versus "_" & "%" in the LIKE operator).
'

Option Explicit

Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" _
    (ByVal lpszLongPath As String, ByVal lpszShortPath As String, _
    ByVal cchBuffer As Long) As Long

Dim cnn As adodb.Connection
Dim rs As adodb.Recordset
Dim rsSchema As adodb.Recordset
Dim cnnStr As String
Dim mFileSpec As String
Dim mSuspend As Boolean
Dim gCancel As Boolean
Dim gcdg As Object




Private Sub Form_Load()
    Dim i As Integer
    NoFrame
    Set cnn = New adodb.Connection
    Set rs = New adodb.Recordset
    
    cboDelimiter.Clear
    cboDelimiter.AddItem "Comma delimited"
    cboDelimiter.AddItem "Semicolon delimited"
    cboDelimiter.ListIndex = 0
    
    Set gcdg = CommonDialog1
End Sub



Private Sub mnuHelpHelp_Click()
     Dim tmp
     tmp = "HELP - Using sample files provided as an example" & vbCrLf & vbCrLf
     tmp = tmp & Chr(34) & "Import from Excel into existing table" & Chr(34) & vbCrLf
     tmp = tmp & "      Source: NoHeader.xls.  Target: ForTest.mdb.  Table to select: Address (as it has 14" & vbCrLf
     tmp = tmp & "      fields corresponding to 14 Excel columns.  But you may select to import less)." & vbCrLf & vbCrLf
     tmp = tmp & Chr(34) & "Import from Excel into new table" & Chr(34) & vbCrLf
     tmp = tmp & "      Source: HasHeader.xls.   Change default sheet name" & Chr(34) & "Sheet1" & Chr(34) & " if wanted.  Target:" & vbCrLf
     tmp = tmp & "      ForTest.mdb.   Type in the new table name or just use the default." & vbCrLf & vbCrLf
     tmp = tmp & Chr(34) & "Export to Excel" & Chr(34) & vbCrLf
     tmp = tmp & "      Source: Any Access file.  Target: Any new Excel name.   With headings or without." & vbCrLf & vbCrLf
     tmp = tmp & Chr(34) & "Import from text file (single field)" & Chr(34) & vbCrLf
     tmp = tmp & "      Source: SingleField.txt.  Target: ForTest.mdb.   Table can be any one, select a text field." & vbCrLf & vbCrLf
     tmp = tmp & Chr(34) & "Export to text file (single field)" & Chr(34) & vbCrLf
     tmp = tmp & "      Source: ForTest.mdb.  Select ForText table.   Target: Type in a text file name." & vbCrLf & vbCrLf
     tmp = tmp & Chr(34) & "Import text file (delimited)" & Chr(34) & vbCrLf
     tmp = tmp & "      Try it out yourself" & vbCrLf & vbCrLf
     tmp = tmp & "Read remarks in each frame, once you are familiar with the pertinent rules, you may then" & vbCrLf
     tmp = tmp & "begin to use the program to process your other files." & vbCrLf & vbCrLf
     MsgBox tmp
End Sub



Private Sub NoFrame()
    lblProgressMsg.Visible = False
    picBackGround.Visible = True
    fraImportFromExcelToOldTable.Visible = False
    fraImportFromExcelToNewTable.Visible = False
    fraExportToExcel.Visible = False
    fraImportFromTxtSingleField.Visible = False
    fraExportToTxtSingleField.Visible = False
    fraImportFromTxtDelimited.Visible = False
End Sub


Private Sub cmdExit_Click(Index As Integer)
    On Error Resume Next
    cnn.Close
    NoFrame
End Sub



Private Sub mnuFileExit_Click()
    Unload Me
End Sub



Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    On Error Resume Next
    Set cnn = Nothing
    Set rs = Nothing
    Set rsSchema = Nothing
End Sub



Private Sub mnuFile_Click()
    Dim OnOff As Boolean
    OnOff = picBackGround.Visible
    mnuImportFromExcelToOldTable.Enabled = OnOff
    mnuImportFromExcelToNewTable.Enabled = OnOff
    mnuExportToExcel.Enabled = OnOff
    mnuImportFromTxtSingleField.Enabled = OnOff
    mnuExportToTxtSingleField.Enabled = OnOff
End Sub




Private Function GetFileSpec(ByVal inExt As String) As String
    On Error GoTo errHandler
    GetFileSpec = ""
    With gcdg
         .DialogTitle = ""
         .DefaultExt = inExt
         .InitDir = App.Path
         .FileName = ""
         .Filter = "(*." & inExt & ")|*." & inExt & "|(*.*)|*.*"
         .FilterIndex = 0
         .CancelError = True
         .Flags = FileOpenConstants.cdlOFNHideReadOnly
         .ShowOpen
    End With
    GetFileSpec = gcdg.FileName
    Exit Function
errHandler:
    If Not Err = 32755 Then
         DBErrMsgProc ""
    End If
End Function



'-----------------------------------------------------
' Import Excel table into an existing Access table
'-----------------------------------------------------
Private Sub mnuImportFromExcelToOldTable_Click()
    NoFrame
    fraImportFromExcelToOldTable.Visible = True
    picBackGround.Visible = False
    cboTables1.Clear
    cboStartingFromFields.Clear
     ' Blank txtTargetSpec1, so as to force the use of Command button to select
     ' the MDB file - thus triggering Click event to execute instructions therein.
    txtTargetSpec1 = ""
    txtSourceSpec1.SetFocus
End Sub



Private Sub cmdImportFromExcelProceed1_Click()
    On Error GoTo errHandler
    
    Dim excelApp As Object
    Dim excelSheet As Object
    Dim mValue As Variant
    Dim colCount As Integer
    Dim fldCount As Integer
    Dim row, col
    Dim startingFieldNum
    Dim i
    
    If Len(txtSourceSpec1) = 0 Then
         MsgBox "No Excel file spec yet"
         Exit Sub
    ElseIf Not IsFileThere(txtSourceSpec1) Then
         MsgBox "Excel file not found"
         Exit Sub
    End If
    
    If Len(txtTargetSpec1) = 0 Then
         MsgBox "No Access file spec yet"
         Exit Sub
    ElseIf UCase(Right(txtTargetSpec1, 4)) <> ".MDB" Then
         MsgBox "DB file not with MDB extension"
         Exit Sub
    ElseIf Not IsFileThere(txtTargetSpec1) Then
         MsgBox "Access file not found"
         Exit Sub
    End If
    
    If Len(txtNumofCols) = 0 Then
         MsgBox Chr(34) & "No. of columns" & Chr(34) & " not entered yet"
         Exit Sub
    End If
    
    Screen.MousePointer = vbHourglass
    lblProgressMsg.Visible = True
    
    If cboTables1.ListCount = 0 Then
         Screen.MousePointer = vbDefault
         lblProgressMsg.Visible = False
         MsgBox "Access file has no table yet"
         Exit Sub
    End If
    
    fldCount = rs.Fields.Count
    If fldCount = 0 Then
           ' Don't close cnn, user may select another table, though unlikely another
           ' suitable one
         MsgBox "Table has no field yet"
         Exit Sub
    End If
    
    startingFieldNum = cboStartingFromFields.ListIndex
    
    If fldCount < Val(txtNumofCols) Then
         Screen.MousePointer = vbDefault
         lblProgressMsg.Visible = False
         If fldCount = 1 Then
              MsgBox "Table has only " & CStr(fldCount) & " field" & vbCrLf & _
                 "which is less then " & Chr(34) & "No. of Columns" & Chr(34) & " entered."
         Else
              MsgBox "Table has only " & CStr(fldCount) & " fields" & vbCrLf & _
                 "which is less then " & Chr(34) & "No. of Columns" & Chr(34) & " entered."
         End If
         Exit Sub
    ElseIf (fldCount - startingFieldNum) < Val(txtNumofCols) Then
         Screen.MousePointer = vbDefault
         lblProgressMsg.Visible = False
         MsgBox "Starting from the selected field, number of fields" & vbCrLf & _
             "is less then " & Chr(34) & "No. of Columns" & Chr(34)
         Exit Sub
    End If
    
       ' Test whether Excel object already exists
     On Error Resume Next
     Set excelApp = GetObject(, "Excel.Application")
     If Err.Number <> 0 Then
         Set excelApp = CreateObject("Excel.Application")
     End If
       ' (Note we leave On Error Resume Next to remain, to avoid potential
       ' complications, a value in a certain cell does not type of field
       ' does not match a field type)