Creation et lecture de fichier xml via une base de donnee..

Soyez le premier à donner votre avis sur cette source.

Vue 7 861 fois - Téléchargée 987 fois

Description

Programme interressant car :
utilisation de ADO
Creation de fichier log
Utilisation de FileSystemObject
et de commonDialog
Visitez mon site bodyartgallery.free.fr

Je sais que c'est pas un prog qui interresse bcp de monde,
mais si j'avais eu ces exemples il y'a qques temps,
ca m'aurais bien aidé donc je le mets a disposition. ;o)

il faut:
Les references
-"Microsoft Windows Common Dialog Control 6.0"
-"Microsoft ActiveX Data Object 2.5 Library
-"Microsoft ADO Ext. 2.5 for DDL and security

Les controles
- Une feuille --> Form1
- Un textbox --> txtoperateur
(pour indiquer l'operateur de la requete =, <, >, etc...)
- un textbox --> txtValue
- Un CommandButton --> Command1
- Un CommandButton --> Command2
- Une listbox --> List1
- Un CommonDialog --> Cmdial
- Une base de donnée avec des tables contenant un champ "DerniereSaisie" (ou un autre champ qu'il faudra modifier dans le code) et des tables n'en contenant pas

Source / Exemple :


'***A mettre dans une Form*****

Private Sub Command1_Click()
    '***Bouton pour enregistrer dans un fichier XML*****
    Dim objSaveXML As New ClsOperationXML
    '***Uniquement le repertoire*****
    objSaveXML.SaveBaseXml ("C:\MonChemin\")
End Sub

Private Sub Command2_Click()
    '***Bouton pour ouvrir le fichier XML*****
    Dim objOpenXml As New ClsOperationXML
    Cmdial.ShowOpen
    objOpenXml.OpenBaseXml Cmdial.FileName
End Sub

'***A mettre dans une classe --> ClsOperationXML*****

'***************************
'***Classe clsOperationXML**
'***************************

Option Explicit

Private ctlCatalogUpdate As Catalog

Private mcnUpdate As Connection

Private rstUpdate As Recordset
Private rstVerification As Recordset

Private blnDateDS As Boolean

Private strVerifField As String
Private strTableName As String

Private objField As Field

Private mstrConnectionString

'***Enregistrer la requete dans un fichier XML*****

Public Function SaveBaseXml(ByVal vPath As String) As Boolean

    Dim AdoTbl As adox.Table

    Dim mstrBase As String
    Dim mStrProvider As String
    Dim mvarConnectionString As String
    Dim mstrSystem As String

    Dim strMyDate As String
    Dim strFormatDate As String
    Dim strQueryUpdate As String
    Dim lngNbTables As Long

    Dim strPathBDD As String
    Dim strtempDir As String
    Dim strIdentifiant As String
    
    Dim fs As New FileSystemObject
    Dim fldr As Scripting.Folder
    Dim fle As Scripting.File
    Dim strfleName As String

    Dim strlog As String

    Dim strErreur As String
    
    '***Cherche le Chemin de la base de donnee*****
    strtempDir = vPath
    '***Il faut une Base de donnée qui commence par "@@"***
    strIdentifiant = "@@"
    Set fldr = fs.GetFolder(strtempDir)
    For Each fle In fldr.Files
        strfleName = fle.Name
        If VBA.Left(strfleName, 4) = strIdentifiant And Not UCase(VBA.Right(strfleName, 3)) = "LDB" Then
            strPathBDD = strtempDir & strfleName
            Exit For
        End If
    Next

    Set mcnUpdate = New Connection
    With mcnUpdate
        On Error Resume Next
        .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strPathBDD    'vUpdatePath
        .CursorLocation = adUseServer
        .Mode = adModeShareExclusive
        On Error GoTo Erreur
        .Open
    End With

    Set rstUpdate = New Recordset

    On Error GoTo Erreur

    Set ctlCatalogUpdate = New Catalog
    Set ctlCatalogUpdate.ActiveConnection = mcnUpdate

    '***Compte le nombre de table*****
    lngNbTables = ctlCatalogUpdate.Tables.Count

    '***Scrute les Tables ds la base de donnee*****
    For Each AdoTbl In ctlCatalogUpdate.Tables
        strTableName = AdoTbl.Name

        If VBA.Left(UCase(strTableName), 4) <> "MSYS" Then
            '***Verification: La table contient elle un champ DerniereSaisie ?*****
            Set rstVerification = New Recordset
            With rstVerification
                Dim intCount As Integer
                intCount = 0
                .Open strTableName, mcnUpdate, adOpenStatic, adLockOptimistic, adCmdTable
                For Each objField In rstVerification.Fields
                    strVerifField = objField.Name
                    If UCase(strVerifField) <> "DERNIERESAISIE" Then
                        blnDateDS = 0
                    Else
                        blnDateDS = 1
                        Exit For
                    End If
                Next
            End With
            Select Case blnDateDS
                Case 0
                    MsgBox "Pas de date de Derniere Saisie dans la table '" & strTableName & "'"
                    GoTo NextTable
                Case 1
                    '****On ne fait rien****
            End Select
            Set rstUpdate = New Recordset
            With rstUpdate
                If .State = 1 Then .Close
                '***Formatage de la date (format U.S.)*****
                strFormatDate = Format(Form1.txtValue, "mm/dd/yy")
                '***Requete de selection*****
                strQueryUpdate = "SELECT '" & strTableName & "' as TableName, * FROM " & strTableName & " WHERE DerniereSaisie " & Form1.txtOperateur & " #" & strFormatDate & "#"
                .Open strQueryUpdate, mcnUpdate, adOpenForwardOnly, adLockReadOnly, adCmdText
                '***Enregistrement dans un fichier XML*****
                strMyDate = Format(Now, "ddmmyy_hhmmss")
                If Len(Dir(App.Path & "\SaveXML\", vbDirectory)) = 0 Then MkDir App.Path & "\SaveXML\"
                .Save App.Path & "\SaveXML\" & strTableName & " " & strMyDate & ".xml", adPersistXML
                .Close
            End With
        End If
NextTable:
    Next
    
    SaveBaseXml = True
    If Len(LTrim(strlog)) > 0 Then GoTo WriteLog
    GoTo Fin
    '***Gestion des erreurs*****
Erreur:
    strlog = Err.Description
    On Error Resume Next
    If Err.Number <> 0 Then
        Dim strError As String
        strError = Err.Description
        strlog = strlog & strError & vbCrLf
    Else
    strErreur = "Erreur l'opération a été annulée "
    MsgBox strErreur & ", " & strlog
    strlog = strErreur & ", " & strlog
    End If

    '***Ecrire un fichier log*****
WriteLog:
    If Len(LTrim(strlog)) > 0 Then
        Dim lngFree As Long
        lngFree = FreeFile
        Open App.Path & "\Erreur.log" For Append As #lngFree
        strlog = "************ Erreur " & Now & "***************" & vbCrLf & _
                vbCrLf & strlog & vbCrLf & vbCrLf & "************ Fin erreur ***************" & vbCrLf
        Write #lngFree, strlog
        Debug.Print strlog
        Close #lngFree
    End If

    '***Si pas d'erreurs*****
Fin:
    On Error Resume Next
    If Not mcnUpdate Is Nothing Then
        If mcnUpdate.State = 1 Then mcnUpdate.Close
    End If
    Set rstUpdate = Nothing
    Set mcnUpdate = Nothing
End Function

'***Ouvrir un fichier XML*****

Public Function OpenBaseXml(vPath As String)
    Dim strTableName As String
    Dim strFieldName As String
    Form1.List1.Clear
    strTableName = vPath
    Set rstUpdate = New Recordset
    With rstUpdate
        .Open strTableName
        Do While Not .EOF
            For Each objField In rstUpdate.Fields
                strFieldName = objField.Name
                Form1.List1.AddItem strFieldName & " ==> " & objField.Value
            Next
            .MoveNext
        Loop
        If Form1.List1.List(0) = "" Then Form1.List1.AddItem "Aucun enregistrement"
    End With
    GoTo Fin
Erreur:
    Debug.Print Err.Description
    MsgBox Err.Description
    On Error Resume Next
    MsgBox "Erreur l'opération a été annulée"
    Exit Function
Fin:
    Set rstUpdate = Nothing
End Function

Codes Sources

A voir également

Ajouter un commentaire

Commentaires

Commenter la réponse de cs_hash

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.