如何使用 excel VBA 从 AS400 中筛选抓取

Question

我想从AS400中抓取数据。我做了一些研究，相信这是可能的，但我正在挣扎。模拟器是"System i Navigator"这是我尝试连接到 AS400 但在设置大型机行收到 activex 错误的内容。

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

这是我复制 5250 屏幕的 MS Word 2010 宏。CopyScreen 子应该会帮助你。格式子只是格式化输入字段等。

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