En fait je transfert un fichier EXCEL dans une bibliothèque de l'AS400.
C'est une macro complémentaire qui est installé sur EXCEL.
Voici les macros qui permettent d'importer des fichiers de l'AS400 :
Sub requeteDTF(Dtf As String, destination As String, plage As Range, Optional Entete = False, Optional MiseEnFormeColonne = False)
'
Dim chemin_transfert As String
Dim fichier_transfert As String
Dim lignes As Long
chemin_transfert = "U:\"
fichier_transfert = "transfertDTF.xls"
Application.Cursor = xlWait
Menage destination, plage ' ménage dans la feuille avant le transfert
supprimer_fichier chemin_transfert & fichier_transfert
lignes = transfert(Dtf)
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FileExists(chemin_transfert & fichier_transfert) Then
charger_fichier destination, plage, chemin_transfert, fichier_transfert, Entete
supprimer_fichier chemin_transfert & fichier_transfert ' ménage après le transfert
Else: MsgBox "Le fichier " & Dtf & " n'est pas correct. Il doit générer le fichier u:\transfertDTF.xls", , "MODIFIER LE FICHIER TRANSFERT DE DONNEES"
End If
'REPRISE CALCUL AUTO
Application.Calculation = xlCalculationAutomatic
Calculate
Application.Cursor = xlDefault
If MiseEnFormeColonne Then affichage_correct
End Sub
Function transfert(Dtf As String) As Integer
'
' DLL cwbx.dll
' Menu Outils-Références IBM AS/400 iSeries Access for Windows ActiveX Object Library
Dim dt As New cwbx.DatabaseTransfer
On Error Resume Next ' Diffère la gestion d'erreur.
Err.Clear
dt.Transfer Dtf
If Err.Number <> 0 Then
Msg = "LE FICHIER " & Dtf & " N'A PAS GENERE DE RESULTAT" & Chr(13) & Chr(13) & Chr(13) & "L'erreur # " & Str(Err.Number) & " a été générée par " _
& Err.Source & Chr(13) & Err.Description
MsgBox Msg, , "AUCUNE DONNEE EXPLOITABLE POUR LA REQUETE", Err.HelpFile, Err.HelpContext
End If
transfert = dt.TransferResults.RowsTransferred
End Function
Function transfertSQL(systeme As String, SQL As String, format_date As cwbdtDateFormatEnum) As Integer
'
' DLL cwbx.dll
' Menu Outils-Références IBM AS/400 iSeries Access for Windows ActiveX Object Library
Dim as400 As New cwbx.AS400System
Dim dlr As New cwbx.DatabaseDownloadRequest
as400.Define systeme
Set dlr.system = as400
dlr.AS400File = "-"
dlr.pcFile = "U:\TransfertSQL.xls"
dlr.pcFile.FileType = cwbdtBIFF8
dlr.Convert65535 = True
dlr.Format.SetDateFormat format_date
dlr.QueryDataTransferSyntax = False
dlr.Query = SQL
On Error Resume Next ' Diffère la gestion d'erreur.
Err.Clear
dlr.Download
' Vérifie la présence d'erreurs, puis affiche le message.
If Err.Number <> 0 Then
Msg = "LE FICHIER " & Dtf & " N'A PAS GENERE DE RESULTAT" & Chr(13) & Chr(13) & Chr(13) & "L'erreur # " & Str(Err.Number) & " a été générée par " _
& Err.Source & Chr(13) & Err.Description
MsgBox Msg, , "AUCUNE DONNEE EXPLOITABLE POUR LA REQUETE", Err.HelpFile, Err.HelpContext
End If
transfertSQL = dlr.TransferResults.RowsTransferred
End Function
Sub charger_fichier(onglet As String, plage As Range, chemin_transfert As String, fichier_transfert As String, Optional Entete = False)
'
'
' V1 : prise en compte des valeurs vides
Dim colonnes As Long
Dim lig As Long
colonnes = 1
Workbooks.Open Filename:=(chemin_transfert & fichier_transfert)
' le paramètres lignes est parfois incorrect. La DLL retourne 0 lignes alors que plusieurs lignes sont retournées.
' On recalcule le nombre de lignes d'une autre façon.
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
lig = Selection.Rows.Count
While Cells(1, colonnes) <> ""
colonnes = colonnes + 1
Wend
If Entete Then
Range("A1").Select
Range(Selection, Cells(Selection.Row + lig, colonnes - 1)).Select
Else:
lig = Selection.Rows.Count
Range("A2").Select
Range(Selection, Cells(Selection.Row + lig - 1, colonnes - 1)).Select
End If
Selection.Copy
ThisWorkbook.Activate
ThisWorkbook.Sheets(onglet).Cells(plage.Row, plage.Column).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("A1").Select
' Le presse papier est désactivé pour ne pas être questionné lors de la fermeture du fichier
Application.CutCopyMode = False
Workbooks(fichier_transfert).Close False
ThisWorkbook.Activate
End Sub
Sub supprimer_fichier(fichier As String)
'
'
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FileExists(fichier) Then fs.deletefile fichier, True
End Sub
Sub appel_SQL(systeme As String, cellule As Range, destination As String, plage As Range, Optional Entete = False, Optional MiseEnFormeColonne = False)
Dim SQL As String
Dim chemin_transfert As String
Dim fichier_transfert As String
Dim format_date As cwbdtDateFormatEnum
If systeme = "" Then systeme = Worksheets("SQL").Cells(cellule.Row, cellule.Column + 1).Value
SQL = Worksheets("SQL").Cells(cellule.Row, cellule.Column).Value
Select Case Worksheets("SQL").Cells(cellule.Row, cellule.Column + 2).Value
Case "EUR"
format_date = cwbdtDateFmtEUR
Case "ISO"
format_date = cwbdtDateFmtISO
Case "YrMonDay"
format_date = cwbdtDateFmtYrMonDay
Case "DayMonYr"
format_date = cwbdtDateFmtDayMonYr
Case "USA"
format_date = cwbdtDateFmtUSA
Case Else
MsgBox "Le format date de la requête n'est pas correct."
SQL = ""
End Select
If SQL <> "" Then
pointeur = Application.Cursor
chemin_transfert = "U:\"
fichier_transfert = "transfertSQL.xls"
Application.Cursor = xlWait
Menage destination, plage ' ménage dans la feuille avant le transfert
supprimer_fichier chemin_transfert & fichier_transfert ' ménage avant le transfert
lignes = transfertSQL(systeme, SQL, format_date)
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FileExists(chemin_transfert & fichier_transfert) Then
charger_fichier destination, plage, chemin_transfert, fichier_transfert, Entete
supprimer_fichier chemin_transfert & fichier_transfert ' ménage après le transfert
End If
'REPRISE CALCUL AUTO
Application.Calculation = xlCalculationAutomatic
Calculate
Application.Cursor = xlDefault
If MiseEnFormeColonne Then affichage_correct
Else: MsgBox "Pas de requête appelée dans l'onglet SQL"
End If
End Sub
Sub Menage(destination As String, plage As Range)
Dim existe As Boolean
Dim i As Integer
existe = False
i = 1
While i < Sheets.Count + 1 And Not existe ' Test de l'existance de la feuille
a = Sheets(i).Name
If StrConv(Sheets(i).Name, vbUpperCase) = StrConv(destination, vbUpperCase) Then existe = True
i = i + 1
Wend
If existe Then
Sheets(destination).Select 'ARRET DU CALCUL AUTO
Application.Calculation = xlCalculationManual
If Sheets(destination).FilterMode = True Then 'ENLEVER LES FILTRES
Selection.AutoFilter Field:=1, Criteria1:=310
ActiveSheet.ShowAllData
End If
'EFFACER LES DONNEES
Range(Cells(plage.Row, plage.Column), Cells(plage.Row + plage.Rows.Count, plage.Column + plage.Columns.Count - 1)).ClearContents
Range("A1").Select
Else
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = destination
End If
End Sub
Sub affichage_correct()
Cells.Select
Cells.EntireColumn.AutoFit
Range("A1").Select
End Sub
Reste maintenant à exporter
