• Home
 · 
• Databases/Data Access/DAO/ADO
 · 
• This program exports the data from MySQL to the following 3 formats 1.Ms-Access Database. 2.Text Fi

This program exports the data from MySQL to the following 3 formats 1.Ms-Access Database. 2.Text Fi

This program exports the data from MySQL to the following 3 formats 1.Ms-Access Database. 2.Text File 3.Excel File It has 2 modules and 3

Rate This program exports the data from MySQL to the following 3 formats 1.Ms-Access Database. 2.Text Fi

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

Option Explicit

Public g_sServerName        As String
Public g_sDatabaseName      As String
Public g_sUID               As String
Public g_sPWD               As String

Public g_bGenerateExcelFile As Boolean
Public g_bGenerateTextFile  As Boolean
Public g_bGenerateAccesFile As Boolean

--------------------------------------------------------------------------------'Module Name : modExport.bas

Option Explicit

'Constant Declaration
Private Const ODBC_ADD_DSN = 1        ' Add data source
Private Const ODBC_ADD_SYS_DSN = 4    ' Add System DSN
Private Const ODBC_CONFIG_DSN = 2     ' Configure (edit) data source
Private Const ODBC_REMOVE_DSN = 3     ' Remove data source
Private Const vbAPINull As Long = 0   ' NULL Pointer

Public Const DSNName = "MySQLExportDSN"

Private Type BrowseInfo
    hWnd                As Long
    RootFolderLocation  As Long
    DisplayName         As Long
    Title               As Long
    Flags               As Long
    BFFCALLBACK         As Long
    Param               As Long
    Image               As Long
End Type

'Function Declare
#If Win32 Then
    Private Declare Function SQLConfigDataSource Lib "ODBCCP32.DLL" (ByVal hwndParent As Long, ByVal fRequest As Long, ByVal lpszDriver As String, ByVal lpszAttributes As String) As Long
#Else
    Private Declare Function SQLConfigDataSource Lib "ODBCINST.DLL" (ByVal hwndParent As Integer, ByVal fRequest As Integer, ByVal lpszDriver As String, ByVal lpszAttributes As String) As Integer
#End If

Private Declare Function SQLGetInstalledDriver Lib "ODBCCP32.DLL" (ByVal lDrvList As String, ByVal lpszDriver As Long, ByVal lpszAttributes As Long) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long

Public Function GetPath(oOwnerForm_In As Form) As String
    
    Dim lngReturnPointer        As Long
    Dim lngNullCharPosition     As Integer
    Dim tBrowseTypeStructure    As BrowseInfo
    Dim sPath                   As String
   
    With tBrowseTypeStructure
        .hWnd = oOwnerForm_In.hWnd
        .Title = lstrcat("Please select the destination.", "")
        .Flags = 1
    End With
 
    lngReturnPointer = SHBrowseForFolder(tBrowseTypeStructure)
    If lngReturnPointer Then
        sPath = Space(1000)
        SHGetPathFromIDList lngReturnPointer, sPath
        CoTaskMemFree lngReturnPointer
        lngNullCharPosition = InStr(sPath, vbNullChar)
        If lngNullCharPosition Then
            sPath = Left$(sPath, lngNullCharPosition - 1)
        End If
    End If
    
    GetPath = Trim(sPath)
    
End Function
Public Function createDSN(ByVal sServerName_IN As String, ByVal sDSNDBName_IN As String, ByVal sUserName_IN As String, ByVal sPWD_IN As String) As Boolean
On Error GoTo errHandlerSection
    
    #If Win32 Then
        Dim lRet As Long
    #Else
        Dim intRet As Integer
    #End If
    
    Dim strDriver As String
    Dim strAttributes As String
    
    Dim sDriverList As String
    Dim bRetValue As Boolean
 
'    bRetValue = SQLGetInstalledDriver(sDriverList, Len(sDriverList), Len(sDriverList))
    
    strDriver = ""
    strAttributes = ""
    
    strDriver = "MySQL"
    strAttributes = "Server=" & sServerName_IN
    strAttributes = strAttributes & ";Database=" & sDSNDBName_IN & ";DSN=" & DSNName & ";uid=" & sUserName_IN & ";Password=" & sPWD_IN
    
    lRet = SQLConfigDataSource(vbAPINull, ODBC_ADD_DSN, strDriver, strAttributes)
        
    If lRet = 0 Then
        createDSN = False
    Else
        createDSN = True
    End If
    
    Exit Function
    
errHandlerSection:
    MsgBox "Cannot create DSN" & vbCrLf & "Error description : " & Err.Description, vbCritical, "Internal Error"
    createDSN = False
End Function

Public Function RemoveDSN() As Boolean
On Error GoTo errHandlerSection
    
    #If Win32 Then
        Dim lRet As Long
    #Else
        Dim intRet As Integer
    #End If
    
    Dim strDriver As String
    Dim strAttributes As String
    
    Dim sDriverList As String
    Dim bRetValue As Boolean
    
    lRet = SQLConfigDataSource(vbAPINull, ODBC_REMOVE_DSN, "MySQL", DSNName)
        
    If lRet = 0 Then
        RemoveDSN = False
    Else
        RemoveDSN = True
    End If
    
    Exit Function
    
errHandlerSection:
    MsgBox "Cannot delete DSN" & vbCrLf & "Error description : " & Err.Description, vbCritical, "Internal Error"
    RemoveDSN = False
End Function

--------------------------------------------------------------------------------
'Form Name : frmServerSettings

Option Explicit

Private Sub cmdCancel_Click()
    Unload Me
End Sub

Private Sub cmdOk_Click()
    
    g_sServerName = Trim(txtServerName.Text)
    g_sDatabaseName = Trim(txtDatabaseName.Text)
    g_sUID = Trim(txtUserName.Text)
    g_sPWD = Trim(txtPassword.Text)
    
    If createDSN(g_sServerName, g_sDatabaseName, g_sUID, g_sPWD) Then
        Unload Me
    Else
        MsgBox "Cannot connect to the specified server.", vbInformation, "Server Connection failed"
    End If
    
End Sub

--------------------------------------------------------------------------------
'Form Name : frmMain

Option Explicit

Private Sub MDIForm_Load()
    RemoveDSN
End Sub

Private Sub mnuAccessTransfer_Click()
    g_bGenerateAccesFile = True
    g_bGenerateExcelFile = False
    g_bGenerateTextFile = False
    frmExport.Show 1
End Sub

Private Sub mnuExcelTransfer_Click()
    g_bGenerateAccesFile = False
    g_bGenerateExcelFile = True
    g_bGenerateTextFile = False
    frmExport.Show 1
End Sub

Private Sub mnuExit_Click()
    Unload Me
End Sub

Private Sub mnuServerSettings_Click()
    frmServerSettings.Show 1
End Sub

Private Sub mnuTextFileTransfer_Click()
    g_bGenerateAccesFile = False
    g_bGenerateExcelFile = False
    g_bGenerateTextFile = True
    frmExport.Show 1
End Sub

--------------------------------------------------------------------------------
'Form Name : frmExport

Option Explicit
Dim m_oAccess           As New Access.Application
Dim m_oFSO              As New FileSystemObject

Private Sub cmdBrowse_Click()
Dim sDBPath As String
    
    sDBPath = Trim(GetPath(Me))
    
    If sDBPath <> "" Then
        sDBPath = IIf(Right(sDBPath, 1) = "\", Left(sDBPath, Len(sDBPath) - 1), sDBPath)
    End If
    
    txtDBPath.Text = IIf(sDBPath <> "", sDBPath, txtDBPath.Text)
    
    If g_bGenerateExcelFile = False And g_bGenerateTextFile = False Then CopyDatabase
End Sub
Private Sub cmdClose_Click()
    Unload Me
End Sub
Private Sub cmdDeselectAll_Click()
Dim i As Integer
    For i = 0 To lstTableNames.ListCount - 1
        lstTableNames.Selected(i) = False
    Next i
End Sub

Private Sub cmdExport_Click()
Dim i As Integer

    Screen.MousePointer = vbHourglass
    If OpenDatabase Then
        
        For i = 0 To lstTableNames.ListCount - 1
            If lstTableNames.Selected(i) = True Then ExportTables lstTableNames.List(i)
        Next i
        
        If g_bGenerateAccesFile Then CopyAccessFile
        
        CloseDatabase
        
        DeleteDBFile
        
    End If
    
    Screen.MousePointer = vbDefault
    
    MsgBox "Data transfer completed.", vbInformation, App.Title
    
    Unload Me
    
End Sub
Private Sub cmdSelectAll_Click()
Dim i As Integer

    For i = 0 To lstTableNames.ListCount - 1
        lstTableNames.Selected(i) = True
    Next i
    
End Sub

Private Function GetTableList() As Boolean
On Error GoTo errHandlerSection

    Dim oCN             As New ADODB.Connection
    Dim oRS             As ADODB.Recordset
    Dim sConnectString  As String
    
    sConnectString = ""
    
    sConnectString = "driver=MySQL"
    sConnectString = sConnectString & ";Server=" & g_sServerName
    sConnectString = sConnectString & ";uid=" & g_sUID
    sConnectString = sConnectString & ";pwd=" & g_sPWD
    sConnectString = sConnectString & ";Database=" & g_sDatabaseName
    sConnectString = sConnectString & ";Option=" & "16899"
    
    With oCN
        If .State = 1 Then .Close
        .ConnectionString = sConnectString
        .Open
        Set oRS = .OpenSchema(adSchemaTables)
    End With
    
    With oRS
        While Not .EOF
            lstTableNames.AddItem .Fields(2).Value
            .MoveNext
        Wend
    End With
    
    If oRS.State = 1 Then oRS.Close
    Set oRS = Nothing
    
    If oCN.State = 1 Then oCN.Close
    Set oCN = Nothing
    
    GetTableList = True
    
    Exit Function

errHandlerSection:

    GetTableList = False
    MsgBox "Cannot get the table list." & vbCrLf & "Error Description : " & Err.Description, vbCritical, "Error in GetTableList"
    
End Function
Private Sub CopyDatabase()
On Error GoTo errHandlerSection

    With m_oFSO
    
        If .FolderExists(Trim(txtDBPath.Text)) Then
            .CopyFile App.Path & "\Blank.mdb", Trim(txtDBPath.Text) & "\Blank.mdb"
            
            If .FileExists(Trim(txtDBPath.Text) & "\" & IIf(Right(txtDBName.Text, 4) = ".mdb", Trim(txtDBName.Text), Trim(txtDBName.Text) & ".mdb")) Then
                .DeleteFile (Trim(txtDBPath.Text) & "\" & IIf(Right(txtDBName.Text, 4) = ".mdb", Trim(txtDBName.Text), Trim(txtDBName.Text) & ".mdb"))
            End If
            
            Name Trim(txtDBPath.Text) & "\Blank.mdb" As Trim(txtDBPath.Text) & "\" & IIf(Right(txtDBName.Text, 4) = ".mdb", Trim(txtDBName.Text), Trim(txtDBName.Text) & ".mdb")
        End If
    
    End With
    
    Exit Sub

errHandlerSection:
    MsgBox "Error while copying database.", vbCritical, "Copy Database"
    
End Sub


Private Sub Form_Activate()
    If lstTableNames.ListCount > 0 Then
        cmdSelectAll.Enabled = True
        cmdDeselectAll.Enabled = True
        cmdExport.Enabled = True
    End If
    
    If g_bGenerateExcelFile Or g_bGenerateTextFile Then
        txtDBName.Enabled = False
        txtDBName.BackColor = vbGrayText
    ElseIf g_bGenerateAccesFile Then
        txtDBName.Enabled = True
    End If
End Sub
Private Sub Form_Load()
GetTableList
End Sub
Private Sub Form_Unload(Cancel As Integer)
    Set m_oAccess = Nothing
    Set m_oFSO = Nothing
End Sub
Private Sub txtDBPath_LostFocus()
    If Trim(txtDBPath.Text) <> "" Then
        If g_bGenerateExcelFile = False And g_bGenerateTextFile = False Then CopyDatabase
    End If
End Sub
Private Sub ExportTables(sTableName_IN As String)
On Error GoTo errHandlerSection
    
    With m_oAccess
        
        .DoCmd.TransferDatabase acImport, "ODBC Database", _
                                        "ODBC;DSN=" & DSNName & ";UID=" & g_sUID & ";PWD=" & g_sPWD & ";LANGUAGE=us_english;" _
                                        & "DATABASE=" & g_sDatabaseName, acTable, sTableName_IN, sTableName_IN
         If g_bGenerateExcelFile Then
            .DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, sTableName_IN, Trim(txtDBPath.Text) & "\" & sTableName_IN & ".xls", True
         End If
                  
         If g_bGenerateTextFile Then
            .DoCmd.TransferText acExportDelim, , sTableName_IN, Trim(txtDBPath.Text) & "\" & sTableName_IN & ".txt"
         End If
         
    End With
    
    Exit Sub

errHandlerSection:
    
    MsgBox "Error while retrieving data from table : " & sTableName_IN & vbCrLf & "Error Description : " & Err.Description, vbCritical, "Error while creating database."
    
End Sub
Private Function OpenDatabase() As Boolean
On Error GoTo errHandlerSection
    
    If (g_bGenerateExcelFile = False And g_bGenerateTextFile = False) And (Trim(txtDBName.Text) = "" Or Trim(txtDBPath.Text) = "") Then
        MsgBox "Invalid database information,cannot create database.", vbInformation, "Create Database"
        OpenDatabase = False
        Exit Function
    End If
    
    With m_oAccess
        If g_bGenerateExcelFile Or g_bGenerateTextFile Then
            CopyTempDB
           .OpenCurrentDatabase App.Path & "\TempBlank.mdb"
        Else
            .OpenCurrentDatabase Trim(txtDBPath.Text) & "\" & IIf(Right(txtDBName.Text, 4) = ".mdb", Trim(txtDBName.Text), Trim(txtDBName.Text) & ".mdb")
        End If
    End With
    
    OpenDatabase = True
    
    Exit Function
    
errHandlerSection:
    
    MsgBox "Error while opening database connection " & vbCrLf & "Error Description : " & Err.Description, vbCritical, "Error while opening database connection."
    
    OpenDatabase = False
    
End Function
Private Function CloseDatabase() As Boolean
On Error GoTo errHandlerSection

    With m_oAccess
        .CloseCurrentDatabase
    End With
    
    CloseDatabase = True
    Exit Function
    
errHandlerSection:
    
    MsgBox "Error while closing database connection " & vbCrLf & "Error Description : " & Err.Description, vbCritical, "Error while closing database connection."
    
    CloseDatabase = False
    
End Function
Private Sub CopyTempDB()
    With m_oFSO
        .CopyFile App.Path & "\Blank.mdb", App.Path & "\TempBlank.mdb", True
    End With
End Sub
Private Sub DeleteDBFile()
    With m_oFSO
        If .FileExists(App.Path & "\TempBlank.mdb") Then .DeleteFile ((App.Path & "\TempBlank.mdb"))
    End With
End Sub
Private Function GetDatabaseList() As Boolean
On Error GoTo errHandlerSection

    Dim oCN             As New ADODB.Connection
    Dim oRS             As ADODB.Recordset
    Dim sConnectString  As String
    
    sConnectString = ""
    
    sConnectString = "driver=MySQL"
    sConnectString = sConnectString & ";Server=" & g_sServerName
    sConnectString = sConnectString & ";uid=" & g_sUID
    sConnectString = sConnectString & ";pwd=" & g_sPWD
    sConnectString = sConnectString & ";Database=" & g_sDatabaseName
    sConnectString = sConnectString & ";Option=" & "16899"
    
    With oCN
        .ConnectionString = sConnectString
        .Open
        Set oRS = .OpenSchema(adSchemaTables)
    End With
    
    With oRS
        While Not .EOF
            lstTableNames.AddItem .Fields(2).Value
            .MoveNext
        Wend
    End With
    
    If oRS.State = 1 Then oRS.Close
    Set oRS = Nothing
    If oCN.State = 1 Then oCN.Close
    Set oCN = Nothing
    GetDatabaseList = True
    Exit Function

errHandlerSection:
    GetDatabaseList = False
    MsgBox "Cannot get the Database list." & vbCrLf & "Error Description : " & Err.Description, vbCritical, "Error in GetDatabaseList"
End Function

Private Sub CopyAccessFile()
On Error GoTo errHandlerSection

Dim oFSO        As FileSystemObject
Dim sFilePath   As String

    Set oFSO = New FileSystemObject
    
    sFilePath = Replace(Trim(txtDBPath.Text) & "\" & Trim(txtDBName.Text), "\\", "\")
    
    With oFSO
        If .FileExists(sFilePath) Then
            If MsgBox(Trim(txtDBName.Text) & " file already exists in the following location : " & Trim(txtDBPath.Text) & vbCrLf & _
                "Do you want to overwrite this file [Y/N]?", vbQuestion + vbYesNo + vbDefaultButton2, "Overwrite File") = vbYes Then
                oFSO.DeleteFile sFilePath
                oFSO.CopyFile App.Path & "\TempBlank.mdb", sFilePath
            End If
        Else
            oFSO.CopyFile App.Path & "\TempBlank.mdb", sFilePath
        End If
    End With
    
    Set oFSO = Nothing
    
    Exit Sub
    
errHandlerSection:
    MsgBox "Error while copying file...." & vbCrLf & "Error Description : " & Err.Description, vbOKCancel, "Copy File"
    Set oFSO = Nothing
End Sub



--------------------------------------------------------------------------------