export - 1
' Attribute VB_Name = "export"
Funct ion export complet()
Application.SetOption "Auto compact ", True
sql_ name = "C:\Athena\Minerve scripts\sql\athena.sql "
mdb name = "C:\Athena\Minerve-scri pts\mdb\athena data . mdb "
mdb orig name = "C: \Athena\Athena\UTLAthena data-:-mdb "
' mdb name = "C: \Athena local\minerve\mdb\20Î21112 UTLAthena data . mdb "
log_file = "C:\Athena\Minerve scripts\log\export.Iog "
Open log file For Output As #2
Print #2-; Date & " " & Time & " début de la conversion mdb "
Call effacer tables
Call importer_ tabl es(mdb name)
Call exporter_mysql(mdb name , sql name , mdb orig_name)
Call effacer tables
Pr int #2 , Date & " " & Time & " fin de la conversion mdb"
Close #2
End Function
Sub i mporter table s (nom base)
' On Error GoTo Error Handler
Dim source As DAO.Database
Dim table As DAO . TableDef
Set source = Op enDatabase(nom_base)
' balayer toutes les tables de la base
For Each table In source.Tabl eDefs
' ne pas tenir compte des tables système
If Left(table.Name , 4) <> "MSys " Then
On Err or GoTo e r ror handle r
Access.DoCmd . TransferDatabase acimport , "Microsoft Access ", noi:;n_base, acTable , tabl
e . Name , table . Name, False
End If
Next table
sour ce.Close
Set source Nothing
Exit Sub
error handler:
msg = vbCrLf & ">>>>>>>Erreur lors de l ' importat i on de la table " & t abl e .Name & vbCrL f
msg = msg & " Er reur:" & Err.Number & vbCrLf & Err.Description & vbCrL f
Print #2 , msg
' Resume Next ne pas cont i nuer, sinon on ne se rendra j amais compt e du problème
End Sub
Functi on exporter_mysql(mdb_name , sql name, mdb ori g_ name)
On Error GoTo error handler
Dim sql f ilename As String
generate_pr imary keys = True
' find the date of the mdb file
mdb date FileDateTime(mdb orig name)
now date = Date & " " & .Time
' Exports the database contents into a file in mysql f ormat
Dim dbase As Database , tdef As Recordset , i As Integer, fd As Integer , table name As String
, j As Integer , iname As String
Dim s As String , found As Integer , field_ name As String , idx As Index , k As Integer , f As I
nteger , fld As Field, ifield_name As St r ing
Set dbase = CurrentDb()
export - 2
'Open the file to export
Open sql_name For Output As #1
Print #1 ,
Print #1 ,
Print #1 ,
Print #1 ,
Pri nt #1 ,
Print #1 ,
Pr int #1 ,
Print #1 ,
Print #1 ,
Print #1 ,
Print #1 ,
Print #1 ,
Print #1 ,
Print #1 ,
Print #1 ,
Print #1 ,
Print #1 ,
Print #1 ,
Print #1 ,
""
"#-------- ---------------- -------- -------------------- ----- ---------- - --------"
"# Conversion MS - ACCESS en SQL "
"# H. Miezin - Commission Informatique UTL- Essonne <utlminerve@gmail . com> "
"# license http://www . gnu . org/licenses/gpl.html GPLv3 "
"# Jul 2012 , 07 "
"# Créé par VBA script export mode file "
"# Besoin de conversion UTF- 8: NON "
"#----- -------- -- ------ -- --------- ------------- ------ --- - - ----------------- - --"
"# Conversion du fichier " & mdb name & " " & mdb date & eol
"# Vers " & sql name & eol
" #" & eol
"# <mdb date> " & mdb date & "</mdb date> " & eol
"# <sql_ date> " & now:=date & "</sql-date> " & eol
"#------------------ --- ----------------------- - ---- - --------- --------------- - -"
"CREATE DATABASE IF NOT EXISTS 'minerve' ;"
"USE 'minerve' ;"
' Go through the table defi nitions
' Dim eol As St ring
eol ";"
For i = 0 To dbase . TableDefs.Count - 1
' ne prendre que les tabl es qui ne sont pas des tables sytème
If ((dbase . TableDefs(i) .Attributes And DB_SYSTEMOBJECT)) Then
El se
table name = name convert( "" & dbase . TableDefs(i) . Name ~
Print- #2 , Date & " " & Time & " conversion de l a tabl e " & table name
' comment table name
Pri nt #1 , "# Table " & table name
Print #1 , ""
' demander la suppression de la table , car elle existe certainement dans la bas e ac
tuelle en vers i on n - 1'
et MYSQL
Print #1 , "DROP TABLE IF EXISTS " & table name & eol
Print #1 , ""
' construire la r e quête sql CREATE TABLE
Print #1 , "CREATE TABLE " & table name & " ("
' Parcourir les champs de la table , effectuer les conversions de types entre ACCESS
For fd = 0 To dbase . TableDefs(i) .Fi elds . Count - 1
Dim data type As String, field size As Integer , comma As String
Select Case dbase . TableDe f s(i)~Fields(fd) . Type
Case DB BOOLEAN
data_type = "SMALLINT "
Case DB INTEGER
data_ type "SMALL I NT "
Case DB BYTE
data_ type "TINYBLOB "
Case DB LONG
data_type " INT "
Case DB DOUBLE
data_t ype = " DOUBLE"
Case DB SINGLE
data_ type = " REAL "
Case DB CURRENCY
data_ type = " INT(ll) "
Case DB TEXT
field size = db ase . TableDefs (i) . Fiel ds(fd ) .Size
data type = "VARCHAR (" & field size & " ) "
Case dbAutoincrFiel d -
data_type = " INT NOT NULL AUTO INCREMENT "
Case DB DATE
data_type = " DATETIME "
Case DB_MEMO , DB LONGBINARY
data type = " BLOB "
export - 3
End Select
' ajouter la définition des champs à la requête
fiel d name = "" & dbase . Tab leDefs(i) .Fields(fd) . Name
1 convertir les noms de champ en quelque chose de facile à gérer
field name = name convert(field name)
field::::info = " " & field_name & " " & data type
If fd < dbase.TableDefs(i) .Fields.Count - l Then
field info =field info & ","
End I f
Print #1 , field i nfo
Next fd
' générer les i nformations concernant les clés primaires
If generate_pri mary keys Then
Primar y = ""
k = 0
For Each idx In dbase.TableDefs(i) . Indexes
' Check Primary property
k = k + 1
' If idx.Pri mary Then
If idx . Name = " PrimaryKey " Then
ifield_name = ", PRIMARY KEY ( "
f = 0
For Each fld In idx . Fields
f = f + 1
iname = name convert(fld.Name)
i fi e l d name ~ ifield name & iname
If f <-idx . Fields . Count Then
ifield name
End I f
Next fld
ifield name &
ifield_name ifield name & " ) "
" ' "
' If k < dbase . Tabl e Defs( i ) .Ind exes . Coun t Then
ifiel d name = ifield name & ","
' End If
Print #1 , ifi eld name
End If
Next idx
End If
' termi ner la requête CREATE TABLE
Print #1 , " ) " & "ENGINE=MyI SAM DEFAULT CHARSET=utf8 " & eol
Print #1 , ""
Pri nt #1 , ""
Pri nt #1 , ""
Print #1 , ""
' ensuite générer des requêtes SQL "INSERT " pour remplir la base.
Dim recset As Recordset
Dim insert query As String , it As String
Dim is string As String , reccount As Int eger , x As Integer
' ouvrir le contenu de l a table concernée
Set recset = dbase.OpenRecordset(dbase . TableDefs(i) . Name)
reccount = recset.RecordCount
If reccount <> 0 Then
' parcourir les champs de l a table
recset . MoveFirst
Do Until recset.EOF
insert query = " INSERT INTO " & table name & " VALUES ( "
' Go through the fields in the row
For fd = 0 To recset.Fields.Count - 1
is_ string =
field value= "" & r e c s et . Fields(fd) . Value
Select Case recset . Fields(fd) .Type
Case DB BOOLEAN
'true fields are set to 1 , false are set to 0
If recset . Fields(fd) . Value= True Then
f i eld value " 1 "
El se
field value " 0 "
End If
Case DB_TEXT , DB_MEMO, 15 , DB LONGBINARY
is string "'"
export - 4
Lo op
Case DB DATE
is_string = 11111
If field value<> 1111 And Not (IsNull(field value)) Then
field value Format(field_value, " YYYY=-MM- DD HH :mm 11
)
End If
Case DB CURRENCY
field value Replace(field_value , " " " . " ) Case DB DOUBLE '
fie ld value Replace(field_value, " " " . ") Case DB SINGLE ' '
field value Replace(field_value , " " " . " ) Case El se ' '
End Select
'default empty number fields to NULL - comment this out if you want
If field value= "" Or (IsNull(field_value)) Then
field value = "NULL "
is string ""
End If
'*** * escape single quotes
field value = value convert(field value )
x = InStr(field_value, "'" l -
While X <> 0
s = Left$(field_value , x - 1)
s = s & " \ " & Right$(field_value , Len(fie ld_value) - x + 1)
field value = s
x = InStr(x + 2 , field_value, ""' )
Wend
insert query = insert query & is string & field value & is string
I f fd < recset .Fields~Count - l Then
insert query insert query & 11
,
End If
Next fd
' Add trailers and print
insert query = i nsert query & " ) " & eol
' escape # to preserve sql comments
insert query = Replace( i nsert query, " #", "-11
)
Print #1 , i nsert query -
Print #1, ""
' Move to the next row
recset.MoveNext
recset.Close
Set recset = Nothing
End If
End If
Next i
' Modif DM/FL du 23/04/14********************************
Print #1, ""
Pri nt #1, "ALTER Table t08 activites global MODIFY titre_prestation VARCHAR(lOO) CHARACTER
SET utf8 COLLATE utf8 unicode ci;"
Print #1 , ""
' *******************************************************
Close #1
dbase . Close
Set dbase = Nothing
Exit Function
error handl er:
msg = vbCrLf & ">>>>>>> Erreur lors de la conversion de la table " & table name & vbCrLf
msg = msg & "Erreur: " & Err.Number & vbCrLf & Err.Description & vbCrLf
Print #2, msg
' Resume Next ne pas continuer sinon on ne verra jamais le problème
End Function
export - 5
Function effacer tables()
Dim dba s e As Database , table name As String, i As I nteger
Set dbase CurrentDb()
' Go through the table definitions
success = True
While s uccess
n = dbase . Tabl eDefs . Coun t
For i = 0 To n - 1
success = False
I f ((dbase . TableDefs(i) . Attributes And DB_SYSTEMOBJECT) Or (dbase.TableDefs(i) .Attr
i butes And DB HIDDENOBJECT)) Then
El se
tabl e name = dbase.TableDefs(i) . Name
Pri nt #2 , Date & " " & Time & " effacement table " & table name
' table name =escape quotes(tabl e name)
dbase~TableDefs.Delete (table_name)
succe ss = True
Exit For
' SQL = " DROP TABLE " & table name & ""
' DoCmd . RunSQL SQL
End If
Next i
Wend
dbase . Cl ose
Set dbase Nothing
End Function
Function n ame convert(s)
t s
t Replace(t , " " " " )
t Replace(t , "é " I " e " )
t Replace(t , " è " I " e " )
t Replace(t , "ê ", " e " )
t Replace( t, " à "' "a " )
t Replace(t , " 0 " " o " )
t Replace(t , " ô ", " o " )
t Replace(t , "û ", "u " )
t Replace(t , "ù ", "u " )
t Replace(t , " ç "' " c " )
t Repla c e(t , " & ", " et " )
t Repl ace(t , "'" " " )
t LCase(t)
name con vert " ' " & t & " ' "
End Function
Fu n ct i on value convert(s)
t s
t = Replace ( t , "; ", " . " )
t = Replace ( t , " \ ", " / " )
value convert = t
End Functi on
Funct i on e s cape quotes(zz)
End Function
x = InStr(zz , ""' )
While X <> 0
s = Left$(zz , x - 1)
s = s & " \ " & Right$(zz , Len(zz) - x + 1)
zz = s
x = InSt r (x + 2 , z , "'" )
Wend
escape_ quotes = zz