by Matthew Holton (1 Submission)
Category: Files/File Controls/Input/Output
Compatability: Visual Basic 5.0
Difficulty: Unknown Difficulty
Originally Published: Sun 11th November 2001
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Opens a text file and reads in sales values for sales reps, then writes out a report to a text file.
API Declarations
'*****************************************************************************
' Sales Reporting
'-----------------------------------------------------------------------------
'
' Opens a CSV Data source, reads the sales information and
' generates a series of reports based on these reports.
'
' This module was desinged to be incorporated inside of
' Excel.
'
'
' Author: <Your Name Here>
' Date Create: 11/11/2001
'
' Procedures Included:
' 1. Sub Main() - Wrapper for the whole thing. We start here
' 2. Func ReadData() as Boolean - Has the user select the input file
' and reads the data in. Data is then
' populated into an array arrSales().
' 3. Func ComputeData() as boolean - Base function to run all the calc-
' ulations.
' 4. Func AvgSales() as Boolean - Averages the sales for each sales person.
' 5. Func GetPay() as Boolean - Populates an array with amount to pay.
' 6. Func WriteReports() as Boolean - Generates any reports needed
' 7. Sub CleanUp() - Releases objects from memory and destroys vars
'
' Modifications:
' None
'
'*****************************************************************************
'Local variables
Dim arrSalesPPL() As Long 'Used to validate our sales ppl
Dim arrSales() As Currency 'Used to hold sales information
Dim arrPay() As Currency 'Used to hold payment information
Dim AVGSales As Currency 'Used to hold the average sales amount
Dim iSaleCount As Long 'Used to count the number of sales that we have
Dim cSaleValue As Currency 'Used to hold the GrandTotal of All Sales
Dim IsInit As Boolean 'Used to state that this module was properly initialized
VBcoders
'*****************************************************************************
' Procedure :- Main
'-----------------------------------------------------------------------------
' Master Wrapper for Compute That! Weekly Payment Calculator
'*****************************************************************************
On Error GoTo Sub_Err
Dim bRet As Boolean ' Used to handle the status of a function that we called
'initialize
'Clean arrays
ReDim arrSales(0)
ReDim arrPay(0)
ReDim arrSalesPPL(0)
IsInit = True
bRet = ReadData(): If Not bRet Then GoTo Sub_ErrExit
bRet = ComputeData(): If Not bRet Then GoTo Sub_ErrExit
bRet = PrintSalesReport(): If Not bRet Then GoTo Sub_ErrExit
Sub_ErrExit:
'Used when we get a False from a called function.
'We want to end our application gracefully.
GoTo Sub_Exit
Sub_Exit:
'Turn off Init
IsInit = False
'Clean up memory stack
Call CleanUp
Exit Sub
Sub_Err:
'Used for errors that happen in this sub routine.
Dim sErrMSG As String
sErrMSG = "There was an error in Sub_Main. " & vbCrLf
sErrMSG = sErrMSG & "The Error Code is: " & Err.Number & vbCrLf
sErrMSG = sErrMSG & "The Error Description is:" & Err.Description & vbCrLf
sErrMSG = sErrMSG & "This application cannot continue, and no reports will be generated." & vbCrLf
sErrMSG = sErrMSG & "If this problem persists, contact the author."
MsgBox sErrMSG, vbCritical + vbOKOnly, "Error!"
Resume Sub_Exit
End Sub
Private Sub CleanUp()
'*****************************************************************************
' Procedure :- CleanUp
'-----------------------------------------------------------------------------
' Clears everything from memory and releases any objects.
'*****************************************************************************
Erase arrSales
Erase arrPay
End Sub
Private Function ReadData() As Boolean
'*****************************************************************************
' Procedure :- ReadData
'-----------------------------------------------------------------------------
' Loads data into memory from a CSV File.
'
' Returns true on success
'
'*****************************************************************************
On Error GoTo Func_Err
Dim sFile As String, iFile As Long
Dim iRet As Long, sTemp As String
Top:
'Get the file name from the user
If sFile = "" Then
sFile = InputBox("Where is the file to open?" & vbCrLf & "The file must be preformatted for use with this application." & vbCrLf & "Inside the file, it should look like this:" & vbCrLf & "1, 2445.66" & vbCrLf & "5, 87.99" & vbCrLf & "... And so on.", "Open Data Source.", App.Path & "\salary.txt")
Else
sFile = InputBox("Where is the file to open?" & vbCrLf & "The file must be preformatted for use with this application." & vbCrLf & "Inside the file, it should look like this:" & vbCrLf & "1, 2445.66" & vbCrLf & "5, 87.99" & vbCrLf & "... And so on.", "Open Data Source.", sFile)
End If
'Validate User Input
If sFile = vbNullString Or sFile = "" Then
iRet = MsgBox("Are you sure you want to abort this operation?", vbQuestion + vbYesNo, "Confirm Action")
Select Case iRet
Case vbYes
'The user does not want to continue
ReadData = False
GoTo Func_Exit
Case vbNo
'The user got trigger happy, lets try it again.
GoTo Top
End Select
Else
'We have a string value. Lets validate it.
If Dir(sFile) <> "" Then
'we have a valid filename, but whats inside of it.
GoTo Middle
Else
End If
End If
Middle:
iFile = FreeFile
Open sFile For Input As #iFile
While Not EOF(iFile)
'While..wend is faster that Do..Loop
'Select case is faster than IF..End IF
'If..End IF is faster that iif()
Line Input #iFile, sTemp
If sTemp <> "" Then
If AddSalesItem(sTemp) Then
'This was a good line, and no problems were encountered
'Do nothing... Follow through logic.
Else
'This was a bad line, and should be grounded for a week
GoTo Func_Exit
End If
End If
Wend
Close #iFile
Bottom:
Debug.Print "Loading of data is complete and successful"
ReadData = True
Func_Exit:
Exit Function
Func_Err:
'Try to handle the errors
Select Case Err.Number
Case 53
'Bad file name or number
iRet = MsgBox("This is not a valid file. Would you like to create it?", vbQuestion + vbYesNo, "Confirm Action")
Select Case iRet
Case vbYes
'The user got trigger happy, lets try it again.
'Clear our error
Err.Clear
Call CreateSample(sFile)
Resume Top
Case vbNo
iRet = MsgBox("This is not a valid file. Would you like to try again?", vbQuestion + vbYesNo, "Confirm Action")
Select Case iRet
Case vbYes
'The user got trigger happy, lets try it again.
'Clear our error
Err.Clear
Resume Top
Case vbNo
'The user does not want to continue
ReadData = False
GoTo Func_Exit
End Select
End Select
End Select
ReadData = False
'Used for errors that happen in this sub routine.
Dim sErrMSG As String
sErrMSG = "There was an error while loading the data.. " & vbCrLf
sErrMSG = sErrMSG & "The Error Code is: " & Err.Number & vbCrLf
sErrMSG = sErrMSG & "The Error Description is:" & Err.Description & vbCrLf
sErrMSG = sErrMSG & "This application cannot continue, and no reports will be generated." & vbCrLf
sErrMSG = sErrMSG & "If this problem persists, contact the author."
MsgBox sErrMSG, vbCritical + vbOKOnly, "Error!"
Resume Func_Exit
End Function
Private Function AddSalesItem(ByVal sTemp As String) As Boolean
'*****************************************************************************
' Procedure :- AddSalesItem
'-----------------------------------------------------------------------------
' Add Sales Item to arrSales()
'
' Inputs: sTemp, The actual data "ID","Amount"
' Returns: True on success
'
'*****************************************************************************
Dim lID As Long, cValue As Currency
Dim x As Long
On Error GoTo Func_Err
'Do we have a comma
x = InStr(1, sTemp, ",", vbTextCompare)
If IsNull(x) Then
'We have a bad line.
'For now we will just omit it
' and not trouble the user.
ElseIf x > 0 Then
lID = CLng(Mid(sTemp, 1, x - 1))
cValue = CCur(Mid(sTemp, x + 1, Len(sTemp) - x))
Debug.Print "Adding Item: " & lID & "~~" & cValue
'Validate the ID Must be greater than 0
If lID > 0 Then
'Ensure that we have this many items in our array
If lID > UBound(arrSalesPPL) Then
ReDim Preserve arrSalesPPL(lID)
ReDim Preserve arrSales(lID)
End If
arrSalesPPL(lID) = lID
arrSales(lID) = arrSales(lID) + cValue
End If
Else
'We have a bad line.
'For now we will just omit it
' and not trouble the user.
End If
AddSalesItem = True
Func_Exit:
Exit Function
Func_Err:
Select Case Err.Number
'we may encounter err 9 - Subscript out of range.
Case 9
'We didn't account for enough slots in our array.
'We will just ignore it for now.
Err.Clear
AddSalesItem = True
Resume Func_Exit
End Select
AddSalesItem = False
'Used for errors that happen in this sub routine.
Dim sErrMSG As String
sErrMSG = "There was an error while loading the data (Parsing a row).. " & vbCrLf
sErrMSG = sErrMSG & "The Error Code is: " & Err.Number & vbCrLf
sErrMSG = sErrMSG & "The Error Description is:" & Err.Description & vbCrLf
sErrMSG = sErrMSG & "This application cannot continue, and no reports will be generated." & vbCrLf
sErrMSG = sErrMSG & "If this problem persists, contact the author."
MsgBox sErrMSG, vbCritical + vbOKOnly, "Error!"
Resume Func_Exit
End Function
Private Function ComputeData() As Boolean
'*****************************************************************************
' Procedure :- ComputeData
'-----------------------------------------------------------------------------
'
' We now have data, lets compute it in a varaity of ways. This proc it the
' wrapper for those functions
'
' Returns: True on success
'
'*****************************************************************************
On Error GoTo Func_Err
'We need a average of sales.
Dim xLoop As Long
Dim cBasePay As Currency, cBonusPay As Currency
iSaleCount = 0
cSaleValue = 0
For xLoop = 1 To UBound(arrSalesPPL)
'Validate that this is a valid person
If arrSalesPPL(xLoop) <> 0 Then
'Count the number of sales
iSaleCount = iSaleCount + 1
'Total the sales
cSaleValue = cSaleValue + arrSales(xLoop)
End If
Next xLoop
If iSaleCount > 0 Then
AVGSales = cSaleValue / iSaleCount
End If
Debug.Print "The number of sales ppl is:" & iSaleCount
Debug.Print "The total from sales is:" & cSaleValue
Debug.Print "The average of sales is:" & AVGSales
ReDim arrPay(UBound(arrSales))
For xLoop = 1 To UBound(arrSales)
'Validate that this is a valid person
If arrSales(xLoop) > AVGSales Then
If CalcThisPay(xLoop) Then
Else
GoTo Func_Exit
End If
Debug.Print arrSalesPPL(xLoop) & " Has sold over the average with " & arrSales(xLoop) & " in sales this week."
End If
Next xLoop
cBasePay = 100
cBonusPay = 50
'One more and final time
For xLoop = 1 To UBound(arrSales)
If arrSalesPPL(xLoop) > 0 Then
arrPay(xLoop) = arrPay(xLoop) + cBasePay
If arrSales(xLoop) > AVGSales Then
arrPay(xLoop) = arrPay(xLoop) + cBonusPay
End If
End If
Next xLoop
ComputeData = True
Func_Exit:
Exit Function
Func_Err:
'Used for errors that happen in this sub routine.
Dim sErrMSG As String
sErrMSG = "There was an error while calculating the data... " & vbCrLf
sErrMSG = sErrMSG & "The Error Code is: " & Err.Number & vbCrLf
sErrMSG = sErrMSG & "The Error Description is:" & Err.Description & vbCrLf
sErrMSG = sErrMSG & "This application cannot continue, and no reports will be generated." & vbCrLf
sErrMSG = sErrMSG & "If this problem persists, contact the author."
MsgBox sErrMSG, vbCritical + vbOKOnly, "Error!"
Resume Func_Exit
End Function
Private Function CalcThisPay(Element As Long) As Boolean
'*****************************************************************************
' Procedure :- CalcThisPay
'-----------------------------------------------------------------------------
'
' This function calculates the amount the sales person makes
'
' Returns: True on success
'
'*****************************************************************************
On Error GoTo Func_Err
'<= $1000 3%
'>$1000 but < = $5000 4.5%
'>$5000 but < = %10,000 5.25%
'> $10,000 6%
Dim cBasePay As Currency
cBasePay = 100
Select Case arrSales(Element)
Case Is <= 1000
arrPay(Element) = arrPay(Element) + (cBasePay * 0.03)
Case 1001 To 5000
arrPay(Element) = arrPay(Element) + (cBasePay * 0.045)
Case 5001 To 10000
arrPay(Element) = arrPay(Element) + (cBasePay * 0.0525)
Case Is > 10000
arrPay(Element) = arrPay(Element) + (cBasePay * 0.06)
End Select
CalcThisPay = True
Func_Exit:
Exit Function
Func_Err:
'Used for errors that happen in this sub routine.
Dim sErrMSG As String
sErrMSG = "There was an error while calculating pay... " & vbCrLf
sErrMSG = sErrMSG & "The Error Code is: " & Err.Number & vbCrLf
sErrMSG = sErrMSG & "The Error Description is:" & Err.Description & vbCrLf
sErrMSG = sErrMSG & "This application cannot continue, and no reports will be generated." & vbCrLf
sErrMSG = sErrMSG & "If this problem persists, contact the author."
MsgBox sErrMSG, vbCritical + vbOKOnly, "Error!"
Resume Func_Exit
End Function
Private Function PrintSalesReport() As Boolean
'*****************************************************************************
' Procedure :- PrintSalesReport
'-----------------------------------------------------------------------------
'
' Print a sales report to file
'
' Returns: True on success
'
'*****************************************************************************
On Error GoTo Func_Err
Dim iRet As Long, sFile As String, iFile As Long
Dim sTemp As String, TotalPay As Currency
Dim sReturn As String
'Create the output
iRet = MsgBox("Do you want to watch the sales report as it is created?", vbQuestion + vbYesNo, "Um, Question...")
If iRet = vbYes Then
sReturn = vbCr
Else
sReturn = vbCrLf
End If
sTemp = "--------------------------------->Sales Report<---------------------------------" & sReturn
sTemp = sTemp & "For week of: " & GetWeek() & sReturn
sTemp = sTemp & "" & sReturn
sTemp = sTemp & "" & sReturn
sTemp = sTemp & "Sales Rep ID" & vbTab & vbTab & vbTab & "Sales Amount" & vbTab & vbTab & vbTab & "Pay Amount" & sReturn
For iFile = 1 To UBound(arrSales)
If arrSalesPPL(iFile) > 0 Then
TotalPay = TotalPay + arrPay(iFile)
sTemp = sTemp & IIf((arrSales(iFile) > AVGSales), "*" & CStr(arrSalesPPL(iFile)), CStr(arrSalesPPL(iFile)))
sTemp = sTemp & vbTab & vbTab & vbTab & vbTab
sTemp = sTemp & "$" & PadToSameLen(Format$(arrSales(iFile), "#,##0.00"), Len(cSaleValue) + 5)
sTemp = sTemp & vbTab & vbTab & vbTab
sTemp = sTemp & "$" & PadToSameLen(Format$(arrPay(iFile), "#,##0.00"), Len(cSaleValue) + 5) & sReturn
End If
Next iFile
sTemp = sTemp & "" & vbTab & vbTab & vbTab & vbTab & "---------------" & vbTab & vbTab & vbTab & "---------------" & sReturn
sTemp = sTemp & "Totals" & vbTab & vbTab & vbTab & vbTab & "$" & PadToSameLen(Format$(cSaleValue, "#,##0.00"), Len(cSaleValue) + 5)
sTemp = sTemp & vbTab & vbTab & vbTab & "$" & PadToSameLen(Format$(TotalPay, "#,##0.00"), Len(cSaleValue) + 5) & sReturn
sTemp = sTemp & "" & sReturn
sTemp = sTemp & "" & sReturn
sTemp = sTemp & "Note - * represents sales reps who had above average sales ,""" & Format$(AVGSales, "$ #,##0.00") & """, this week."
Select Case iRet
Case vbYes
Call WatchSalesReport(sTemp)
PrintSalesReport = True
GoTo Func_Exit
Case vbNo
'Create it then msgbox the user that the job is done
'and where to find the file
sFile = App.Path & "\salesreport-" & Format(Date, "mm-dd-yyyy") & ".txt"
iFile = FreeFile
Open sFile For Output As #iFile
Print #iFile, sTemp
Close #iFile
Shell "Notepad " & QuoteMe(sFile)
End Select
PrintSalesReport = True
Func_Exit:
Exit Function
Func_Err:
'Used for errors that happen in this sub routine.
Dim sErrMSG As String
sErrMSG = "There was an error while generating Sales Report... " & vbCrLf
sErrMSG = sErrMSG & "The Error Code is: " & Err.Number & vbCrLf
sErrMSG = sErrMSG & "The Error Description is:" & Err.Description & vbCrLf
sErrMSG = sErrMSG & "This application cannot continue, and no reports will be generated." & vbCrLf
sErrMSG = sErrMSG & "If this problem persists, contact the author."
MsgBox sErrMSG, vbCritical + vbOKOnly, "Error!"
Resume Func_Exit
End Function
Private Function WatchSalesReport(sData As String) As Boolean
'*****************************************************************************
' Procedure :- WatchSalesReport
'-----------------------------------------------------------------------------
'
' Creates a text file
' Opens the file
' Populates it with data.
'
' Returns: True on success
'
'*****************************************************************************
On Error GoTo Func_Err
Dim sFile As String, iFile As Long, dRet As Double
sFile = App.Path & "\salesreport-" & Format(Date, "mm-dd-yyyy") & ".txt"
iFile = FreeFile
'Create the file
Open sFile For Output As #iFile
Close #iFile
dRet = Shell("Notepad " & QuoteMe(sFile), vbNormalFocus)
DoEvents
If dRet > 0 Then
If SendToReport(sData, dRet) Then
Else
GoTo Func_Exit
End If
End If
WatchSalesReport = True
Func_Exit:
Exit Function
Func_Err:
'Used for errors that happen in this sub routine.
Dim sErrMSG As String
sErrMSG = "There was an error while opening the report... " & vbCrLf
sErrMSG = sErrMSG & "The Error Code is: " & Err.Number & vbCrLf
sErrMSG = sErrMSG & "The Error Description is:" & Err.Description & vbCrLf
sErrMSG = sErrMSG & "This application cannot continue, and no reports will be generated." & vbCrLf
sErrMSG = sErrMSG & "If this problem persists, contact the author."
MsgBox sErrMSG, vbCritical + vbOKOnly, "Error!"
Resume Func_Exit
End Function
Private Function SendToReport(sData As String, AppID As Double) As Boolean
'*****************************************************************************
' Procedure :- SendToReport
'-----------------------------------------------------------------------------
' Using SendKeys, SendsData to the report.
'
' Caution, this will send keys to the active application.
' Always save this project before running it.
'*****************************************************************************
Dim xLoop As Long
For xLoop = 1 To Len(sData)
'Look for Special values
'for right now we will just send it
AppActivate AppID: DoEvents
Debug.Print "calling. SendKeys(" & Mid(sData, xLoop, 1) & ")"
Call SendKeys(Mid(sData, xLoop, 1)): DoEvents
AppActivate AppID: DoEvents
Next xLoop
End Function
Private Function QuoteMe(TheMe As String) As String
'*****************************************************************************
' Procedure :- ReadData
'-----------------------------------------------------------------------------
' Wraps quotes around a string. Useful for filepaths.
' I always get confused with quotes.
'
'*****************************************************************************
Dim sTemp As String
sTemp = """"
sTemp = sTemp & TheMe
sTemp = sTemp & """"
QuoteMe = sTemp
End Function
Private Function TemplateFunction() As Boolean
'*****************************************************************************
' Procedure :- TemplateFunction
'-----------------------------------------------------------------------------
'
' TemplateFunction does nothing, just there for copy/paste
'
' Returns: True on success
'
'*****************************************************************************
On Error GoTo Func_Err
TemplateFunction = True
Func_Exit:
Exit Function
Func_Err:
'Used for errors that happen in this sub routine.
Dim sErrMSG As String
sErrMSG = "There was an error while <Action Here>... " & vbCrLf
sErrMSG = sErrMSG & "The Error Code is: " & Err.Number & vbCrLf
sErrMSG = sErrMSG & "The Error Description is:" & Err.Description & vbCrLf
sErrMSG = sErrMSG & "This application cannot continue, and no reports will be generated." & vbCrLf
sErrMSG = sErrMSG & "If this problem persists, contact the author."
MsgBox sErrMSG, vbCritical + vbOKOnly, "Error!"
Resume Func_Exit
End Function
Private Function PadToSameLen(sData As String, sLen As Long) As String
Dim xLoop As Long
For xLoop = 1 To sLen - Len(sData)
PadToSameLen = PadToSameLen + " "
Next xLoop
PadToSameLen = PadToSameLen & sData
End Function
Private Function GetWeek() As String
Dim ThisDay As String, iDayAdd As Integer
Dim ThisDate As Date, ThisReturn As String
ThisDay = Format(Date, "ddd")
Select Case UCase(ThisDay)
Case UCase("sun")
'This report is for the past week
iDayAdd = -7
Case UCase("mon")
'This report is for the past week
iDayAdd = -8
Case UCase("tue")
'This report is for the past week
iDayAdd = -9
Case UCase("web")
'This report is for the past week
iDayAdd = -10
Case UCase("thu")
'This report is for the past week
iDayAdd = -11
Case UCase("fri")
'This report is for this week
iDayAdd = -12
Case UCase("sat")
'This report is for the past week
iDayAdd = -13
End Select
ThisDate = DateAdd("d", iDayAdd, Date)
ThisReturn = Format(ThisDate, "mm-dd-yyyy")
GetWeek = ThisReturn
End Function
Function CreateSample(sFile As String) As String
Dim iLoop As Long
Dim MaxEntries As Long, MaxSalesPPL As Long, MaxDollar As Double
Dim Upper As Long, Lower As Long
Dim CurPerson As Long, CurValue As Double
Dim sTemp As String
Randomize Timer
Upper = 200000#
Lower = 15#
MaxEntries = Int(((Upper - Lower) * Rnd) + 1)
DoEvents
Randomize Timer
Upper = Int(MaxEntries / 10)
Lower = 10#
MaxSalesPPL = Int(((Upper - Lower) * Rnd) + 1)
MaxDollar = 100000#
Debug.Print MaxSalesPPL & "~" & MaxEntries
For iLoop = 1 To MaxEntries
Randomize Timer
Upper = MaxDollar
Lower = 1
CurValue = Round(((Upper - Lower) * Rnd) + 1, 2)
Randomize Timer
Upper = MaxSalesPPL
Lower = 1
CurPerson = Int(((Upper - Lower) * Rnd) + 1)
Debug.Print CurPerson & "~" & CurValue
sTemp = sTemp & vbCrLf & CurPerson & "," & CurValue
Next iLoop
iLoop = FreeFile
Open sFile For Output As #iLoop
Print #iLoop, sTemp
Close #iLoop
End Function
No comments have been posted about Opens a text file and reads in sales values for sales reps, then writes out a report to a text file. Why not be the first to post a comment about Opens a text file and reads in sales values for sales reps, then writes out a report to a text file.