How to screen scrape from an AS400 using excel VBA?

Question

I would like to scrape data from an AS400. I have done some research and believe that this is possible but I am struggling. The emulator is "System i Navigator" This is what I have tried to connect to the AS400 but receive an activex error at the Set Mainframe line.

Sub as400connect()

    Dim Mainframe As Object

    Set Mainframe = CreateObject("saahlapi.dll").CurrentHost
    Mainframe.Activate
    Mainframe.Maximize

    Mainframe.Keys ("{Enter}")

    Set OUTPUTSHEET = ActiveWorkbook.Sheets("Sheet1")


    End Sub

Answer 1

Here is my MS Word 2010 macro copying the 5250 screen. The CopyScreen sub should help you. The Format sub is just to format input fields etc.

Public PS As String
Public Sitzung As String
Public cbEingabe As Boolean
Public size As Long, P As Long, L As Long
Public rows As Integer, cols As Integer
Public screen() As String
Public Start() As Integer, Length() As Integer, Attrib() As Byte, Fields As Integer

Rem *** Sitzung für die Hardcopy auswählen. Automatisch oder per Dialogbox.
Public Sub Auswahl()
    Load Sessions ' Dialogbox laden

Rem *** DDE-Kanal öffnen
    Kanal = DDEInitiate(App:="IBM5250", Topic:="System")
    PS = DDERequest(Channel:=Kanal, Item:="Topics")

    L = InStr(1, PS, Chr$(9))
    If Left(PS, L - 1) <> "System" Then
        MsgBox ("Kein Client Access installiert")
    End If
    Pos = L + 1

Rem *** Sitzungsnamen aus dem Ergebnisstring lesen
    Do Until L = 0
        L = InStr(Pos, PS, Chr$(9))
        If L > 0 Then
            Sessions.SessionList.AddItem (Mid(PS, Pos, L - Pos))
            Pos = L + 1
        End If
    Loop
    Sessions.SessionList.ListIndex = 0
    If (Sessions.SessionList.ListCount > 1) Then
        Sessions.Show
    Else
Rem *** Wenn's nur eine Sitzung gibt, diese automatisch auswählen
        Sitzung = Sessions.SessionList.SelText
    End If

    Unload Sessions
    DDETerminate (Kanal)
End Sub
Rem *** Sitzungsinhalt aus Client Access übernehmen
Public Sub CopyScreen()

    DDETerminateAll ' Alle DDE-Kanäle schliessen

Rem *** Nur dann eine Sitzung auswählen, wenn das noch nicht geschehen ist
    If Sitzung = "" Then
        cbEingabe = True
        Auswahl
    End If

    Kanal = DDEInitiate(App:="IBM5250", Topic:=Sitzung)

Rem *** Der VB DDERequest-Befehl meldet hier einen Pufferüberlauf.
    PS = WordBasic.DDERequest(Kanal, "PS")
    DDETerminate (Kanal)

    Parse ' Datenstring in Tabellen eintragen etc
    Format ' Formatierte Ausgabe

End Sub

Private Sub Parse()

Rem *** Ermitteln verschiedener Werte aus dem Presentation Space
    P = 1
    size = parseNum()   ' Puffergröße
    rows = parseNum()   ' Zeilenanzahl
    cols = parseNum()   ' Spaltenanzahl

    ReDim screen(rows)  ' Bildschirminhalt

    For i = 1 To rows
        screen(i) = Mid(PS, P, cols)
        P = P + cols + 1
    Next i

    Fields = parseNum()      ' Feldanzahl
    ReDim Start(Fields)
    ReDim Length(Fields)
    ReDim Attrib(Fields)
    For i = 1 To Fields
        Start(i) = parseNum()
        Length(i) = parseNum()

        If i = Fields Then
Rem *** Das letzte Feld enthält kein Tab-Zeichen
            Attrib(i) = CByte(Asc(Mid(PS, P)))
        Else
            L = InStr(P, PS, Chr$(9))
            Attrib(i) = CByte(Asc(Mid(PS, P, L - P)))
            P = L + 1
        End If
    Next i

End Sub


Private Sub Format()
    Dim Offset As Integer, temp As Integer

Rem *** Formatvorlage in Abhängigkeit der Auflösung wählen
    With Selection
        .TypeParagraph
        .TypeParagraph
        .MoveUp
        If cols > 80 Then
            .Style = ActiveDocument.Styles("System i 132")
        Else
            .Style = ActiveDocument.Styles("System i 80")
        End If

Rem *** Bildschirminhalt ausgeben
        For i = 1 To rows
            .TypeText (screen(i))
            If i < rows Then .InsertBreak (wdLineBreak)
        Next i

        .StartOf Unit:=wdParagraph, Extend:=wdMove 'An den Anfang positionieren
    End With

Rem *** alle Felder "attributieren"
    Offset = 0
    For i = 1 To Fields
        aktPos = Start(i)
        temp = aktPos - Offset
        L1 = Length(i)

        If L1 > 0 Then
            Startline = Int(aktPos / cols)
            atr = Attrib(i)
            With Selection
Rem *** positionieren
                .MoveRight Unit:=wdCharacter, Count:=temp
                .MoveRight Unit:=wdCharacter, Count:=Startline - Int((Offset / cols))
Rem *** markieren des Feldes + Zeilenumbruchszeichen
                temp = Int((aktPos + Length(i)) / cols) - Startline
                .MoveEnd Unit:=wdCharacter, Count:=L1 + temp
Rem *** formatieren
                If (atr And 8) Then
                    .Font.Bold = True   ' hervorgehoben
                End If

                If ((atr And 32) = 0 And cbEingabe = True) Then
                    .Font.Underline = True ' eingebbar
                    If L1 > 1 Then
Rem *** Leerzeichen durch Unterstriche ersetzen, damit diese auch unterstrichen dargestellt werden
                        t = Right(.Text, 1)
                        With .Find
                            .ClearFormatting
                            .Forward = True
                            .Wrap = wdFindStop
                            .Format = False
                            .MatchCase = False
                            .MatchWholeWord = False
                            .MatchWildcards = False
                            .MatchSoundsLike = False
                            .MatchAllWordForms = False
                            .Execute FindText:=" ", ReplaceWith:="_", Replace:=wdReplaceAll
                        End With
                        If (ActiveDocument.TrackRevisions = True And t = " ") Then
Rem *** Word verkürzt den markierten Bereich um ein Zeichen, wenn das letzte Zeichen " " ist.
                            .MoveRight Unit:=wdCharacter
                        End If
                    Else
Rem *** Ist nur ein Zeichen ausgewählt, funktioniert Suchen/Ersetzen nicht (es wird automatisch das ganze Dokument durchsucht), also manuell durchführen
                        If .Text = " " Then .Text = "_"
                    End If
                End If

Rem *** Auswahl aufheben
                .MoveRight Unit:=wdCharacter

            End With
            Offset = aktPos + Length(i)
        End If
    Next i

    With Selection
        If .Information(wdFirstCharacterColumnNumber) > 1 Then .MoveDown
        .InsertCaption Label:=wdCaptionFigure, Title:=" System i Hardcopy", Position:=wdCaptionPositionBelow
    End With

    End Sub

Private Function parseNum()
    L = InStr(P, PS, Chr$(9))
    parseNum = Val(Mid(PS, P, L - P))
    P = L + 1
End Function