MODULE DE CLASSE : EXPORT REQUETE FOX PRO VERS ACESS ET TEXTE

Dim foxpro As New ADODB.Connection 'Connexion sur base Fox Pro
Dim cmd_fox As New ADODB.Command 'Commande
Dim rqt_fox As New ADODB.Recordset 'Recordset
Dim connecter_base As Integer 'Variable permettant de savoir si la personne s'est connecté à la base Fox Pro
Dim newbase As ADOX.Catalog 'Pour création d'une base access
Dim tbl As Table 'Pour création d'une table dans Access
Dim access_externe As ADODB.Connection 'Connection sur la base créé

'FONCTION PERMETTANT DE SE CONNECTER SUR UNE BASE FOX PRO
Function Se_connecter_foxpro(ByVal chem_base As String)

'Si renvoie 1 , connexion réussie
'Sinon renvoie le numéro de l'erreur de connexion
On Error GoTo error_connexion:

foxpro.ConnectionString = "DRIVER={Microsoft Visual FoxPro Driver};SourceType=DBF;SourceDB=" & chem_base
foxpro.Open
connecter_base = 1
Se_connecter_foxpro = 1

Exit Function

error_connexion:
Se_connecter_foxpro = Err.Number
Exit Function

End Function

'FONCTION PERMETTANT DE SE DECONNECTER D'UNE BASE FOX PRO
Function Se_deconnecter_foxpro()

'Si renvoie 1 , deconnexion réussie
'Sinon renvoie le numéro de l'erreur de deconnexion

On Error GoTo error_deconnexion:

foxpro.Close
Set foxpro = Nothing
connecter_base = 0
Se_deconnecter_foxpro = 1
Exit Function

error_deconnexion:
Se_deconnecter_foxpro = Err.Number
Exit Function

End Function

'FONCTION PERMETTANT D'EXPORTER UN RESULTAT DE REQUETE SQL AU FORMAT TEXTE
Function Exporter_requete_texte(ByVal Requete_SQL As String, ByVal chemin_export As String, ByVal nom_fichier_export_avec_extension As String, ByVal separateur_texte As String)

On Error GoTo error_export_txt:
'Variable fonctions
Dim chaine_txt As String 'Chaine a ecrire dans le fichier texte à chaque fois
'Je teste si la personne s'est connecté sur la base auparavant avec réussite

If connecter_base <> 1 Then

    MsgBox "Connecter vous auparavant sur la base Fox Pro avant de réaliser un export !", vbInformation, "Erreur init"
    
Else

    'Je commence par exécuter la requête SQL sur ma base Fox Pro suite à ma connexion
    cmd_fox.ActiveConnection = foxpro
    cmd_fox.CommandText = Requete_SQL

    rqt_fox.CursorLocation = adUseClient
    rqt_fox.CursorType = adOpenDynamic
    rqt_fox.LockType = adLockPessimistic
    
    rqt_fox.Open cmd_fox
    
    'Si pas d'erreur alors je peux enchainer sur l'export de mon recordset au format souhaité
    
    Open chemin_export & nom_fichier_export_avec_extension For Output As #1

        'Je recupere le nom de mes colonnes en-tete

        For i = 1 To rqt_fox.Fields.count - 1
        
            If i = 1 Then
    
                chaine_txt = Trim(rqt_fox.Fields(i).Name)
        
            Else
        
                chaine_txt = chaine_txt & separateur_texte & Trim(rqt_fox.Fields(i).Name)
        
            End If
    
        Next i
        
        Print #1, chaine_txt
        
        'J'exporte ensuite le reste des valeurs de mon recordset
        
        rqt_fox.MoveFirst
        
        While Not rqt_fox.EOF
        
            For i = 1 To rqt_fox.Fields.count - 1
        
                If i = 1 Then
    
                    chaine_txt = Trim(rqt_fox.Fields(i).Value)
        
                Else
        
                    chaine_txt = chaine_txt & separateur_texte & Trim(rqt_fox.Fields(i).Value)
        
                End If
    
            Next i
            
            Print #1, chaine_txt
            rqt_fox.MoveNext
        
        Wend
        
    Close #1
    
    rqt_fox.Close
    Set rqt_fox = Nothing
    
End If

Exporter_requete_texte = i

Exit Function

error_export_txt:

Exporter_requete_texte = Err.Number
rqt_fox.Close
Set rqt_fox = Nothing
Exit Function

End Function

'FONCTION PERMETTANT D'EXPORTER UN RESULTAT DE REQUETE SQL AU FORMAT ACCESS
Function Exporter_requete_access(ByVal Requete_SQL As String, ByVal chemin_export As String, ByVal nom_fichier_export_avec_extension As String, ByVal nom_table As String)

On Error GoTo error_export_mdb:
'Variable fonction
Dim insert_int As String 'Variable pour préparation requête SQL
Dim quote As Integer 'Index de présence d'une quote
Dim valeur_quote_corriger As String 'Valeur sans la quote
Dim val_inser As String 'Valeur à insérer dans la requête SQL
Dim insertion_def As String 'Requete definitive pour l'insertion des données
Dim access_externe As New ADODB.Connection 'Connection pour insertion des données
Dim reponse_ecrasement As Integer 'Reponse sur ecrasement base


If connecter_base <> 1 Then

    MsgBox "Connecter vous auparavant sur la base Fox Pro avant de réaliser un export !", vbInformation, "Erreur init"
    
Else

    'Je commence par exécuter la requête SQL sur ma base Fox Pro suite à ma connexion
    cmd_fox.ActiveConnection = foxpro
    cmd_fox.CommandText = Requete_SQL

    rqt_fox.CursorLocation = adUseClient
    rqt_fox.CursorType = adOpenDynamic
    rqt_fox.LockType = adLockPessimistic
    
    rqt_fox.Open cmd_fox
    
    'Je crée ma base Access
    If Dir(chemin_export & nom_fichier_export_avec_extension, vbHidden) <> "" Then
    
        reponse_ecrasement = MsgBox("Le fichier existe déjà, voulez vous l'écraser ?", vbYesNo, "Confirmation")
        
        If reponse_ecrasement = vbNo Then
        
            Exit Function
            
        Else
        
            'Je supprime mon fichier pour l'écraser
            Kill (chemin_export & nom_fichier_export_avec_extension)
        
        End If
    
    End If
    
    Set newbase = New ADOX.Catalog
    newbase.Create ("Provider='Microsoft.Jet.OLEDB.4.0';data source=" & chemin_export & nom_fichier_export_avec_extension)
    
    'Je crée ensuite la structure de ma table dans la base créé
    Set tbl = New ADOX.Table
    tbl.Name = nom_table
    
    For i = 1 To rqt_fox.Fields.count - 1
        tbl.Columns.Append Trim(rqt_fox.Fields(i).Name), adVarWChar
    Next i
    
    newbase.Tables.Append tbl
    
    Set tbl = Nothing
    Set newbase = Nothing

    'Je me connecte ensuite sur cette base pour insérer les données
    access_externe.ConnectionString = ("Provider='Microsoft.Jet.OLEDB.4.0';data source=" & chemin_export & nom_fichier_export_avec_extension)
    access_externe.Open
    
    'Préparation de la requête SQL pour l'insertion des données dans la base créé
    
    'Nom de  la table
    inser_int = "INSERT INTO " & nom_table & "("
    
    'Liste des champs
    For i = 1 To rqt_fox.Fields.count - 1
        inser_int = inser_int & rqt_fox.Fields(i).Name & ","
    Next i
    
    If inser_int <> "" Then
    
        inser_int = Mid(inser_int, 1, Len(inser_int) - 1)
        inser_int = inser_int & ") VALUES ("
    
    End If
    
    
    'Je balaye ensuite mon recordset pour récupérer l'ensemble des valeurs à exporter
    rqt_fox.MoveFirst
    
    While Not rqt_fox.EOF
    
        For i = 1 To rqt_fox.Fields.count - 1
        
            'Je teste s'il va y avoir une quote qui va m'embeter dans l'insertion des données
            quote = InStr(1, rqt_fox.Fields(i).Value, "'", vbTextCompare)
        
            If quote <> 0 Then
                            
                valeur_quote_corriger = Mid(rqt_fox.Fields(i).Value, 1, quote - 1) & " " & Mid(rqt_fox.Fields(i).Value, quote + 1, (Len(rqt_fox.Fields(i).Value)) - quote)
                val_inser = val_inser & "'" & valeur_quote_corriger & "',"
                
            Else
                                            
                 val_inser = val_inser & "'" & Trim(rqt_fox.Fields(i).Value) & "',"
                                            
            End If
            

        Next i
        
        If val_inser <> "" Then
        
            val_inser = Mid(val_inser, 1, Len(val_inser) - 1)
        
        End If
        'Creation de la requete définitive
        insertion_def = inser_int & val_inser & ")"
        
        'Execution de la requete sur la base
        access_externe.Execute insertion_def
        val_inser = ""
        
        rqt_fox.MoveNext
    
    Wend
    
    access_externe.Close
    Set access_externe = Nothing
    
End If

Exit Function

error_export_mdb:

Exporter_requete_mdb = Err.Number
rqt_fox.Close
Set rqt_fox = Nothing
Exit Function

End Function

Private Sub Class_Initialize()

    connecter_base = 0

End Sub