Hello All,
I am trying to give some back to the community here. I found some really great help on previous Reflections posts on this forum. Hiker95 I hope you see this post. This for your like on the last one!
I took out all functions and made this code so it could run in This Session in Reflections so that any user on the network could use this code.
This program now stores the results in an XML format.
Please let me know what you guys think. Is there anything we could have done better?
The only way to really learn and get a handle on the Reflections Nice editor is to record as many steps as you can. When I tried this step, I made a huge leap forward!
There is a lot of mainframe generated vba code you can learn to delete.
Have a great week all!
I am trying to give some back to the community here. I found some really great help on previous Reflections posts on this forum. Hiker95 I hope you see this post. This for your like on the last one!
I took out all functions and made this code so it could run in This Session in Reflections so that any user on the network could use this code.
This program now stores the results in an XML format.
Please let me know what you guys think. Is there anything we could have done better?
The only way to really learn and get a handle on the Reflections Nice editor is to record as many steps as you can. When I tried this step, I made a huge leap forward!
There is a lot of mainframe generated vba code you can learn to delete.
Have a great week all!
Code:
' Revised to wait until we get to comments screen (avoid storing menu screen)
'
Option Explicit
Sub ScrapeData()
Dim NeverTimeOut As Integer: NeverTimeOut = 0
Dim ForAppending As Integer: ForAppending = 8
Dim ForReading As Integer: ForReading = 1
Dim FilePath As String
Dim FileCandidates As String
Dim FileXML As String
Dim FileComments As String
Dim FileResults As String
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 sMemberID 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 sLastMemberID As String
Dim strStateCode As String
Dim strLastStateCode As String
Dim CR As String
Dim SI As String
Dim ESC As String
Dim ErrorResult As String
Dim strCandidatesFile As String
Dim strScrapedCandidates As String
Dim strResultsFile As String
Dim sUser 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 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
Dim strComments2 As String
Dim strTest As String
Dim strLine As String
Dim strLine1 As String
Dim strStatus1 As String
Dim bPrepped As Boolean
Dim fld As Object
Dim fil As Object
Dim txt As Object
Dim dtSaved As Date
Dim strRowScrapeStart As String
Dim strRowScrapeEnd As String
Dim arrFiles() As String
On Error GoTo err_Scrape
sUser = Environ$("UserName")
FilePath = "\\xxxx\xxxx\Users\" & sUser & "\My Documents"
FileCandidates = "\xxxx\xxxx\Users\" & sUser & "\My Documents\Candidates.txt"
FileXML = "\\xxxx\xxxx\Users\" & sUser & "\My Documents\Results.xml"
FileComments = "\\xxxx\xxxx\Users\" & sUser & "\My Documents\Comments.txt"
FileResults = "\\xxxx\xxxx\Users\" & sUser & "\My Documents\Results.txt"
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 = ""
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(FilePath)
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
sFilename = ""
If fso.FileExists(FileCandidates) Then
sFilename = fso.BuildPath(FilePath, "Scraped_" & Format(Now(), "yyyyMMddhhmmss") & ".txt")
Do While fso.FileExists(sFilename)
DoEvents
sFilename = fso.BuildPath(FilePath, "Scraped_" & Format(Now(), "yyyyMMddhhmmss") & ".txt")
Loop
End If
strScrapedCandidates = sFilename
fso.CopyFile strCandidatesFile, strScrapedCandidates
Else
sFilename = ""
If fso.FileExists(FileCandidates) Then
sFilename = fso.BuildPath(FilePath, "Candidates_" & Format(Now(), "yyyyMMddhhmmss") & ".txt")
Do While fso.FileExists(sFilename)
DoEvents
sFilename = fso.BuildPath(FilePath, "Candidates_" & Format(Now(), "yyyyMMddhhmmss") & ".txt")
Loop
End If
strCandidatesFile = sFilename
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
sFilename = ""
If fso.FileExists(FileCandidates) Then
sFilename = fso.BuildPath(FilePath, "Results_" & Format(Now(), "yyyyMMddhhmmss") & ".xml")
Do While fso.FileExists(sFilename)
DoEvents
sFilename = fso.BuildPath(FilePath, "Results_" & Format(Now(), "yyyyMMddhhmmss") & ".xml")
Loop
End If
strResultsFile = sFilename
Set txt = fso.CreateTextFile(strResultsFile)
txt.Close
Set txt = Nothing
End If
End If
Set fil = Nothing
Set fld = Nothing
sError = ""
sLastMemberID = ""
strLastStateCode = ""
If fso.FileExists(FileCandidates) Then
Set txtCandidates = fso.OpenTextFile(FileCandidates)
If Len(strCandidatesFile) > 0 Then
Set txtCandidatesOut = fso.OpenTextFile(strCandidatesFile, ForAppending)
End If
If Len(strScrapedCandidates) > 0 Then
Set txtScraped = fso.OpenTextFile(strScrapedCandidates, ForReading)
Do While Not txtScraped.AtEndOfStream
sLine = txtScraped.ReadLine
If Len(Trim(sLine)) > 0 Then
arrLine = Split(sLine, "|")
If UBound(arrLine) >= 1 Then
sLastMemberID = arrLine(1)
End If
End If
Loop
Else
txtCandidatesOut.writeline "RowID|MemberID|State|RowScrapeStart|RowScrapeEnd"
txtCandidates.SkipLine ' Skip header row
End If
If Len(strResultsFile) > 0 Then
Set txtXMLOut = fso.OpenTextFile(strResultsFile, ForAppending)
End If
dblTimer = Timer
lngRecords = 0
If sLastMemberID <> "" Then
sMemberID = ""
If Not txtCandidates.AtEndOfStream Then
Do While sMemberID <> sLastMemberID
sLine = txtCandidates.ReadLine
arrLine = Split(sLine, "|")
If IsArray(arrLine) Then
If UBound(arrLine) > 0 Then
sMemberID = 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)
sMemberID = arrLine(1)
sState = arrLine(2)
strStateCode = arrLine(3)
If UBound(arrLine) = 5 Then
sScrapeStart = arrLine(4)
sScrapeEnd = arrLine(5)
End If
Do While Len(sMemberID) < 9
sMemberID = "0" & sMemberID
Loop
If Len(sMemberID) = 9 Then
strRowScrapeStart = Format(Now, "MM/dd/yyyy hh:mm:ss AMPM")
sCandidatesOut = Trim(sRowID) & "|" & Trim(sMemberID) & "|" & Trim(sState) & "|" & Trim(strStateCode) & "|" & strRowScrapeStart & "|"
sXMLOut = "<Candidate>" & vbCrLf
sXMLOut = sXMLOut & "<RowID>" & sRowID & "</RowID>" & vbCrLf
sXMLOut = sXMLOut & "<MemberID>" & sMemberID & "</MemberID>"
'
' -----------------------------------
' Get member names and start dates
' -----------------------------------
'
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 ", NeverTimeOut, rcAllowKeystrokes
.StatusBar = "Waiting for Prompt: MEMBER NUMBER:"
.WaitForString " " & SI & ESC & "[;;4m" & ESC & "[04;17H ", NeverTimeOut, rcAllowKeystrokes
.StatusBar = ""
'
' Update the state code if necessary
'
If strLastStateCode <> strStateCode Then
.TransmitTerminalKey rcVtPF1Key
.WaitForString "5" & ESC & "[24;01H", NeverTimeOut, rcAllowKeystrokes
.Transmit "h"
.StatusBar = "Waiting for Prompt: CL0100RQ70"
.WaitForString " " & SI & ESC & "[;;1;4m" & ESC & "[02;27H", NeverTimeOut, rcAllowKeystrokes
.StatusBar = ""
.Transmit strStateCode & CR
strLastStateCode = strStateCode
End If
'
' Enter claim ID
'
.Transmit sMemberID
.StatusBar = "Waiting for Prompt: MEMBER NUMBER: 8870044-02 NAME:"
.WaitForString ESC & "[04;40H", NeverTimeOut, 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", NeverTimeOut, 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(sMemberID) & "|" & sState & "|" & 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
sXMLOut = sXMLOut & "<Name>" & vbCrLf
sXMLOut = sXMLOut & "<Instance>" & CStr(iInstance) & "</Instance>" & vbCrLf
sXMLOut = sXMLOut & "<LastName>" & strLast & "</LastName>" & vbCrLf
sXMLOut = sXMLOut & "<FirstName>" & strFirst & "</FirstName>" & vbCrLf
sXMLOut = sXMLOut & "<StartDate>" & strStartDate & "</StartDate>" & vbCrLf
sXMLOut = sXMLOut & "<ProgramMessage/>" & vbCrLf
sXMLOut = sXMLOut & "</Name>" & vbCrLf
strStatus = .GetText(23, 0, 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
If sResult <> "Fail" Then
'
' Go to the Comments Maintenance screen
'
With Session
'
' Press VtPf1 (Perform the VT terminal PF1 function)
'
.TransmitTerminalKey rcVtF20Key
.Wait 1
.Transmit "c"
.TransmitTerminalKey rcVtReturnKey
.Wait 1.5
End With
sComments = ""
bEOC = False
intCount = 0
With Session
Do While Not bEOC
For lRow = 7 To 15
'
' Check to see if we're still on the menu
' and wait until we move to the next screen
'
strTest = Trim(.GetText(lRow, 1, lRow, 35))
intCount = 0
Do While InStr(strTest, "A - CLAIMS HISTORY INQUIRY") > 0
.Wait 0.1
strTest = Trim(.GetText(lRow, 1, lRow, 35))
DoEvents
intCount = intCount + 1
'
' Wait a max of 20 seconds. Then proceed. (Avoid infinite loop)
'
If intCount > 200 Then Exit Do
Loop
'
' We should be past the menu, so we may continue
'
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
sComments = sComments & 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
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), "'")
sComments = Replace(sComments, "/", "-")
sXMLOut = sXMLOut & "<Comments>" & vbCrLf & sComments & vbCrLf & "</Comments>"
With Session
.TransmitTerminalKey rcVtF20Key
.TransmitTerminalKey rcVtPF1Key
.Transmit "M"
.TransmitTerminalKey rcVtReturnKey
.Wait 0.5
End With
Else
sXMLOut = 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
strRowScrapeEnd = Format(Now, "MM/dd/yyyy hh:mm:ss AMPM")
sXMLOut = sXMLOut & "<Stats>" & vbCrLf
sXMLOut = sXMLOut & "<RowScrapeStart>" & Replace(strRowScrapeStart, "/", "-") & "</RowScrapeStart>" & vbCrLf
sXMLOut = sXMLOut & "<RowScrapeEnd>" & Replace(strRowScrapeEnd, "/", "-") & "</RowScrapeEnd>" & vbCrLf
sXMLOut = sXMLOut & "</Stats>" & vbCrLf
sXMLOut = sXMLOut & "</Candidate>" & vbCrLf
txtXMLOut.Write sXMLOut
sCandidatesOut = sCandidatesOut & strRowScrapeEnd
Else
sXMLOut = 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
sXMLOut = sXMLOut & "<Stats>" & vbCrLf
sXMLOut = sXMLOut & "<RowScrapeStart>" & Replace(strRowScrapeStart, "/", "-") & "</RowScrapeStart>" & vbCrLf
sXMLOut = sXMLOut & "<RowScrapeEnd />" & vbCrLf
sXMLOut = sXMLOut & "</Stats>" & vbCrLf
sXMLOut = sXMLOut & "</Candidate>" & vbCrLf
txtXMLOut.Write sXMLOut
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
If lngRecords > 0 Then
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")
Else
MsgBox "All available candidates have been scraped. There are no more candidates to scrape.", vbInformation, "No More Candidates"
End If
Else
MsgBox "The candidates file could not be found.", vbCritical, "Error"
End If
end_Scrape:
On Error Resume Next
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 fld = fso.GetFolder(FilePath)
iCntr = -1
For Each fil In fld.Files
sFile = fil.Name
If Len(sFile) >= 11 Then
If VBA.Strings.Left(sFile, 11) = "Candidates_" Then
iCntr = iCntr + 1
If iCntr = 0 Then
ReDim arrFiles(0)
Else
ReDim Preserve arrFiles(iCntr)
End If
arrFiles(iCntr) = fil.Name
End If
End If
Next
If iCntr >= 0 Then
For iCntr = 0 To UBound(arrFiles)
fso.DeleteFile arrFiles(iCntr)
Next iCntr
End If
iCntr = -1
For Each fil In fld.Files
sFile = fil.Name
If Len(sFile) >= 8 Then
If VBA.Strings.Left(sFile, 8) = "Scraped_" Then
iCntr = iCntr + 1
If iCntr = 0 Then
ReDim arrFiles(0)
Else
ReDim Preserve arrFiles(iCntr)
End If
arrFiles(iCntr) = fil.Name
End If
End If
Next
If iCntr >= 0 Then
For iCntr = 0 To UBound(arrFiles)
fso.DeleteFile arrFiles(iCntr)
Next iCntr
End If
Set fso = Nothing
Exit Sub
err_Scrape:
MsgBox "An error occurred: " & vbCrLf & vbCrLf & _
"Error: " & Err.Description, vbCritical, "Error"
Resume end_Scrape
End Sub
