AS400ToExcel, copie d'écran AS400 vers Excel

**mutsum1** · 25/10/2012, 12h02

Bonjour à tous,

J’ai développé une petite macro pour l’émulateur PCSWS d’IBM, qui permet une copie d’écran AS400 vers Excel.

Elle fonctionne quel que soit l'écran et présente de gros avantages par rapport à un traditionnel copier/coller, à savoir :

* Conservation des champs tels qu’ils ont été définis dans le DSPF. Un champ par cellule Excel, sans découpage.
* Si présence d’un sous-fichier, export intégral en parcourant toutes les pages.
* Export en couleur ou en noir et blanc.

Voilà le code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
[PCOMM SCRIPT HEADER]
LANGUAGE=VBSCRIPT
DESCRIPTION=Export AS400 Screen to Excel
[PCOMM SCRIPT SOURCE]
OPTION EXPLICIT

Dim ExcelApp, Wrkbook, Wrksheet
Dim FieldList, Field
Dim I, J, Lgn, Lrg, Cols(132)
Dim Fld1, Fld2, PLgn, NLgn, PSfl, NSfl
Dim Ref, Fin, Color

autECLSession.SetConnectionByName(ThisSessionName)

'--- Configuration ----------------------------------------

NSfl = 4      ' Nb de ligne identiques minimum pour détection présence sous-fichier

Color = Msgbox("SORTIE EN COULEURS ?" & vbCrLf & vbCrLf & "(Couleurs Background & underline non gérées)", vbYesNoCancel, "Type de sortie" )
If Color <> vbCancel Then

'--- Ouvre Excel ------------------------------------------

On Error Resume Next
Err.Clear

Set ExcelApp = GetObject(,"Excel.Application")        ' Si déjà ouvert
If Err.Number = 429 Then
  Set ExcelApp = CreateObject("Excel.Application")    ' Sinon
End If

ExcelApp.Visible = True
ExcelApp.WorkBooks.Add(1)

Set WrkBook  = ExcelApp.ActiveWorkbook
WrkBook.Sheets(1).Name = "Export AS400"

Set Wrksheet = Wrkbook.ActiveSheet

'--- Lit le premier écran ---------------------------------

Set FieldList = autECLSession.autECLPS.autECLFieldList
FieldList.Refresh()

'--- Trouve la position du sous-fichier -------------------

Fld1 = ""
Fld2 = "."      ' Différent de blanc pour la première détection
PLgn = 0
NLgn = 0
PSfl = autECLSession.autECLPS.NumRows

For I = 1 to FieldList.Count
  Set Field = FieldList(I)

  If Field.StartRow <> PLgn Then       ' Changement de ligne

    If Fld2 = Fld1 Then                ' Mêmes zones
      NLgn = NLgn + 1
    Else
      If NLgn > NSfl Then
        PSfl = PLgn - NLgn
        NSfl = NLgn
      End If
      NLgn = 1
    End If

    Fld1 = Fld2
    Fld2 = ""
  End If

  Fld2 = Fld2 & Field.StartCol & ";"
  PLgn = Field.StartRow
Next

'--- Détermine le colonnage en sortie ---------------------

For I = 1 to FieldList.Count
  Set Field = FieldList(I)

  If Field.Display And Field.Length > 0 Then
    If Trim( Field.GetText()) <> ""  Or  Not Field.Protected Then

      Cols( Field.StartCol ) = 1

    End If
  End If
Next

J = 1
Lrg = 1
Cols( autECLSession.autECLPS.NumCols + 1 ) = 1

For I = 2 to autECLSession.autECLPS.NumCols + 1
  If Cols( I ) = 0 Then
    Lrg = Lrg + 1
  Else
    If Lrg = 1 Then
      Wrksheet.Cells( 1, J ).ColumnWidth = 0.83   ' Petite bizarrerie d'Excel
    Else
      Wrksheet.Cells( 1, J ).ColumnWidth = 1.43 * Lrg - 0.72
    End If

    Lrg = 1
    J = J + 1
  End If
  Cols( I ) = J
Next

'--- Mise en page globale ---------------------------------

Wrksheet.Cells.Font.Name = "Courier New"
Wrksheet.Cells.Font.Size = 12

'--- Export Ecran unique ----------------------------------

If PSfl = autECLSession.autECLPS.NumRows Then

  If Color = vbYes Then Wrksheet.Range( "A1", Colonne( Cols( autECLSession.autECLPS.NumCols )) & autECLSession.autECLPS.NumRows ).Interior.Color = 0

  For I = 1 to FieldList.Count
    Set Field = FieldList(I)

    If Field.Display And Field.Length > 0 Then
      If Trim( Field.GetText()) <> ""  Or  Not Field.Protected Then

        With Wrksheet.Cells( Field.StartRow, Cols( Field.StartCol ))

          .Value = CExcel( Field.GetText())
          .Font.Color = Couleur( Field.StartRow, Field.StartCol )

          If Not Field.Protected Then .Font.Underline = 2
          If Field.HighIntensity Then .Font.Bold = True

        End With

      End If
    End If
  Next

Else

'--- Remonte en haut du sous-fichier ----------------------

  autECLSession.autECLOIA.WaitForAppAvailable
  autECLSession.autECLOIA.WaitForInputReady

  Do while PageMove( "[roll down]" ) = 0
  Loop

'--- Export Entête ----------------------------------------

  If Color = vbYes Then Wrksheet.Range( "A1", Colonne( Cols( autECLSession.autECLPS.NumCols )) & PSfl ).Interior.Color = 0

  For I = 1 to FieldList.Count
    Set Field = FieldList(I)

    If Field.Display And Field.Length > 0 Then
      If Trim( Field.GetText()) <> ""  Or  Not Field.Protected Then

        If Field.StartRow < PSfl Then

          With Wrksheet.Cells( Field.StartRow, Cols( Field.StartCol ))

            .Value = CExcel( Field.GetText())
            .Font.Color = Couleur( Field.StartRow, Field.StartCol )

            If Not Field.Protected Then .Font.Underline = 2
            If Field.HighIntensity Then .Font.Bold = True

          End With
        End If

      End If
    End If
  Next

'--- Export Sous-Fichier ----------------------------------

  Fin = 0
  Ref = 0

  Do while Fin = 0

    If Color = vbYes Then Wrksheet.Range( "A" & PSfl + Ref, Colonne( Cols( autECLSession.autECLPS.NumCols )) & PSfl + NSfl + Ref ).Interior.Color = 0

    For I = 1 to FieldList.Count
      Set Field = FieldList(I)

      If Field.Display And Field.Length > 0 Then
        If Trim( Field.GetText()) <> ""  Or  Not Field.Protected Then

          If Field.StartRow >= PSfl And Field.StartRow <= PSfl + NSfl Then

            Lgn = Field.StartRow + Ref

            With Wrksheet.Cells( Lgn, Cols( Field.StartCol ))

              .Value = CExcel( Field.GetText())
              .Font.Color = Couleur( Field.StartRow, Field.StartCol )

              If Not Field.Protected Then .Font.Underline = 2
              If Field.HighIntensity Then .Font.Bold = True

            End With
          End If

        End If
      End If
    Next

    ' Page suivante

    autECLSession.autECLOIA.WaitForAppAvailable
    autECLSession.autECLOIA.WaitForInputReady

    Fin = PageMove( "[roll up]" )

    If Fin = 0 Then
      Ref = Ref + NSfl + 1
      FieldList.Refresh()
    End If

  Loop

'--- Export Bas de page -----------------------------------

  If Color = vbYes Then Wrksheet.Range( "A" & PSfl + NSfl + Ref, Colonne( Cols( autECLSession.autECLPS.NumCols )) & autECLSession.autECLPS.NumRows + Ref ).Interior.Color = 0

  For I = 1 to FieldList.Count
    Set Field = FieldList(I)

    If Field.Display And Field.Length > 0 Then
      If Trim( Field.GetText()) <> ""  Or  Not Field.Protected Then

        If Field.StartRow >= PSfl + NSfl Then

          Lgn = Field.StartRow + Ref

            With Wrksheet.Cells( Lgn, Cols( Field.StartCol ))

              .Value = CExcel( Field.GetText())
              .Font.Color = Couleur( Field.StartRow, Field.StartCol )

              If Not Field.Protected Then .Font.Underline = 2
              If Field.HighIntensity Then .Font.Bold = True

            End With
        End If

      End If
    End If
  Next

'--- Remonte en haut du sous-fichier ----------------------

  autECLSession.autECLOIA.WaitForAppAvailable
  autECLSession.autECLOIA.WaitForInputReady

  Do while PageMove( "[roll down]" ) = 0
  Loop

End If

'--- Clean up ---------------------------------------------

Set Wrksheet = Nothing
Set Wrkbook  = Nothing
Set ExcelApp = Nothing

End If

'----------------------------------------------------------
'--- End --------------------------------------------------
'----------------------------------------------------------

'### Conversion zone Excel ################################

Function CExcel(ByVal texte)

  CExcel = texte

  Select case left( texte, 1 )
    Case "=", "+", "-", "*", "/"
      CExcel = "'" & texte
    Case Else
      If IsNumeric( texte ) And Len( texte ) > 15 Then CExcel = "'" & texte
      If IsDate( texte ) And InStr( texte, "/" ) > 0 Then CExcel = DateValue( texte )
  End Select

End Function

'### Gestion Pagination ###################################

Function PageMove(ByVal Sens)

  PageMove = 0

  autECLSession.autECLPS.SendKeys Sens

  Do while autECLSession.autECLOIA.InputInhibited <> 0
    Select Case autECLSession.autECLOIA.InputInhibited
      Case 0
      Case 1, 2, 3, 4
        autECLSession.autECLOIA.WaitForInputReady(100)
      Case 5
        PageMove = 1
        autECLSession.autECLPS.SendKeys "[reset]"
        autECLSession.autECLPS.Wait(100)
    End Select
  loop

  If autECLSession.autECLPS.GetText( autECLSession.autECLPS.NumRows, 1, 10 ) <> space(10) Then PageMove = 1

End Function

'### Couleurs #############################################

Function Couleur(ByVal Row, ByVal Col)

  if Color = vbNo then
    Couleur = 0                       ' Noir
  elseif autECLSession.autECLPS.waitforattrib(Row, Col, "01", , 2, 1 )  then
    Couleur = RGB( 120, 144, 240 )    ' Bleu
  elseif autECLSession.autECLPS.waitforattrib(Row, Col, "02", , 2, 1 )  then
    Couleur = RGB(  36, 216,  48 )    ' Vert
  elseif autECLSession.autECLPS.waitforattrib(Row, Col, "03", , 2, 1 )  then
    Couleur = RGB(  88, 240, 240 )    ' Turquoise
  elseif autECLSession.autECLPS.waitforattrib(Row, Col, "04", , 2, 1 )  then
    Couleur = RGB( 240,  24,  24 )    ' Rouge
  elseif autECLSession.autECLPS.waitforattrib(Row, Col, "05", , 2, 1 )  then
    Couleur = RGB( 255,   0, 255 )    ' Rose
  elseif autECLSession.autECLPS.waitforattrib(Row, Col, "07", , 2, 1 )  then
    Couleur = RGB( 255, 255, 255 )    ' Blanc
  elseif autECLSession.autECLPS.waitforattrib(Row, Col, "0E", , 2, 1 )  then
    Couleur = RGB( 255, 255,   0 )    ' Jaune
  else
    Couleur = 0          ' Noir
  end if

End Function

'### Nom de colonne Excel #################################

Function Colonne(ByVal No)

Colonne = ""
If No > 26 Then
  Colonne = Chr( Int( No / 26 ) + 64 ) & Chr( No Mod 26 + 64 )
Else
  Colonne = Chr( No + 64 )
End If

End Function

Ce programme est à sauvegarder en .MAC dans votre répertoire de macro. Généralement :
* Pour Seven : <user>\AppData\Roaming\IBM\Client Access\Emulator\Private
* Pour XP : C:\Program Files\IBM\Client Access\Emulator\Private

(Si vous ne trouvez pas votre répertoire, enregistrez une macro via l’émulateur, et recherchez là ensuite sur votre disque.)

Vous pourrez ensuite la lancer via le menu de l’émulateur ou configurer votre clavier pour lancer cette macro d’une simple combinaison de touche.

Restrictions connues :

La fonction « waitforattrib », qui permet de retrouver la couleur d’un champ, ne fonctionne pas si ce champ est en inverse vidéo, ou en souligné.
Dans ces cas-là, la couleur utilisée sera le vert. Un incident a été remonté à IBM pour corriger ce point.

Certaines listes système ne remontent ni erreur ni message en fin de sous-fichier. La macro ne sera pas en mesure dans ce cas de détecter la fin de son traitement.
Son interruption devra être effectuée manuellement via le bouton correspondant ou le menu de l’émulateur.

Merci de vos retours

**Simka1000** · 25/10/2012, 13h17

Pour ma part bien que je sois en W7 le chemin d'installation du fichier mac est :
C:\ProgramData\IBM\Client Access\Emulator\private

Sinon , ça semble fonctionner correctement pour les écrans venant des commandes Iseries (testé avec WRKACTJOB/WRKWTR/WRKSPLF) mais plutôt aléatoirement pour les écrans venant de logiciels/progiciels autres ( le defilement ne se fait pas toujours dans un SF etc etc...) mais il est possible que cela vienne du sw...

**FORMULARY** · 25/10/2012, 13h49

Je suis aussi sous windows 7 et mon répertoire est bien celui sous utilisateurs.

Les sous-fichiers IBM marchent normalement, mais il y a la ligne "A suivre" qui sépare chaque page.

Mes sous-fichiers d'application ne sont pas pris comme des sous-fichiers et j'ai donc un imprim écran simple dans Excel.

Quand j'aurais le temps, je regarderais la macro de plus près.

En tout cas, un grand merci à mutsum1. Sa macro est très sympa

**mutsum1** · 25/10/2012, 15h31

Merci pour ces premiers retours.

Effectivement je n'ai testé que la pagination classique.
Vous pouvez facilement l'adapter à vos progiciels en modifiant l'appel à la sous-routine "PageMove". Il suffit de passer en paramètre la fonction permettant la pagination.
Mais il sera difficile de faire en sorte que cela marche dans tous les cas. Des touches de fonction utilisées sur certains progiciels auront une autre utilité ailleurs.

Pour le "A suivre", cette donnée est entièrement intégrée par l'AS400 dans le sous-fichier, comme une ligne classique. La macro ne fait pas de distinction.
Pour un sous-fichier déclaré avec un SFLEND simple, cette ligne n'apparaît pas.

**mutsum1** · 25/10/2012, 16h49

Je viens d'effectuer une première modification en ligne 314.

J'ai remplacé

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

If autECLSession.autECLPS.GetText(24, 1, 10) <> space(10) Then PageMove = 1

par

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

If autECLSession.autECLPS.GetText( autECLSession.autECLPS.NumRows, 1, 10 ) <> space(10) Then PageMove = 1

pour tenir compte des écrans en 132 colonnes.

On me remonte également quelques soucis avec STRSQL.
Effectivement STRSQL gère son sous-fichier de façon personnel, une seule zone par ligne, avec les entêtes intégrés. De plus il fait partie des écrans système qui ne provoque pas d'avertissement en fin de fichier (la mention "fin des données" est aussi intégrée au sous-fichier). Donc la macro boucle, il faut l’arrêter à la main.

Je réfléchit à une macro spécifique pour lui, gérant également la pagination horizontale, wait and see...

**didibogs** · 14/11/2013, 15h39

merci pour cette macro. très utile!

mon écran système fait partie de la catégorie qui ne provoque pas d'avertissement en fin de fichier, donc la macro loop à l'infini.
J'ai remarqué cependant que lorsque le [PAGE DOWN] sur la dernière page provoque un changement sur "InputInhibited" mais je n'arrive pas à en tirer profit

Y-t-il des news sur le "wait and see"?...

Merci encore

**BrigitteG** · 04/12/2013, 14h15

Merci pour cette macro.

J'ai un petit soucis la pagination, la macro continue de charger même quand elle arrive à la fin du fichier avec la commande DSPDBF, wrkqry. il faut l'arrêter, ce qui n'est pas le cas avec wrkactjob

**mutsum1** · 28/01/2014, 15h25

Bonjour,

Désolé pour le retard, je n'avais pas activé la notification

Même si c'est sans doute trop tard, je vais répondre quand même.

Les listes systèmes présentent pas mal de particularités selon les commandes, dont la plus préoccupante est pour certaines de ne pas générer d'alerte de fin de liste, comme le fait tout écran classique.

Il s'agit principalement des commandes listant un résultat non prédéfini, comme le contenu d'un fichier par exemple. On aura donc le problème avec DSPDBF, DSPPFM, RUNQRY, STRSQL, pour ne citer que ceux-là.

Inversement, des commandes à sortie fixe, comme PDM ou WRKACTJOB, ne posent aucun problème.

Pour palier à cette problématique, j'ai modifié la fonction de pagination pour que la macro détecte le petit message marqué en fin de liste, message qui peut d'ailleurs être différent selon les écrans. Si vous êtes impacté par ce bug, vous pouvez prendre la nouvelle version de la macro ci-dessous :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
[PCOMM SCRIPT HEADER]
LANGUAGE=VBSCRIPT
DESCRIPTION=Export AS400 Screen to Excel
[PCOMM SCRIPT SOURCE]
OPTION EXPLICIT

Dim ExcelApp, Wrkbook, Wrksheet
Dim FieldList, Field
Dim I, J, Lgn, Lrg, Cols(132)
Dim Fld1, Fld2, PLgn, NLgn, PSfl, NSfl
Dim Ref, Fin, Color

autECLSession.SetConnectionByName(ThisSessionName)

'--- Configuration ----------------------------------------

NSfl = 4      ' Nb de ligne identiques minimum pour détection présence sous-fichier

Color = Msgbox("SORTIE EN COULEURS ?" & vbCrLf & vbCrLf & "(Couleurs Background & underline non gérées)", vbYesNoCancel, "Type de sortie" )
If Color <> vbCancel Then

'--- Ouvre Excel ------------------------------------------

On Error Resume Next
Err.Clear

Set ExcelApp = GetObject(,"Excel.Application")        ' Si déjà ouvert
If Err.Number = 429 Then
  Set ExcelApp = CreateObject("Excel.Application")    ' Sinon
End If

ExcelApp.Visible = True
ExcelApp.WorkBooks.Add(1)

Set WrkBook  = ExcelApp.ActiveWorkbook
WrkBook.Sheets(1).Name = "Export AS400"

Set Wrksheet = Wrkbook.ActiveSheet

'--- Lit le premier écran ---------------------------------

Set FieldList = autECLSession.autECLPS.autECLFieldList
FieldList.Refresh()

'--- Trouve la position du sous-fichier -------------------

Fld1 = ""
Fld2 = "."      ' Différent de blanc pour la première détection
PLgn = 0
NLgn = 0
PSfl = autECLSession.autECLPS.NumRows

For I = 1 to FieldList.Count
  Set Field = FieldList(I)

  If Field.StartRow <> PLgn Then       ' Changement de ligne

    If Fld2 = Fld1 Then                ' Mêmes zones
      NLgn = NLgn + 1
    Else
      If NLgn > NSfl Then
        PSfl = PLgn - NLgn
        NSfl = NLgn
      End If
      NLgn = 1
    End If

    Fld1 = Fld2
    Fld2 = ""
  End If

  Fld2 = Fld2 & Field.StartCol & ";"
  PLgn = Field.StartRow
Next

'--- Détermine le colonnage en sortie ---------------------

For I = 1 to FieldList.Count
  Set Field = FieldList(I)

  If Field.Display And Field.Length > 0 Then
    If Trim( Field.GetText()) <> ""  Or  Not Field.Protected Then

      Cols( Field.StartCol ) = 1

    End If
  End If
Next

J = 1
Lrg = 1
Cols( autECLSession.autECLPS.NumCols + 1 ) = 1

For I = 2 to autECLSession.autECLPS.NumCols + 1
  If Cols( I ) = 0 Then
    Lrg = Lrg + 1
  Else
    If Lrg = 1 Then
      Wrksheet.Cells( 1, J ).ColumnWidth = 0.83   ' Petite bizarrerie d'Excel
    Else
      Wrksheet.Cells( 1, J ).ColumnWidth = 1.43 * Lrg - 0.72
    End If

    Lrg = 1
    J = J + 1
  End If
  Cols( I ) = J
Next

'--- Mise en page globale ---------------------------------

Wrksheet.Cells.Font.Name = "Courier New"
Wrksheet.Cells.Font.Size = 12

'--- Export Ecran unique ----------------------------------

If PSfl = autECLSession.autECLPS.NumRows Then

  If Color = vbYes Then Wrksheet.Range( "A1", Colonne( Cols( autECLSession.autECLPS.NumCols )) & autECLSession.autECLPS.NumRows ).Interior.Color = 0

  For I = 1 to FieldList.Count
    Set Field = FieldList(I)

    If Field.Display And Field.Length > 0 Then
      If Trim( Field.GetText()) <> ""  Or  Not Field.Protected Then

        With Wrksheet.Cells( Field.StartRow, Cols( Field.StartCol ))

          .Value = CExcel( Field.GetText())
          .Font.Color = Couleur( Field.StartRow, Field.StartCol )

          If Not Field.Protected Then .Font.Underline = 2
          If Field.HighIntensity Then .Font.Bold = True

        End With

      End If
    End If
  Next

Else

'--- Remonte en haut du sous-fichier ----------------------

  autECLSession.autECLOIA.WaitForAppAvailable
  autECLSession.autECLOIA.WaitForInputReady

  Do while PageMove( "[roll down]" ) = 0
  Loop

'--- Export Entête ----------------------------------------

  If Color = vbYes Then Wrksheet.Range( "A1", Colonne( Cols( autECLSession.autECLPS.NumCols )) & PSfl ).Interior.Color = 0

  For I = 1 to FieldList.Count
    Set Field = FieldList(I)

    If Field.Display And Field.Length > 0 Then
      If Trim( Field.GetText()) <> ""  Or  Not Field.Protected Then

        If Field.StartRow < PSfl Then

          With Wrksheet.Cells( Field.StartRow, Cols( Field.StartCol ))

            .Value = CExcel( Field.GetText())
            .Font.Color = Couleur( Field.StartRow, Field.StartCol )

            If Not Field.Protected Then .Font.Underline = 2
            If Field.HighIntensity Then .Font.Bold = True

          End With
        End If

      End If
    End If
  Next

'--- Export Sous-Fichier ----------------------------------

  Fin = 0
  Ref = 0

  Do while Fin = 0

    If Color = vbYes Then Wrksheet.Range( "A" & PSfl + Ref, Colonne( Cols( autECLSession.autECLPS.NumCols )) & PSfl + NSfl + Ref ).Interior.Color = 0

    For I = 1 to FieldList.Count
      Set Field = FieldList(I)

      If Field.Display And Field.Length > 0 Then
        If Trim( Field.GetText()) <> ""  Or  Not Field.Protected Then

          If Field.StartRow >= PSfl And Field.StartRow <= PSfl + NSfl Then

            Lgn = Field.StartRow + Ref

            With Wrksheet.Cells( Lgn, Cols( Field.StartCol ))

              .Value = CExcel( Field.GetText())
              .Font.Color = Couleur( Field.StartRow, Field.StartCol )

              If Not Field.Protected Then .Font.Underline = 2
              If Field.HighIntensity Then .Font.Bold = True

            End With
          End If

        End If
      End If
    Next

    ' Page suivante

    autECLSession.autECLOIA.WaitForAppAvailable
    autECLSession.autECLOIA.WaitForInputReady

    Fin = PageMove( "[roll up]" )

    If Fin = 0 Then
      Ref = Ref + NSfl + 1
      FieldList.Refresh()
    End If

  Loop

'--- Export Bas de page -----------------------------------

  If Color = vbYes Then Wrksheet.Range( "A" & PSfl + NSfl + Ref, Colonne( Cols( autECLSession.autECLPS.NumCols )) & autECLSession.autECLPS.NumRows + Ref ).Interior.Color = 0

  For I = 1 to FieldList.Count
    Set Field = FieldList(I)

    If Field.Display And Field.Length > 0 Then
      If Trim( Field.GetText()) <> ""  Or  Not Field.Protected Then

        If Field.StartRow >= PSfl + NSfl Then

          Lgn = Field.StartRow + Ref

            With Wrksheet.Cells( Lgn, Cols( Field.StartCol ))

              .Value = CExcel( Field.GetText())
              .Font.Color = Couleur( Field.StartRow, Field.StartCol )

              If Not Field.Protected Then .Font.Underline = 2
              If Field.HighIntensity Then .Font.Bold = True

            End With
        End If

      End If
    End If
  Next

'--- Remonte en haut du sous-fichier ----------------------

  autECLSession.autECLOIA.WaitForAppAvailable
  autECLSession.autECLOIA.WaitForInputReady

  Do while PageMove( "[roll down]" ) = 0
  Loop

End If

'--- Clean up ---------------------------------------------

Set Wrksheet = Nothing
Set Wrkbook  = Nothing
Set ExcelApp = Nothing

End If

'----------------------------------------------------------
'--- End --------------------------------------------------
'----------------------------------------------------------

'### Conversion zone Excel ################################

Function CExcel(ByVal texte)

  CExcel = texte

  Select case left( texte, 1 )
    Case "=", "+", "-", "*", "/"
      CExcel = "'" & texte
    Case Else
      If IsNumeric( texte ) And Len( texte ) > 15 Then CExcel = "'" & texte
      If IsDate( texte ) And InStr( texte, "/" ) > 0 Then CExcel = DateValue( texte )
  End Select

End Function

'### Gestion Pagination ###################################

Function PageMove(ByVal Sens)

  Dim Ecran

  PageMove = 0

  ' Détection fin de liste sur écrans système

  If Sens = "[roll up]" Then

    Ecran = autECLSession.autECLPS.GetText( 1, 1, autECLSession.autECLPS.NumRows * autECLSession.autECLPS.NumCols )

    If InStr( Ecran, "********  Fin du rapport  ********" ) Then  PageMove = 1   ' DSPDBF, QRY, SQL
    If InStr( Ecran, "****** FIN DES DONNEES ******" )      Then  PageMove = 1   ' DSPPFM

  End If

  ' Si non trouvé, pagine

  If PageMove = 0 Then

    autECLSession.autECLPS.SendKeys Sens

    Do while autECLSession.autECLOIA.InputInhibited <> 0
      Select Case autECLSession.autECLOIA.InputInhibited
        Case 0
        Case 1, 2, 3, 4
          autECLSession.autECLOIA.WaitForInputReady(100)
        Case 5
          PageMove = 1
          autECLSession.autECLPS.SendKeys "[reset]"
          autECLSession.autECLPS.Wait(100)
      End Select
    loop

    If autECLSession.autECLPS.GetText( autECLSession.autECLPS.NumRows, 1, 10 ) <> space(10) Then PageMove = 1

  End If

End Function

'### Couleurs #############################################

Function Couleur(ByVal Row, ByVal Col)

  if Color = vbNo then
    Couleur = 0                       ' Noir
  elseif autECLSession.autECLPS.waitforattrib(Row, Col, "01", , 2, 1 )  then
    Couleur = RGB( 120, 144, 240 )    ' Bleu
  elseif autECLSession.autECLPS.waitforattrib(Row, Col, "02", , 2, 1 )  then
    Couleur = RGB(  36, 216,  48 )    ' Vert
  elseif autECLSession.autECLPS.waitforattrib(Row, Col, "03", , 2, 1 )  then
    Couleur = RGB(  88, 240, 240 )    ' Turquoise
  elseif autECLSession.autECLPS.waitforattrib(Row, Col, "04", , 2, 1 )  then
    Couleur = RGB( 240,  24,  24 )    ' Rouge
  elseif autECLSession.autECLPS.waitforattrib(Row, Col, "05", , 2, 1 )  then
    Couleur = RGB( 255,   0, 255 )    ' Rose
  elseif autECLSession.autECLPS.waitforattrib(Row, Col, "07", , 2, 1 )  then
    Couleur = RGB( 255, 255, 255 )    ' Blanc
  elseif autECLSession.autECLPS.waitforattrib(Row, Col, "0E", , 2, 1 )  then
    Couleur = RGB( 255, 255,   0 )    ' Jaune
  else
    Couleur = 0          ' Noir
  end if

End Function

'### Nom de colonne Excel #################################

Function Colonne(ByVal No)

Colonne = ""
If No > 26 Then
  Colonne = Chr( Int( No / 26 ) + 64 ) & Chr( No Mod 26 + 64 )
Else
  Colonne = Chr( No + 64 )
End If

End Function

Attention, je n'y ai mis que les messages de fin correspondant aux commandes DSPDBF, QRY, SQL et DSPPFM. Selon les commandes, le libellé en fin de liste peut être différent, il faudra alors le rajouter dans la fonction "PageMove" selon vos besoins.

Pour finir : Ces commandes spécifiques listant un fichier présentent 3 autres particularités par rapport à un sous-fichier classique :
* Les entêtes de colonne sont intégrés au sous-fichier, la macro ne peut donc pas les détecter, et elle va les répéter sur toutes les pages.
* Ces listes sont souvent plus larges qu'un écran. La macro ne gère pas la pagination droite/gauche, elle ne listera donc que la partie gauche de la liste.
* Et enfin, dans certains cas, au lieu de paginer de façon classique, l'AS400 gère son écran pour placer le message en bas de l'écran, en redondant certaines des lignes affichées sur la page précédente. Vous pouvez donc vous retrouver avec sur la dernière page des lignes déjà affichées sur l'écran précédent. Attention aux N° de ligne, qui vous alertent sur ce point.

La macro marche maintenant avec les listes système, ou du moins elle ne boucle plus, mais elle n'est clairement pas optimisée pour cette utilisation.
Pour extraire le contenu d'un fichier ou d'un résultat SQL vers Excel, d'autres moyens sont nettement plus adaptés.

Merci pour vos encouragements

**m4k-Hurrican** · 29/01/2014, 12h06

Bah, pas de bol, suis tombé sur une boucle dès le 2ème essai.

Pas trop le temps de chercher, mais c'est un écran de gestion, un peu à la manière de PDM.

**mutsum1** · 31/01/2014, 10h03

En fait la fin d'une liste est le plus difficile à détecter.

La macro se base sur un message d'anomalie renvoyé par l'AS400, ou par l'arrivée d'un message en ligne 24. Cela suffit généralement pour la plupart des écrans.

Regarde sur ton écran si tu es dans un de ces cas, et sinon tu peux modifier la fonction "PageMove" de la macro pour qu'elle prenne en compte ta spécificité.

AS400ToExcel, copie d'écran AS400 vers Excel

AS/400

Discussions similaires

Partager

Partager