AS400ToExcel, copie d'écran AS400 vers Excel

[mutsum1]

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 :

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]

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]

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]

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]

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

J'ai remplacé

Code :

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

par

Code :

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...