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

这是我的MS Word 2010宏，它复制了5250屏幕。 CopyScreen子应该会帮助您。 Format子项仅用于格式化输入字段等。

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

如何使用Excel VBA筛选AS400上的刮擦？

1 个答案: