Importation dans excel de données d'une source as400 (i5, iseries) sans définition de data source odbc. version 2 (avec ou s

Commenter

Contenu du snippet

Bonjour,
le code suivant, à placer dans un module vba (vb), permet de récupérer dans excel le contenu de tout fichier AS400 (pour autant qu'on dispose des droits requis sur l'AS400) dans une feuille excel de votre choix à partir de la cellule de votre choix.

Pour ce faire, il faut simplement disposer d'une connection AS400, du software standard Iseries Access for Windows installé avec le driver ODBC standard, et d'un Userid avec les droits pour ce genre d'opération. (Contrainte AS400)

Il faut cocher la référence à "Microsoft ActiveX data Objects 2.6 Library" pour que ce code fonctionne.

A adapter a l'environnement de l'utilisateur :
Data Source = xxx.xxx.xxx.xxx : Mettre ici l'IP de l'AS400 ou son nom DNS
USER ID = user : mettre ici le Userprofile AS400 à utiliser
PASSWORD = Password : mettre ici le password AS400 du UserProfile choisi.

1 Seule procédure, avec ou sans sélection de Record (clause Where):

ReadFileI5Full

ReadFileI5Full : Importe le contenu avec ou sans filtrage (clause Where), d'un membre d'un fichier AS400
Usage : ReadFileI5Full (Input_File as string, Target_Worksheet as string, Target_Range as string)
Input_File : Fichier As400 à importer (avec ou sans Clause (Where)
peut être Si pas de Clause Where (Importante complète)
soit - Nom_Librairie.Fichier
soit - Nom_librairie.fichier(Membre) (Membre peut valoir *LAST ou *FIRST avec cette syntaxe)
soit - Nom_librairie.fichier Membre (Membre *LAST ou *FIRST non supporté avec cette syntaxe)

Si Clause Where (Importation Sélective)
Soit - Nom_Librarie.Fichier Where (conditions)
Soit - Nom_librairie.Ficher Membre Where (conditions)
Attention : 1) La/les condition(s) doivent être entourées de parenthèses
2) les valeurs de comparaisons doivent être entourées de simples quotes, numériques ou pas (Non testé avec champs spéciaux !!)
3) Les noms de membres *FIRST & *LAST ne sont pas supportés avec une clause Where

Exemples Valides avec Clause Where pour Input file
Mylib.Myfile Where ((Fieldx>'0005' AND Fieldy='FR') OR (Fieldx='0005' AND Fieldy<>'FR')
Mylib.Myfile MyMember Where (Fieldw<>"BONJOUR")
Exemples Erronés avec Clause Where pour input file
Mylib.Myfile(MyMember) Where(condition) ---> Clause Where ignorée -> Import Complet !!!!
Mylib.Myfile *FIRST Where(condition) ---> erreur SQL : *FIRST (ni *LAST) n'est pas reconnu

Target_Worksheet : Feuille excel de destination
Doit être un nom valide d'une feuille excel. (onglet). Si la feuille existe elle est vidée avant l'import, sinon elle est créée.
Target_Range : Cellule de départ (haut, gauche) pour l'import des données. Doit être un nom de cellule valide. (Ex : "A1")

L'import retourne en première ligne les noms de champs, puis les données.

TRUC : Pour récupérer uniquement les noms des champs, spécifier simplement une clause 'Where' avec une condition impossible comme (Field1<>Field1)

Source / Exemple :

Option Explicit

Public Sub ReadFileI5Full(ByVal Input_File As String, ByVal Target_worksheet As String, ByVal Target_range As String)
'ReadFileI5Full : get I5 data from Lib.file(member) and insert that in Worksheet at désired range cell
'usage : ReadFileI5Full (File, Worksheet, Range)
' Input_File : I5 File to be imported (With ou Without Where Clause) : Input_File = SqlString
'  can be
'   WHEN NO 'Where' CLAUSE (Full Member Import)
'            either  Library_Name.File
'                or  Library_Name.File(Member) (With This Syntax Member may also be *FIRST or *LAST)
'                or  Library_Name.File Member  (Member *FIRST or *LAST unsupported with this syntax)
'
'   WHEN 'Where' Clause (Selective Import)
'            Either - Library_Name.File Where (conditions)
'                or - Library_Name.File Member Where (conditions)
'
'     WARNING          1) Condition(s) must be surrounded by brackets ( )
'                      2) Comparison values must be surrounded by single quotes, numeric or not (Not tested with specials fields !!)
'                      3) Special Member Names *FIRST & *LAST non supported with Where Clause
'
'             Valid Examples With Where Caluse for Input_file parameter
'                      Mylib.Myfile Where ((Fieldx>'0005' AND Fieldy='FR') OR (Fieldx='0005' AND Fieldy<>'FR')
'                       Mylib.Myfile MyMember Where (Fieldw<>"HELLO")
'             Erroneous Examples with Where Close for Input_file parameter
'                      Mylib.Myfile(MyMember) Where(condition)  ---> Clause Where ignored -> Full Import  !!!!
'                      Mylib.Myfile *FIRST    Where(condition)  ---> SQL Error : *FIRST (nor *LAST) is not understood

' Target_Worksheet : Must be a valid Worksheet Name : if exists : cleared before fullfillment
'                                              if not exists : will be created
' Target_Range     : Must be a valid cell name : Example "A1"
'
'
' TIP : To get Only Fields names, just specify a 'Where' clause with a non possible condition as (Field1<>Field1)



    On Error GoTo ErrorHandler
 
    Dim cn          As New ADODB.Connection
    Dim rs          As New ADODB.Recordset
    Dim sConn       As String
    Dim SqlString   As String
    Dim FileName    As String
    Dim DSN_Name As String
    Dim ws          As String 'Results Storing Worksheet name
    Dim Rg          As String 'results Cells top left
    Dim cellule     As Range
    Dim CompA       As Integer
    Dim idx         As Long
    Dim sheet_found As Boolean
    Dim ActShName   As String
    Dim Rec_nbr     As Long   'Record Set record Count
    

        
        
 
    sConn = "provider=IBMDA400;Data source=xxx.xxx.xxx.xxx;USER ID=user;PASSWORD=Password"
    FileName = Trim(Input_File)
    ws = Trim(Target_worksheet)
    Rg = Trim(Target_range)
        
    'check target Worsksheet exists and if not build
    sheet_found = False
    For idx = 1 To Sheets.Count
        If Sheets(idx).Name = ws Then
            Application.DisplayAlerts = False
            Sheets(idx).Cells.Clear
            Application.DisplayAlerts = True
            sheet_found = True
            Exit For
        End If
    Next idx
    'Build Ws
    If Not sheet_found Then
        ActShName = ActiveSheet.Name
        Sheets.Add
        ActiveSheet.Name = ws
        Sheets(ActShName).Activate
    End If
 
    'Open Connection
    cn.ConnectionString = sConn
    cn.Open
    SqlString = "SELECT * FROM " & FileName & ""
    
    'open record Set
    rs.Open SqlString, cn
    Rec_nbr = rs.RecordCount
    
    
    
    'Paste Fields names in line 1
    Set cellule = Worksheets(ws).Range(Rg)
    For CompA = 0 To rs.Fields.Count - 1
        cellule.Offset(0, CompA).Value = rs.Fields(CompA).Name
    Next CompA
    'Paste results line above names
    Worksheets(ws).Range(Rg).Offset(1, 0).CopyFromRecordset rs

    rs.Close
    cn.Close
    Set cn = Nothing
    Set rs = Nothing
    'MsgBox Rec_nbr & " records imported from I5"
 
    Exit Sub
ErrorHandler:
    ' clean up
    If Not cn Is Nothing Then
        If cn.State = adstateopen Then cn.Close
    End If
    Set cn = Nothing
    If Not rs Is Nothing Then
        If rs.State = adstateopen Then rs.Close
    End If
    If Err <> 0 Then
      MsgBox Err.Source & "-->" & Err.Description, , "Error"
    End If
 
End Sub

Conclusion :

Conclusion d'origine
---------------------
J'espère que ce code pourra aider quelqu'un. Il m'a considérablement aidé dans mes import dans Excel de mes DB As400.
Sa mise en oeuvre est très simple et ne nécessite quasi rien.

Je le stocke dans un .XLA et y fais référence via mes applications de manière indépendante.

Godzestla.

A voir également

S'inscrire maintenant

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.