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

Soyez le premier à donner votre avis sur cette source.

Vue 8 235 fois - Téléchargée 884 fois

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

Codes Sources

A voir également

Ajouter un commentaire

Commentaires

Messages postés
402
Date d'inscription
jeudi 26 août 2004
Statut
Membre
Dernière intervention
19 juin 2009
1
ok, mais dommage, j'aime bien regarder le code sur CS avant de le DL si besoin se fait !
Messages postés
1222
Date d'inscription
jeudi 23 août 2001
Statut
Membre
Dernière intervention
9 septembre 2018

Pour le zip c'est un bug de Windows XP : le zip n'a pas d'erreur, mais c'est la gestion des zip de Windows XP qui est sérieusement boguée (personne ne me crois quand je dis cela d'habitude :-)

Evite les chemins en dur, car personne ne pourra tester ton logiciel sinon, utilise App.Path :
Set MonFic = FSys.CreateTextFile("C:\Documents and Settings\seb\Mes " & _
"documents\Nos site\Fichier d'importation\Ajout_donnees_" & cdsn.Text & ".txt")
Messages postés
402
Date d'inscription
jeudi 26 août 2004
Statut
Membre
Dernière intervention
19 juin 2009
1
Pas de zip... pas de screen ... pas de code ...

ben, bof je suis pas contre ta source mais là !
(Le zip doit être endomagé pour que CS puisse pas le lire)

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.