Reflections2 Web Scraping Sharing some code knowledge

Kurt · Jul 19, 2017

Hello All,

I thought I would share some code knowledge on a project I have been working on for the last month or so.

This is a great learning experience and I found some great posts on Mr. Excel on Reflections so I thought I would transfer some knowledge.

Please let me know if you think there is a better way to do some of these routines.

I have been fortunate to work in a collaborative environment on this project.

One of the most important things when scraping from a mainframe terminal is the wait time.

Hope this info helps someone out there.

Kurt

Code:

Option Explicit

Public Const NEVER_TIME_OUT = 0
Public Const FILE_PATH As String = "\\xxxx\xxx\Users\Kurt\My Documents"
Public Const FILE_CANDIDATES As String = "\\xxxx\xxxx\Users\Kurt\My Documents\Candidates.txt"
Public Const FILE_XML As String = "\\xxxx\xxxx\Users\Kurt.\My Documents\Results.xml"
Public Const FILE_COMMENTS As String = "\\xxxx\xxxx\Users\Kurts\My Documents\Comments.txt"
Public Const FILE_RESULTS As String = "\\xxxxx\xxxx\Users\Kurt\My Documents\Results.txt"
Public Const FOR_APPENDING As Integer = 8
Public Const FOR_READING As Integer = 1
Public CR As String
Public SI As String
Public ESC As String
Public ErrorResult As String
Public strCandidatesFile As String
Public strScrapedCandidates As String
Public strResultsFile As String
Public strLastStateCode As String

Public Sub Run()
    ScrapeData
End Sub

Public Sub DefineConstants()
    CR = Chr(Reflection2.ControlCodes.rcCR)   ' Chr(rcCR) = Chr(13) = Control-M
    SI = Chr(Reflection2.ControlCodes.rcSI)    ' Chr(rcSI) = Chr(15) = Control-O
    ESC = Chr(Reflection2.ControlCodes.rcESC)   ' Chr(rcESC) = Chr(27) = Control-[
    ErrorResult = ""
End Sub

'364161302 as the issue with the new error message I need it to go back to the main menu
Function StepstoSubscriberMemberHistory(ByVal strClaimID As String, ByVal strState As String, ByVal strStateCode As String, ByRef txtXMLOut As Object) As String
    Dim sLastRecordString  As String
    Dim strStatus As String
    Dim strRL As String
    Dim strTN As String
    Dim strFirst As String
    Dim strLast As String
    Dim strStartDate As String
    Dim sResult As String
    Dim bEOC As Boolean
    Dim lRow As Integer
    Dim sXML As String
    Dim sWriteString As String
    Dim bExit As Boolean
    Dim iInstance As Integer
    Dim intCount As Integer
    Dim sFirstRecord As String
    Dim sThisRecord As String
    Dim bContinue As Boolean
    
    sFirstRecord = ""
    sThisRecord = ""
    sLastRecordString = ""
    sResult = "Pass"
    ErrorResult = ""
    bEOC = False
    bContinue = True
    
    With Session
        '
        ' Select "Claims History Inquiry" from menu
        '
        .Transmit "3" & CR
        '
        ' Wait for terminal to allow further input
        '
        .WaitForString ESC & "[04;17H       ", NEVER_TIME_OUT, rcAllowKeystrokes
        .StatusBar = "Waiting for Prompt: MEMBER NUMBER:"
        .WaitForString " " & SI & ESC & "[;;4m" & ESC & "[04;17H       ", NEVER_TIME_OUT, rcAllowKeystrokes
        .StatusBar = ""
        '
        ' Update the state code if necessary
        '
        If strLastStateCode <> strStateCode Then
            .TransmitTerminalKey rcVtPF1Key
            .WaitForString "5" & ESC & "[24;01H", NEVER_TIME_OUT, rcAllowKeystrokes
            .Transmit "h"
            .StatusBar = "Waiting for Prompt: CL0100RQ70"
            .WaitForString " " & SI & ESC & "[;;1;4m" & ESC & "[02;27H", NEVER_TIME_OUT, rcAllowKeystrokes
            .StatusBar = ""
            .Transmit strStateCode & CR
            strLastStateCode = strStateCode
        End If
        '
        ' Enter claim ID
        '
        .Transmit strClaimID
        .StatusBar = "Waiting for Prompt: MEMBER NUMBER: 8870044-02       NAME:"
        .WaitForString ESC & "[04;40H", NEVER_TIME_OUT, rcAllowKeystrokes
        .StatusBar = ""
        .Transmit CR
        .Wait 0.5
        strStatus = Trim(.GetText(23, 0, 23, 70))
        
        If strStatus = "CL-E-175  NO CLAIMS ON FILE FOR THIS MEMBER UNDER THIS CMPNY" Then
            sResult = "Fail"
            ErrorResult = "No claims on file for this member"
            'debug.print sResult
        ElseIf strStatus = "CL-E-191  THIS MBR CONFIDENTIAL; USER NOT AUTHORIZED TO VIEW" Then
            sResult = "Fail"
            ErrorResult = "Member confidential. User not authorized to view data."
            'debug.print sResult
        ElseIf strStatus = "CL-E-020  SPECIFIED MEMBER NUMBER NOT VALID-REENTER NEW NUMBER" Then
            sResult = "Fail"
            ErrorResult = "Member confidential. User not authorized to view data."
            'debug.print sResult
        Else
            If Trim(.GetText(9, 2, 9, 5)) = "" Then
                .Wait 0.5
                If InStr(strStatus, "<RETURN> REQUEST IN PROGRESS") > 0 Then
                    Do While InStr(strStatus, "<RETURN> REQUEST IN PROGRESS") > 0
                        .Wait 0.1
                        strStatus = Trim(.GetText(23, 0, 23, 70))
                        DoEvents
                    Loop
                Else
                    If Trim(.GetText(9, 2, 9, 5)) = "" Then
                        sResult = "Fail"
                        ErrorResult = strStatus
                        'debug.print sResult
                        'debug.print strStatus
                        bContinue = False
                    End If
                End If
            End If
            
            If bContinue Then
                .TransmitTerminalKey rcVtPF1Key
                .Transmit "o"
                .StatusBar = "Waiting for Prompt: ENTER OPTION LETTER:"
                .StatusBar = ""
                '
                ' Goto Subscriber / Member History
                '
                .Transmit "g" & CR
                .WaitForString ESC & "[24;80H", NEVER_TIME_OUT, rcAllowKeystrokes
                Session.Wait 0.5
                '
                ' Begin Paste
                '
                bExit = False
                iInstance = 0
                Do While Not bEOC
                    For lRow = 14 To 20
                        strRL = .GetText(lRow, 0, lRow, 1)
                        'debug.print strRL
                
                        If strRL = "  " Then Exit For
                        
                        iInstance = iInstance + 1
                        strTN = .GetText(lRow, 3, lRow, 4)
                        strLast = .GetText(lRow, 6, lRow, 13)
                        strFirst = .GetText(lRow, 15, lRow, 23)
                        strStartDate = .GetText(lRow, 58, lRow, 65)
                                           
                        sThisRecord = strLast & "|" & strFirst
                        sWriteString = Trim(strClaimID) & "|" & strState & "|" & CStr(iInstance) & "|" & strLast & "|" & strFirst & "|" & strStartDate
                        
                        If lRow = 14 Then
                            If sFirstRecord = sThisRecord Then
                                Exit Do
                            Else
                                sFirstRecord = sThisRecord
                            End If
                        End If
                                                                
                        'debug.print strTN
                        'debug.print strLast
                        'debug.print strFirst
                        'debug.print strStartDate
                                            
                        sXML = "<Name>" & vbCrLf
                        sXML = sXML & "<Instance>" & CStr(iInstance) & "</Instance>" & vbCrLf
                        sXML = sXML & "<LastName>" & strLast & "</LastName>" & vbCrLf
                        sXML = sXML & "<FirstName>" & strFirst & "</FirstName>" & vbCrLf
                        sXML = sXML & "<StartDate>" & strStartDate & "</StartDate>" & vbCrLf
                        sXML = sXML & "<ProgramMessage/>" & vbCrLf
                        sXML = sXML & "</Name>" & vbCrLf
                        txtXMLOut.Write sXML
                                                                
                        strStatus = .GetText(23, 1, 23, 60)
                        
                        If strStatus = "CO-I-001  CANNOT PAGE FWD; NO ADDITIONAL RECORDS TO DISPLAY" Then
                            bExit = True
                            Exit Do
                        End If
                    Next lRow
                    
                    If Not bExit Then
                        Session.TransmitTerminalKey rcVtNextScreenKey
                        Session.Wait 1
                    Else
                        bEOC = True
                    End If
                                                        
                    intCount = intCount + 1
                    If intCount > 50 Then Exit Do
                Loop
            End If
        End If
    End With
    
    StepstoSubscriberMemberHistory = sResult
End Function

Public Sub GetCommentsMaintenance()
    With Session
        '
        ' Press VtPf1 (Perform the VT terminal PF1 function)
        '
        .TransmitTerminalKey rcVtF20Key
        .Wait 1
        .Transmit "c"
        .TransmitTerminalKey rcVtReturnKey
        .Wait 1.5
    End With
End Sub
'
' ClaimID: 698105401 - Showing menu instead of comments
'
Function CommentsMaintenance()
    Dim strComments2 As String
    Dim strLine As String
    Dim lRow As Integer
    Dim strStatus As String
    Dim intCount As Integer
    Dim strLine1 As String
    Dim strStatus1 As String
    Dim bEOC As Boolean

    strComments2 = ""
    bEOC = False
    intCount = 0
    
    With Session
        Do While Not bEOC
            For lRow = 7 To 15
                strLine = .GetText(lRow, 1, lRow, 78)
                '
                'If lRow = 7 And strLine = strLine1 Then
                '    bEOC = True
                '    Exit For
                'End If
                '
                strStatus = Trim(.GetText(23, 0, 23, 60))
                                
                If strStatus = "CO-I-001  CANNOT PAGE FWD; NO ADDITIONAL RECORDS TO DISPLAY" Then
                    bEOC = True
                    Exit Do
                End If
                '
                'Go back to main menu
                'Maybe put Start Over function here
                'assign a value so it knows to jump out of this loop
                '
                If lRow = 7 Then strLine1 = strLine
                If Len(Trim(strLine)) = 0 Then Exit For
                
                strComments2 = strComments2 & RTrim(strLine) & vbCrLf
                
                'debug.print lRow
                'debug.print strLine
            Next lRow
            
            .Wait 0.25
            .TransmitTerminalKey rcVtPF1Key
            .Transmit "F"
            .Wait 0.25
            .WaitForHostTrigger
            '
            ' Prevent infinite loop if we get into an error condition and don't advance
            '
            intCount = intCount + 1
            If intCount > 50 Then Exit Do
        Loop
    End With
    
    CommentsMaintenance = strComments2
End Function

Function ScrapeData()
    Dim sLine As String
    Dim sComments As String
    Dim sResult As String
    Dim sFilename As String
    Dim sCandidatesOut As String
    Dim sResultsOut As String
    Dim sXMLOut As String
    Dim fso As Object
    Dim txtCandidates As Object
    Dim txtCandidatesOut As Object
    Dim txtScraped As Object
    Dim txtXMLOut As Object
    Dim sRowID As String
    Dim sClaimID As String
    Dim sState As String
    Dim sScrapeStart As String
    Dim sScrapeEnd As String
    Dim arrLine As Variant
    Dim iCntr As Integer
    Dim sError As String
    Dim sFile As String
    Dim dblTimer As Double
    Dim dblTotalTime As Double
    Dim lngRecords As Long
    Dim sLastClaimID As String
    Dim sStateCode As String
        
    DefineConstants
    ResumeScrape
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    sError = ""
    sLastClaimID = ""
    strLastStateCode = ""
    
    If fso.FileExists(FILE_CANDIDATES) Then
        Set txtCandidates = fso.OpenTextFile(FILE_CANDIDATES)
        
        If Len(strCandidatesFile) > 0 Then
            Set txtCandidatesOut = fso.OpenTextFile(strCandidatesFile, FOR_APPENDING)
        End If
        
        If Len(strScrapedCandidates) > 0 Then
            Set txtScraped = fso.OpenTextFile(strScrapedCandidates, FOR_READING)
            Do While Not txtScraped.AtEndOfStream
                sLine = txtScraped.ReadLine
                If Len(Trim(sLine)) > 0 Then
                    arrLine = Split(sLine, "|")
                    If UBound(arrLine) >= 1 Then
                        sLastClaimID = arrLine(1)
                    End If
                End If
            Loop
            txtCandidatesOut.WriteLine vbCrLf
        Else
            txtCandidatesOut.WriteLine "RowID|ClaimID|State|RowScrapeStart|RowScrapeEnd"
            txtCandidates.SkipLine                  ' Skip header row
        End If
        
        If Len(strResultsFile) > 0 Then
            Set txtXMLOut = fso.CreateTextFile(strResultsFile, FOR_APPENDING)
        End If
                
        dblTimer = Timer
        lngRecords = 0
        
        If sLastClaimID <> "" Then
            sClaimID = ""
            If Not txtCandidates.AtEndOfStream Then
                Do While sClaimID <> sLastClaimID
                    sLine = txtCandidates.ReadLine
                    arrLine = Split(sLine, "|")
                    If IsArray(arrLine) Then
                        If UBound(arrLine) > 0 Then
                            sClaimID = arrLine(1)
                        End If
                    End If
                    
                    If txtCandidates.AtEndOfStream Then Exit Do
                Loop
            End If
        End If
        
        Do While Not txtCandidates.AtEndOfStream
            lngRecords = lngRecords + 1
            sLine = txtCandidates.ReadLine
            sScrapeStart = ""
            sScrapeEnd = ""
            
            arrLine = Split(sLine, "|")
            
            If IsArray(arrLine) Then
                If UBound(arrLine) >= 2 Then
                    sRowID = arrLine(0)
                    sClaimID = arrLine(1)
                    sState = arrLine(2)
                    sStateCode = arrLine(3)
                    
                    If UBound(arrLine) = 5 Then
                        sScrapeStart = arrLine(4)
                        sScrapeEnd = arrLine(5)
                    End If
                    
                    Do While Len(sClaimID) < 9
                        sClaimID = "0" & sClaimID
                    Loop
                    
                    If Len(sClaimID) = 9 Then
                        sCandidatesOut = Trim(sRowID) & "|" & Trim(sClaimID) & "|" & Trim(sState) & "|" & Trim(sStateCode) & "|" & Format(Now, "dd/MM/yyyy hh:mm:ss AMPM") & "|"
                        sXMLOut = "<Candidate>" & vbCrLf
                        sXMLOut = sXMLOut & "<RowID>" & sRowID & "</RowID>" & vbCrLf
                        sXMLOut = sXMLOut & "<ClaimID>" & sClaimID & "</ClaimID>"
                        txtXMLOut.WriteLine sXMLOut
                        sResult = StepstoSubscriberMemberHistory(sClaimID, sState, sStateCode, txtXMLOut)
                        
                        If sResult <> "Fail" Then
                            GetCommentsMaintenance
                            sComments = CommentsMaintenance()
                            sComments = Replace(sComments, vbLf, vbCrLf)
                            '
                            ' Replace characters that won't work with XML
                            '
                            sComments = Replace(sComments, "&", "&")
                            sComments = Replace(sComments, ">", ">")
                            sComments = Replace(sComments, "<", "<")
                            sComments = Replace(sComments, Chr(34), """)
                            sComments = Replace(sComments, Chr(39), "&apos;")
                            sXMLOut = "<Comments>" & vbCrLf & sComments & vbCrLf & "</Comments>"
                            
                            With Session
                                .TransmitTerminalKey rcVtF20Key
                                .TransmitTerminalKey rcVtPF1Key
                                .Transmit "M"
                                .TransmitTerminalKey rcVtReturnKey
                                .Wait 0.5
                            End With
                        Else
                            sXMLOut = "<Name>" & vbCrLf
                            sXMLOut = sXMLOut & "<Instance>1</Instance>" & vbCrLf
                            sXMLOut = sXMLOut & "<LastName />" & vbCrLf
                            sXMLOut = sXMLOut & "<FirstName />" & vbCrLf
                            sXMLOut = sXMLOut & "<StartDate />" & vbCrLf
                            sXMLOut = sXMLOut & "<ProgramMessage>" & ErrorResult & "</ProgramMessage>" & vbCrLf
                            sXMLOut = sXMLOut & "</Name>" & vbCrLf
                            With Session
                                .TransmitTerminalKey rcVtPF1Key
                                .Transmit "M"
                                .Wait 0.5
                            End With
                        End If
                        txtXMLOut.Write sXMLOut
                        txtXMLOut.WriteLine "</Candidate>"
                        sCandidatesOut = sCandidatesOut & Format(Now, "dd/MM/yyyy hh:mm:ss AMPM")
                    Else
                        sXMLOut = "<Name>" & vbCrLf
                        sXMLOut = sXMLOut & "<Instance>1</Instance>" & vbCrLf
                        sXMLOut = sXMLOut & "<LastName />" & vbCrLf
                        sXMLOut = sXMLOut & "<FirstName />" & vbCrLf
                        sXMLOut = sXMLOut & "<StartDate />" & vbCrLf
                        sXMLOut = sXMLOut & "<ProgramMessage>Claim not processed</ProgramMessage>" & vbCrLf
                        sXMLOut = sXMLOut & "</Name>" & vbCrLf
                        txtXMLOut.Write sXMLOut
                        txtXMLOut.WriteLine "</Candidate>"
                        With Session
                            .TransmitTerminalKey rcVtPF1Key
                            .Transmit "M"
                            .Wait 0.5
                        End With
                    End If
                                        
                    txtCandidatesOut.WriteLine sCandidatesOut
                Else
                    Error = "Candidates file is not in the correct format. Check file and try again."
                    Exit Do
                End If
            Else
                Error = "Candidates file is not in the correct format. Check file and try again."
                Exit Do
            End If
        Loop
        
        dblTotalTime = Timer - dblTimer
        
        MsgBox "All candidates have been scraped." & vbCrLf & vbCrLf & "Records scraped: " & _
            Format(lngRecords, "##,###,###,##0") & vbCrLf & "Time elapsed: " & _
            Format(dblTotalTime / 60, "##,##0.0") & " minutes" & vbCrLf & vbCrLf & _
            "Avg time per scrape: " & Format(dblTotalTime / lngRecords, "##0.0") & " seconds", vbInformation, "Complete!"
        
        Debug.Print "All candidates have been scraped." & vbCrLf & vbCrLf & "Records scraped: " & _
            Format(lngRecords, "##,###,###,##0") & vbCrLf & "Time elapsed: " & _
            Format(dblTotalTime / 60, "##,##0.0") & " minutes" & vbCrLf & vbCrLf & _
            "Avg time per scrape: " & Format(dblTotalTime / lngRecords, "##0.0")
            
        txtXMLOut.Close 'The code is stopping here on the first record
        txtCandidatesOut.Close
        txtCandidates.Close
        Set txtXMLOut = Nothing
        Set txtCandidatesOut = Nothing
        Set txtCandidates = Nothing
        
        Set fso = Nothing
    Else
        MsgBox "The candidates file could not be found.", vbCritical, "Error"
    End If
End Function

Public Sub Wait(ByVal nSecs As Double)
    Dim nTimer As Double
        
    nTimer = Timer
    
    Do While Timer - nTimer < nSecs
        DoEvents
    Loop
End Sub

Function GetTimestampFilename(ByVal sFilenamePrefix, Optional ByVal sExtension As String = "txt") As String
    Dim sFilename As String
    Dim fso As Object
    Dim bPrepped As Boolean
    
    bPrepped = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    sFilename = ""
    
    If fso.FileExists(FILE_CANDIDATES) Then
        sFilename = fso.BuildPath(FILE_PATH, sFilenamePrefix & "_" & Format(Now(), "yyyyMMddhhmmss") & "." & sExtension)
        
        Do While fso.FileExists(sFilename)
            Wait 1
            sFilename = fso.BuildPath(FILE_PATH, sFilenamePrefix & "_" & Format(Now(), "yyyyMMddhhmmss") & "." & sExtension)
        Loop
    End If
    
    Set fso = Nothing
    
    GetTimestampFilename = sFilename
End Function
'
' This function checks to see if there are any previous scrapes that failed
' and picks up where they left off
'
Function ResumeScrape()
    Dim fso As Object
    Dim fld As Object
    Dim fil As Object
    Dim txt As Object
    Dim sFile As String
    Dim sFilename As String
    Dim dtSaved As Date
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fld = fso.GetFolder(FILE_PATH)
    
    dtSaved = CDate("1/1/1990")
    sFilename = ""
    
    If Not fld Is Nothing Then
        For Each fil In fld.Files
            If Len(fil.Name) > 4 Then
                sFile = VBA.Strings.Left(fil.Name, Len(fil.Name) - 4)
                If Len(sFile) >= 11 Then
                    If VBA.Strings.Left(sFile, 11) = "Candidates_" Then
                        '
                        ' Finds last saved candidates file
                        '
                        If fil.DateCreated > dtSaved Then
                            sFilename = fil.Path
                            dtSaved = fil.DateCreated
                        End If
                    End If
                End If
            End If
        Next
        
        If Len(sFilename) > 0 Then
            strCandidatesFile = sFilename
            strScrapedCandidates = GetTimestampFilename("Scraped")
            fso.CopyFile strCandidatesFile, strScrapedCandidates
        Else
            strCandidatesFile = GetTimestampFilename("Candidates")
            Set txt = fso.CreateTextFile(strCandidatesFile)
            txt.Close
            Set txt = Nothing
        End If
        
        sFilename = ""
        dtSaved = CDate("1/1/1990")
        
        For Each fil In fld.Files
            sFile = VBA.Strings.Left(fil.Name, Len(fil.Name) - 4)
            If Len(sFile) >= 8 Then
                If VBA.Strings.Left(sFile, 8) = "Results_" Then
                    '
                    ' Finds last saved Results file
                    '
                    If fil.DateCreated > dtSaved Then
                        sFilename = fil.Path
                        dtSaved = fil.DateCreated
                    End If
                End If
            End If
        Next
        
        If Len(sFilename) > 0 Then
            strResultsFile = sFilename
        Else
            strResultsFile = GetTimestampFilename("Results", "xml")
            Set txt = fso.CreateTextFile(strResultsFile)
            txt.Close
            Set txt = Nothing
        End If
    End If
    
    Set fil = Nothing
    Set fld = Nothing
    Set fso = Nothing
End Function

Sub CreateFolderShortcut()
    Dim oWsh As Object, oShortcut As Object
    Dim sPathDesktop As String, sShortcut As String, sPathFile As String
   
    On Error GoTo Proc_Err
    
    sPathFile = FILE_PATH
   
    Set oWsh = CreateObject("WScript.Shell")
    sPathDesktop = oWsh.SpecialFolders("Desktop")
    sShortcut = sPathDesktop & "\Kurt's Documents.lnk"
   
    Set oShortcut = oWsh.CreateShortcut(sShortcut)
    With oShortcut
        .TargetPath = sPathFile
        .Save
    End With

Proc_Exit:
    On Error Resume Next
    
    Set oShortcut = Nothing
    Set oWsh = Nothing
    
    Exit Sub
  
Proc_Err:
   MsgBox Err.Description, , _
        "ERROR " & Err.Number _
        & "   CreateShortcut "
   Resume Proc_Exit
End Sub

Kurt · Jul 19, 2017

Re: Reflections2 Mainframe Scraping Sharing some code knowledge

Sorry all title should read Mainframe Scraping.

hiker95 · Jul 19, 2017

This is a great learning experience and I found some great posts on Mr. Excel on Reflections so I thought I would transfer some knowledge.

Kurt,

Thank you so much for sharing.

This is something that I just added to my archives.

Reflections2 Web Scraping Sharing some code knowledge

Kurt

Well-known Member

Excel Facts

Kurt

Well-known Member

hiker95

Well-known Member

Similar threads

Forum statistics

Share this page

Reflections2 Web Scraping Sharing some code knowledge

Kurt

Well-known Member

Excel Facts

Kurt

Well-known Member

hiker95

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock