Import de données d'un serveur IBM AS/400 dans Access

Option Compare Database

Private Sub Form_Open(Cancel As Integer)
' Si la date du jour = lundi la date dans le contrôle doit être un samedi et non un dimanche
    If Weekday(Now) = vbMonday Then
        Me.Txt_DateBon.Value = DateAdd("d", -2, Date)
    Else
        ' Sinon la veille
        Me.Txt_DateBon.Value = DateAdd("d", -1, Date)
        ' On pourrait également inclure les jours fériés
    End If
End Sub

Option Compare Database
Option Explicit
----------------------------------------------------------------------------------------------------------
Public Sub Import_Ca()
On Error GoTo Error_Import_Ca

'Variables de connexion ADO
    Dim CnnAs400 As ADODB.Connection
    Dim RsAs400 As ADODB.Recordset
    Dim Cnndb As New ADODB.Connection
    Dim Rsdb As New ADODB.Recordset
    Dim Fld As ADODB.Field
    Dim StrNameAS400 As String        'Variable nom de l'AS/400
    Dim StrNameUser As String         'Variable nom utilisateur
    Dim StrPasswordUser As String     'Variable mot de passe utilisateur
    Dim Champ1 As String, Champ2 As String, Champ3 As String, Champ4 As String, Champ5 As String, Champ6 As String

'Autres variables
    Dim StrDate As String             'Variable Date de bon
    Dim strTabDelete As String
    Dim strSql As String
    Dim i As Integer

    ' Attribue des valeurs aux variables

    ' Transforme le contrôle date du formulaire d'accueil (par exemple 24/10/06) en texte de 6 caractères (061024)
    StrDat = Right(Form_Frm_Accueil.[Txt_DateBon], 2) & Mid(Form_Frm_Accueil.[Txt_DateBon], 4, 2) & Left(Form_Frm_Accueil.[Txt_DateBon], 2)

    ' Les trois variables suivantes vont chercher leur valeur dans la table « Paramètres »
    StrNameAS400 = Nz(DLookup("Name_AS400", "Tbl_Parametres"))
    StrNameUser = Nz(DLookup("User", "Tbl_Parametres"))
    StrPasswordUser = Nz(DLookup("Password", "Tbl_Parametres"))

    ' Nous supprimons les données de la table "Tbl_Import_Ca"
    DoCmd.SetWarnings False      'Stoppe les messages d'alerte
    strTabDelete = "DELETE * FROM [Tbl_ImportCa];"
    DoCmd.RunSQL strTabDelete    'Rétablit les messages d'alerte
    DoCmd.SetWarnings True

    ' Nous lançons la connexion.
    Set CnnAs400 = CreateObject("ADODB.connection")
    CnnAs400.Open "provider=IBMDA400;data source=" & StrNameAS400 & "", StrNameUser, StrPasswordUser

    Set Cnndb = CurrentProject.Connection
    Set RsAs400 = CreateObject("ADODB.recordset")
    RsAs400.ActiveConnection = CnnAs400

    'Nous créons la requête.
    strSql = " " & _
             " SELECT T01.NOBON, T01.COVEN, T01.BONDA||T01.BONDM||T01.BONDJ, T01.COCLI, T01.MOBON, T02.NOVEN " & _
             " FROM GESTION.VENTES1 T01 " & _
             " JOIN GESTION.VENDEUR T02 " & _
             " ON T01.COVEN = T02.COVEN " & _
             " WHERE (T01.BONDA||T01.BONDM||T01.BONDJ = '" & StrDate & "' AND " & _
             " T01.COVEN = 'V12 ') "

    'Pour avoir notre champ Date1 nous faisons une concaténation sur l'année, le mois et le jour.
       
	RsAs400.Open strSql

    Do Until RsAs400.EOF
        i = 1
        For Each Fld In RsAs400.Fields
            Select Case i
            Case 1
                Champ1 = Nz(Fld.Value)
            Case 2
                Champ2 = Nz(Fld.Value)
            Case 3
                Champ3 = Nz(Fld.Value)
            Case 4
                Champ4 = Nz(Fld.Value)
            Case 5
                Champ5 = Nz(Fld.Value)
            Case 6
                Champ6 = Nz(Fld.Value)
            Case Else
            End Select
            i = i + 1
        Next Fld
        If Rsdb.State = 0 Then
            ' Ouverture de la table et remplissage
            Rsdb.Open "[Tbl_ImportCa]", Cnndb, adOpenKeyset, adLockOptimistic
        End If
        ' Attribution des valeurs aux champs correspondants
        With Rsdb
            .AddNew Array("N°_Bon", "Code_Ven", "Date1", "Code_client", "CA_Bon", "Nom_Ven"), _
                    Array(Champ1, Champ2, Champ3, Champ4, Champ5, Champ6)
            .Update
        End With
        RsAs400.MoveNext
    Loop

    'La table est remplie et il faut maintenant s'occuper du dernier champ qui nous intéresse
    'c'est-à-dire le champ "Date_Bon". Nous allons nous servir de la fonction Update.
    DoCmd.SetWarnings False    'Stoppe les messages d'alerte
    DoCmd.RunSQL "Update Tbl_Import_Ca Set Date_Bon " & _
                 "= Right([Date1],2) & '/' & Mid([Date1],3,2) & '/' & Left([Date1],2)"
    DoCmd.SetWarnings True

Exit_Import_Ca:
    'Ferme la connexion et libère les variables
    Rsdb.Close
    RsAs400.Close
	Call CloseConnection(Cnndb)
	Call CloseConnection(CnnAs400)
    Set CnnAs400 = Nothing
    Set Cnndb = Nothing
    Set RsAs400 = Nothing
    Set Rsdb = Nothing
Exit Sub

Error_Import_Ca:
MsgBox "Erreur importation " & Err.Number & "  " & Err.Description
Resume Exit_Import_Ca

End Sub
----------------------------------------------------------------------------------------------------------

Sub CloseConnection(Cnx As ADODB.Connection)
    With Cnx
        If .State = adStateOpen Then
           .Close
        End If
    End With
End Sub

    'Nous créons la requête.
    strSql = " " & _
             " SELECT T01.NOBON ,T01.COVEN ," & _
             " Digits(T01.BONDA)Concat Digits(T01.BONDM)Concat Digits(T01.BONDJ) ," & _
             " T01.COCLI ,T01.MOBON ,T02.NOVEN " & _
             " FROM GESTION.VENTES1 T01 " & _
             " JOIN GESTION.VENDEUR T02 " & _
             " ON T01.COVEN = T02.COVEN " & _
             " WHERE (Digits(T01.BONDA)Concat Digits(T01.BONDM)Concat Digits(T01.BONDJ) = '" & StrDate & "' AND " & _
             " T01.COVEN = 'V12 ') "

Private Sub Cmd_Valid_Click()
  Call Import_Ca
  DoEvents
  MsgBox "L'importation est terminée."
End Sub

Public Sub Maj_QryImport()  'Mise à jour de la requête Qry_Import + création des tables et remplissage
    On Error GoTo Error_Maj_QryImport
    Dim oDb As DAO.Database
    Dim StrDat As String
    Dim oQdf As DAO.QueryDef
    Dim StrSql As String

    'Attribue à la variable la valeur de la liste déroulante du formulaire d'accueil
    StrDat = Form_Frm_Accueil.[Txt_DateBon].Value
    StrDat = Right(StrDat, 2) & Mid(StrDat, 4, 2) & Left(StrDat, 2)

    Set oDb = CurrentDb
    'Redéfinit la requête en y ajoutant la variable date choisie
    Set oQdf = oDb.QueryDefs("Qry_Import")
    StrSql = " " & _
           " SELECT T01.NOBON, T01.COVEN, T01.BONDA||T01.BONDM||T01.BONDJ, T01.COCLI, T01.MOBON, T02.NOVEN " & _
           " FROM GESTION.VENTES1 T01 " & _
           " JOIN GESTION.VENDEUR T02 " & _
           " ON T01.COVEN = T02.COVEN " & _
           " WHERE (T01.BONDA||T01.BONDM||T01.BONDJ = '" & StrDat & "' AND " & _
           " T01.COVEN = 'V12 ') "

    'Applique la modification
    oQdf.SQL = StrSql

Exit_Maj_QryImport:
    oDb.Close
    Set oDb = Nothing
    Set oQdf = Nothing
    Exit Sub

Error_Maj_QryImport:
    If Err.Number = 3265 Then
        MsgBox "La requête n'existe pas"
    Else
        MsgBox Err.Number & "  " & Err.Description
    End If
    Resume Exit_Maj_QryImport
End Sub