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
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.