by Kaustubh Zoal (10 Submissions)
Category: Databases/Data Access/DAO/ADO
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Fri 21st June 2002
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
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
VBcoders
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
--------------------------------------------------------------------------------
No comments have been posted about This program exports the data from MySQL to the following 3 formats 1.Ms-Access Database. 2.Text Fi. Why not be the first to post a comment about This program exports the data from MySQL to the following 3 formats 1.Ms-Access Database. 2.Text Fi.
