Gestion dsn sqlserver et creation de fichier texte pour pouvoir importer des bases de données sql dans mysql ainsi que les d

Télécharger le projet
Commenter

Description

Voic une petite application que j'ai developpée qui permet de creer des dsn sql server ou de les supprimer et de creer des fichier textes servant a l'importation dans mysql

Source / Exemple : 


Private Declare Function SQLDataSources Lib "ODBC32.DLL" (ByVal henv&, ByVal fDirection%, ByVal szDSN$, ByVal cbDSNMax%, pcbDSN%, ByVal szDescription$, ByVal cbDescriptionMax%, pcbDescription%) As Integer
Private Declare Function SQLAllocEnv% Lib "ODBC32.DLL" (env&)
Const SQL_SUCCESS As Long = 0
Const SQL_FETCH_NEXT As Long = 1

' Ajoute un dsn Utilisateur
Private Const ODBC_ADD_DSN = 1
' Supprime le DSN Utilisateur
Private Const ODBC_REMOVE_DSN = 3
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

Dim adddsna As Boolean
Dim intRet As Long
Dim strDriver As String
Dim strAttributes As String

Private Sub ajoutdonnee_Click()
'Pour creer le fichier texte
Set FSys = CreateObject("Scripting.FileSystemObject")
Set MonFic = FSys.CreateTextFile(app.path & cdsn.Text & ".txt")
Dim cn As New ADODB.Connection
Dim rcsinfo As New ADODB.Recordset
Dim rcsdonnee As New ADODB.Recordset
Dim rcsnbcolonne As New ADODB.Recordset
Dim nbcolonne As Integer
nbcolonne = 0
cn.Open "dsn=" & cdsn.Text
rcsinfo.Open "select sysobjects.name" & _
    " from sysobjects where  sysobjects.xtype='u' and sysobjects.name " & _
    "<>'dtproperties'", cn
While rcsinfo.EOF = False
rcsnbcolonne.Open "select syscolumns.name from syscolumns,sysobjects,systypes where syscolumns.id=sysobjects.id and sysobjects.xtype='u' and syscolumns.xtype=systypes.xtype and sysobjects.name ='" & rcsinfo.Fields(0) & "'", cn
While rcsnbcolonne.EOF = False
nbcolonne = nbcolonne + 1
rcsnbcolonne.MoveNext
Wend
rcsnbcolonne.Close
'MsgBox nbcolonne
With MonFic
.writeline "insert into " & rcsinfo.Fields(0) & " values("
End With
rcsdonnee.Open "select * from " & rcsinfo.Fields(0), cn, adOpenDynamic
While rcsdonnee.EOF = False
For i = 0 To nbcolonne - 1
If i <> nbcolonne - 1 Then
With MonFic
.Write "'" & rcsdonnee.Fields(i) & "',"
End With
Else
With MonFic
.Write "'" & rcsdonnee.Fields(i) & "'"
End With
End If
Next
rcsdonnee.MoveNext
If rcsdonnee.EOF = False Then
With MonFic
.Write "),("
End With
Else
With MonFic
.Write ");"
End With
End If
rcsdonnee.MovePrevious
rcsdonnee.MoveNext
Wend
rcsdonnee.Close
rcsinfo.MoveNext
nbcolonne = 0
Wend
End Sub

Private Sub Create_Click()
If cdsn.Text = "" Then
MsgBox "Vous devez choisir un dsn!!!!", vbCritical
Exit Sub
End If
Dim nomtable As String
Dim verif As Boolean
Dim cn As New ADODB.Connection
Dim rcsinfo As New ADODB.Recordset
Dim typedonnee As String
'Pour creer le fichier texte
Set FSys = CreateObject("Scripting.FileSystemObject")
Set MonFic = FSys.CreateTextFile(app.path & cdsn.Text & ".txt")
cn.Open "dsn=" & cdsn.Text
rcsinfo.Open "select sysobjects.name, syscolumns.name,systypes.name,syscolumns.prec," & _
    "syscolumns.scale,syscolumns.autoval,syscolumns.isnullable,syscolumns.cdefault" & _
    " from syscolumns,sysobjects,systypes where syscolumns.id=sysobjects.id " & _
    "and sysobjects.xtype='u' and syscolumns.xtype=systypes.xtype and sysobjects.name " & _
    "<>'dtproperties'", cn
nomtable = ""
verif = True
While rcsinfo.EOF = False
If rcsinfo.Fields(0) <> nomtable Then
nomtable = rcsinfo.Fields(0)
If verif = False Then
With MonFic
.writeline ")TYPE=MyISAM;"
End With
End If
With MonFic
.writeline "CREATE TABLE " & nomtable & "("
End With
verif = False
Else
With MonFic
.Write ","
End With
End If
Select Case rcsinfo.Fields(2)
    Case "money"
        typedonnee = rcsinfo.Fields(1) & " " & "numeric" & "(" & rcsinfo.Fields(3) & _
    ")"
    Case "smallmoney"
        typedonnee = rcsinfo.Fields(1) & " " & "numeric" & "(" & rcsinfo.Fields(3) & _
    ")"
    Case "smalldatetime"
        typedonnee = rcsinfo.Fields(1) & " " & "datetime"
    Case "timestamp"
        typedonnee = rcsinfo.Fields(1) & " " & "timestamp"
    Case "bit"
        typedonnee = rcsinfo.Fields(1) & " " & "char" & "(1)"
    Case "text"
        typedonnee = rcsinfo.Fields(1) & " " & "text"
    Case "float"
        typedonnee = rcsinfo.Fields(1) & " " & "numeric" & "(12)"
    Case "real"
        typedonnee = rcsinfo.Fields(1) & " " & "numeric(100,10)"
    Case Else
        typedonnee = rcsinfo.Fields(1) & " " & rcsinfo.Fields(2) & "(" & rcsinfo.Fields(3) & _
    ")"
End Select
If rcsinfo.Fields(4) > 0 Then
typedonnee = Mid(typedonnee, 1, Len(typedonnee) - 1) & "," & rcsinfo.Fields(4) & ")"
End If
'MsgBox rcsinfo.Fields(4).ActualSize
With MonFic
.writeline typedonnee
End With
'MsgBox rcstable.Fields(0) & "  " & rcstable.Fields(1) & "  " & rcstable.Fields(2) & "  " & rcstable.Fields(3) & "  " & rcstable.Fields(4) & "  " & rcstable.Fields(5) & "  " & rcstable.Fields(6) & "  " & rcstable.Fields(7) & "  "
rcsinfo.MoveNext
Wend
With MonFic
.writeline ")TYPE=MyISAM;"
End With
rcsinfo.Close
rcsinfo.Open "select syscolumns.name,sysobjects.parent_obj from sysobjects,syscolumns " & _
    "where sysobjects.xtype='pk' " & _
    "and sysobjects.parent_obj=syscolumns.id and colstat=1 and sysobjects.parent_obj " & _
    "not in(select id from sysobjects where name='dtproperties')", cn, adOpenDynamic
While rcsinfo.EOF = False
rcsinfo.MoveNext
If rcsinfo.EOF = True Then
rcsinfo.MovePrevious
With MonFic
.writeline "alter table " & cn.Execute("select name from " & _
    "sysobjects where id=" & rcsinfo.Fields(1)).Fields(0)
.writeline "add primary key(" & rcsinfo.Fields(0) & ")"
End With
Else
rcsinfo.MovePrevious
With MonFic
.writeline "alter table " & cn.Execute("select name from " & _
    "sysobjects where id=" & rcsinfo.Fields(1)).Fields(0)
.writeline "add primary key(" & rcsinfo.Fields(0) & ");"
End With
End If
rcsinfo.MoveNext
Wend
rcsinfo.Close
End Sub

Private Sub creer_Click()
'Indique les attributs delimités par le caractère null.
'Indique le nom du DSN ainsi que son chemin d'accès
strAttributes = "SERVER=(local)" & Chr$(0)
strAttributes = strAttributes & "DESCRIPTION=" & Nom_dsn_create.Text & Chr$(0)
strAttributes = strAttributes & "DSN=" & Nom_dsn_create.Text & Chr$(0)
strAttributes = strAttributes & "DATABASE=" & Nom_base.Text & Chr$(0)
'pour utiliser les parametre de windows pour connexion
strAttributes = strAttributes & "Trusted_Connection=yes"
intRet = SQLConfigDataSource(vbAPINull, ODBC_ADD_DSN, strDriver, strAttributes)
adddsna = CBool(intRet)
If adddsna = True Then
MsgBox "DSN SQL Server Créé !"
Else
MsgBox "Une erreur s'est produite lors de la connexion à la base de données SQL. " _
& "Veuillez vérifier si le chemin est correct et retenter une connexion. Si le " _
& "problème persiste, veuillez contacter votre administrateur"
End If
Nom_dsn_create.Text = ""
Nom_base.Text = ""
End Sub

Private Sub delete_Click()
strAttributes = "DSN=" & Nom_dsn_delete.Text & Chr$(0)
intRet = SQLConfigDataSource(vbAPINull, ODBC_REMOVE_DSN, _
strDriver, strAttributes)
'recuperer la valeur vrai ou faux
adddsna = intRet
'test pour savoir si le dsn est supprimer ou non
If adddsna = True Then
MsgBox "DSN SQL Supprimé"
Else
MsgBox "DSN SQL Non-Supprimé"
End If
Nom_dsn_delete.Text = ""
End Sub

Private Sub Form_Activate()
Nom_dsn_create.SetFocus
End Sub

Private Sub Form_Load()
'Indique le driver Access
strDriver = "SQL Server"
Frame(0).ZOrder 0
End Sub

Private Sub Nom_dsn_create_GotFocus()
delete.Default = False
creer.Default = True
End Sub

Private Sub Nom_dsn_delete_GotFocus()
delete.Default = True
creer.Default = False
End Sub

Private Sub Quitter_Click()
End
End Sub

Private Sub TabStrip1_Click()
Frame(TabStrip1.SelectedItem.Index - 1).ZOrder 0
If TabStrip1.SelectedItem.Index - 1 = 1 Then
GetDSN
End If
End Sub

Sub GetDSN()
Dim i As Integer
Dim sDSNItem As String * 1024
Dim sDRVItem As String * 1024
Dim sDSN As String
Dim sDRV As String
Dim iDSNLen As Integer
Dim iDRVLen As Integer
Dim lHenv As Long         ' Descripteur de l'environnement.
On Error Resume Next
cdsn.Clear
' Obtient les DSN.
If SQLAllocEnv(lHenv) <> -1 Then
Do Until i <> SQL_SUCCESS
sDSNItem = Space$(1024)
sDRVItem = Space$(1024)
i = SQLDataSources(lHenv, SQL_FETCH_NEXT, sDSNItem, 1024, iDSNLen, sDRVItem, 1024, iDRVLen)
sDSN = Left$(sDSNItem, iDSNLen)
sDRV = Left$(sDRVItem, iDRVLen)
If sDSN <> Space(iDSNLen) And sDRV = "SQL Server" And sDSN <> "LocalServer" Then
cdsn.AddItem sDSN
End If
Loop
End If
End Sub
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.