CS 15
Visual Basic Code Segments
| College Level | Homework Assignments | CS 15 Code | CS 17 Code | CS 60 Code | Discussion Inputs |
Final Schedule | Email to Instructor | Student Sign-up Form |
Table of Contents
1. Galactic Speed
2. PAO Demos, GOP, Indies
3. TicTacToe
4. Colfax Payroll
5. Day Trader
6. Web Page Text Grabber by Kalieb
Davis
' create a form with text1, lblRadius, lblCirc, lblSpeed, txtHours, txtYears
Option Explicit
Dim dblRadius As Double
Dim dblCirc As Double
Dim dblArea As Double
Dim dblSpeed As Double
Dim dblHours As Double
Dim dblYears As Double
Const Pi As Single = 3.14159
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Or KeyAscii = 9 Then
dblRadius = Text1.Text
dblCirc = dblRadius * 2 * Pi
dblArea = dblRadius ^ 2 * Pi
lblCirc.Caption = Format(dblCirc, "Standard")
lblArea.Caption = Format(dblArea, "Standard")
Text1.Text = Format(Text1.Text, "Standard")
End If
End Sub
Private Sub txtHours_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Or KeyAscii = 9 Then
dblHours = txtHours.Text
lblSpeed.Caption = Format(Val(lblCirc.Caption) / dblHours, "Standard")
End If
End Sub
Private Sub txtYears_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Or KeyAscii = 9 Then
dblYears = Val(txtYears.Text)
dblHours = dblYears * 365.25 * 24
lblSpeed.Caption = dblCirc / dblHours
End If
End Sub
=============================================
Dim sAge As String, SParty As String
Dim iAge As Integer, iParty As Integer
Dim iaryDemo(0 To 3) As Integer
Dim iaryRep(0 To 3) As Integer
Dim iaryInd(0 To 3) As Integer
Private Sub cmdSave_Click()
lstAge.Enabled = False
lstParty.Enabled = True
Print #1, SParty, lstAge.ListIndex
End Sub
Private Sub Form_Load()
dlgOpen.ShowOpen
sFilename = dlgOpen.FileName
Open sFilename For Append As #1
lstParty.AddItem "Democratic"
lstParty.AddItem "Republican"
lstParty.AddItem "Independent"
lstAge.Enabled = False
lstParty.Enabled = True
' iiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiii
For i = 0 To 3
Label7(i).Caption = ""
Label8(i).Caption = ""
Label9(i).Caption = ""
Next i
' iiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiii
End Sub
Private Sub List1_Click()
End Sub
Private Sub Form_Unload(Cancel As Integer)
Close
End Sub
Private Sub lstAge_Click()
sAge = lstAge.Text
iAge = lstAge.ListIndex
lstAge.Enabled = False
Select Case SParty
Case "Democratic"
Label7(iAge).Caption = Val(Label7(iAge)) + 1
Case "Republican"
Label8(iAge).Caption = Val(Label8(iAge)) + 1
Case "Independent"
Label9(iAge).Caption = Val(Label9(iAge)) + 1
End Select
End Sub
Private Sub lstParty_Click()
SParty = lstParty.Text
iParty = lstParty.ListIndex
lstParty.Enabled = False
lstAge.Enabled = True
End Sub
Dim icount As Integer, aryTic(0 To 2, 0 To 2) As String
Dim x As Integer, y As Integer
Private Sub cmdClear_Click()
For i = 0 To 8
Label1(i).FontSize = 30
Label1(i).FontBold = True
Label1(i).ForeColor = vbBlue
Label1(i).Caption = ""
Label1(i).Alignment = 2
Next i
FormTicTacToe.BackColor = vbWhite
icount = 0
Label2.Caption = "X Starts"
End Sub
Private Sub cmdexit_Click()
End
End Sub
Private Sub Form_Load()
Call cmdClear_Click
End Sub
Private Sub Label1_Click(Index As Integer)
y = Index Mod 3: x = Index Mod 4
Select Case icount
Case 0, 2, 4, 6, 8: Label1(Index).Caption = "X"
aryTic(x, y) = "X"
Case 1, 3, 5, 7, 9: Label1(Index).Caption = "O"
aryTic(x, y) = "O"
End Select
Call TestWin(Index)
icount = icount + 1
End Sub
Private Sub TestWin(Index As Integer)
For i = 0 To 2 'Horizontal
sOX = Label1(i).Caption + Label1(i + 3).Caption + Label1(i + 6).Caption
If sOX = "XXX" Or sOX = "OOO" Then
FormTicTacToe.BackColor = vbRed
For j = i To i + 6 Step 3: Label1(j).FontSize = 50: Next j
End If
Next i
'''''''''''
For i = 0 To 6 Step 3 'Vertical
sOX = Label1(i).Caption + Label1(i + 1).Caption + Label1(i + 2).Caption
If sOX = "XXX" Or sOX = "OOO" Then
FormTicTacToe.BackColor = vbRed
For j = i To i + 2: Label1(j).FontSize = 50: Next j
End If
Next i
'Diagonal SE
If Label1(0).Caption = Label1(4).Caption And Label1(8).Caption =
Label1(4).Caption And (Label1(0).Caption = "X" Or Label1(0).Caption =
"O") Then
FormTicTacToe.BackColor = vbRed
For j = 0 To 8 Step 4: Label1(j).FontSize = 50: Next j
End If
'Diagonal NE
If Label1(2).Caption = Label1(4).Caption And Label1(2).Caption =
Label1(6).Caption And (Label1(2).Caption = "X" Or Label1(2).Caption =
"O") Then
FormTicTacToe.BackColor = vbRed
For j = 0 To 6 Step 2: Label1(j).FontSize = 50: Next j
End If
If FormTicTacToe.BackColor = vbRed Then
Select Case icount
Case 0, 2, 4, 6, 8: Label2.Caption = "X Wins!"
Case 1, 3, 5, 7, 9: Label2.Caption = "0 Wins!"
End Select
End If
End Sub
Private Sub TestXY()
sOXx = aryTic(x, 0) + aryTic(x, 1) + aryTic(x, 2)
sOXy = aryTic(0, y) + aryTic(1, y) + aryTic(2, y)
If sOXx = "XXX" Or sOXx = "OOO" Then
End If
End Sub
======================================
Private Sub cmdGross_Click()
Dim sGross As Currency, sHours As Single, sRate As Single
'iRecCount = adoColfax.Recordset.RecordCount
'adoColfax.Caption = adoColfax.Caption + " " + Str(iRecCount)
adoColfax.Recordset.MoveFirst
If txtFWT.Text = "" Or Val(txtFWT.Text) >= 1 Then
x = MsgBox("Please type in a value less than 1 for FWT", vbOKOnly)
txtFWT.SetFocus
End If
Do While Not adoColfax.Recordset.EOF
sHours = Label1(12).Caption
sRate = Label1(13).Caption
sGross = sHours * sRate
Label1(14).Caption = sGross
sFWTRate = Val(txtFWT.Text)
sFWT = sFWTRate * sGross
Label1(15).Caption = sFWT
adoColfax.Recordset.MoveNext
Loop
adoColfax.Recordset.MoveFirst
adoColfax.Recordset.Update
End Sub
Private Sub cmdSetup_Click()
For i = 0 To 9
Label1(i + 10).DataField = Label1(i).Caption
Next i
End Sub
Private Sub Form_Load()
Form1.BackColor = vbBlue
End Sub
VERSION 5.00
Object = "{67397AA1-7FB1-11D0-B148-00A0C922E820}#6.0#0"; "MSADODC.OCX"
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 4410
ClientLeft = 60
ClientTop = 345
ClientWidth = 5160
LinkTopic = "Form1"
ScaleHeight = 4410
ScaleWidth = 5160
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton cmdSeatTraders
Caption = "&Seat Traders"
Height = 495
Left = 120
TabIndex = 18
Top = 2760
Width = 975
End
Begin MSAdodcLib.Adodc adoTraders
Height = 330
Left = 120
Top = 4080
Width = 3135
_ExtentX = 5530
_ExtentY = 582
ConnectMode = 0
CursorLocation = 3
IsolationLevel = -1
ConnectionTimeout= 15
CommandTimeout = 30
CursorType = 3
LockType = 3
CommandType = 2
CursorOptions = 0
CacheSize = 50
MaxRecords = 0
BOFAction = 0
EOFAction = 0
ConnectStringType= 1
Appearance = 1
BackColor = -2147483643
ForeColor = -2147483640
Orientation = 0
Enabled = -1
Connect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\TEMP\vbtoday\Traders.mdb;Persist Security Info=False"
OLEDBString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\TEMP\vbtoday\Traders.mdb;Persist Security Info=False"
OLEDBFile = ""
DataSourceName = ""
OtherAttributes = ""
UserName = ""
Password = ""
RecordSource = "tblTraders"
Caption = "adoTraders"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
_Version = 393216
End
Begin VB.CommandButton Command1
Caption = "&Load Traders"
Height = 495
Left = 120
TabIndex = 0
Top = 3360
Width = 975
End
Begin VB.Label Label2
Caption = "Total Profit / Loss"
Height = 495
Left = 2760
TabIndex = 22
Top = 3480
Width = 1215
End
Begin VB.Label Label1
Caption = "Total Rent"
Height = 495
Left = 2760
TabIndex = 21
Top = 2880
Width = 1215
End
Begin VB.Label lblTotProfit_Loss
Alignment = 1 'Right Justify
BorderStyle = 1 'Fixed Single
Caption = "Label1"
Height = 495
Left = 4080
TabIndex = 20
Top = 3480
Width = 975
End
Begin VB.Label lbltotRent
Alignment = 1 'Right Justify
BorderStyle = 1 'Fixed Single
Caption = "Label1"
Height = 495
Left = 4080
TabIndex = 19
Top = 2880
Width = 975
End
Begin VB.Label lblEntry
BorderStyle = 1 'Fixed Single
Caption = "Entry"
DataField = "Pofit_Loss"
DataSource = "adoTraders"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Index = 4
Left = 240
TabIndex = 17
Top = 1920
Width = 1695
End
Begin VB.Label lblEntry
BorderStyle = 1 'Fixed Single
Caption = "Entry"
DataField = "SeatID"
DataSource = "adoTraders"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Index = 3
Left = 240
TabIndex = 16
Top = 1440
Width = 1695
End
Begin VB.Label lblEntry
BorderStyle = 1 'Fixed Single
Caption = "Entry"
DataField = "Rent"
DataSource = "adoTraders"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Index = 2
Left = 240
TabIndex = 15
Top = 960
Width = 1695
End
Begin VB.Label lblEntry
BorderStyle = 1 'Fixed Single
Caption = "Entry"
DataField = "DateWanted"
DataSource = "adoTraders"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Index = 1
Left = 240
TabIndex = 14
Top = 480
Width = 1695
End
Begin VB.Label lblEntry
BorderStyle = 1 'Fixed Single
Caption = "Entry"
DataField = "Trader"
DataSource = "adoTraders"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Index = 0
Left = 240
TabIndex = 13
Top = 0
Width = 1695
End
Begin VB.Label lblTrader
BorderStyle = 1 'Fixed Single
Caption = "Trader"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Index = 5
Left = 2640
TabIndex = 12
Top = 2400
Width = 1455
End
Begin VB.Label lblTrader
BorderStyle = 1 'Fixed Single
Caption = "Trader"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Index = 4
Left = 2640
TabIndex = 11
Top = 1920
Width = 1455
End
Begin VB.Label lblTrader
BorderStyle = 1 'Fixed Single
Caption = "Trader"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Index = 3
Left = 2640
TabIndex = 10
Top = 1440
Width = 1455
End
Begin VB.Label lblTrader
BorderStyle = 1 'Fixed Single
Caption = "Trader"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Index = 2
Left = 2640
TabIndex = 9
Top = 960
Width = 1455
End
Begin VB.Label lblTrader
BorderStyle = 1 'Fixed Single
Caption = "Trader"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Index = 1
Left = 2640
TabIndex = 8
Top = 480
Width = 1455
End
Begin VB.Label lblTrader
BorderStyle = 1 'Fixed Single
Caption = "Trader"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Index = 0
Left = 2640
TabIndex = 7
Top = 0
Width = 1455
End
Begin VB.Label lblRent
BorderStyle = 1 'Fixed Single
Caption = "Rent"
BeginProperty Font
Name = "MS Sans Serif"
Size = 13.5
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Index = 5
Left = 4200
TabIndex = 6
Top = 2400
Width = 855
End
Begin VB.Label lblRent
BorderStyle = 1 'Fixed Single
Caption = "Rent"
BeginProperty Font
Name = "MS Sans Serif"
Size = 13.5
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Index = 4
Left = 4200
TabIndex = 5
Top = 1920
Width = 855
End
Begin VB.Label lblRent
BorderStyle = 1 'Fixed Single
Caption = "Rent"
BeginProperty Font
Name = "MS Sans Serif"
Size = 13.5
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Index = 3
Left = 4200
TabIndex = 4
Top = 1440
Width = 855
End
Begin VB.Label lblRent
BorderStyle = 1 'Fixed Single
Caption = "Rent"
BeginProperty Font
Name = "MS Sans Serif"
Size = 13.5
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Index = 2
Left = 4200
TabIndex = 3
Top = 960
Width = 855
End
Begin VB.Label lblRent
BorderStyle = 1 'Fixed Single
Caption = "Rent"
BeginProperty Font
Name = "MS Sans Serif"
Size = 13.5
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Index = 1
Left = 4200
TabIndex = 2
Top = 480
Width = 855
End
Begin VB.Label lblRent
BorderStyle = 1 'Fixed Single
Caption = "Rent"
BeginProperty Font
Name = "MS Sans Serif"
Size = 13.5
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Index = 0
Left = 4200
TabIndex = 1
Top = 0
Width = 855
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim Trader(0 To 1000) As String
Dim datewanted(0 To 1000) As String
Dim rent(0 To 1000) As Currency
Dim Last As String, First As String
Dim Profit_Loss(0 To 1000) As CurrencyPrivate Sub cmdSeatTraders_Click() adoTraders.Recordset.MoveFirst Dim i As Integer, seatID As Integer
dTheDate = InputBox("Type The Trading Date")
For i = 0 To 50
If datewanted(i) = dTheDate Then
lblEntry(0).Caption = Trader(i)
lblEntry(1).Caption = datewanted(i)
lblEntry(2).Caption = rent(i)
lblEntry(3).Caption = seatID
Profit_Loss(i) = -1000 + Rnd() * 2000
iTotRent = iTotRent + rent(i)
iTotProfit = iTotProfit + Profit_Loss(i)
lblRent(seatID).Caption = rent(i)
lblTrader(seatID).Caption = Trader(i)
seatID = seatID + 1
'''''''''''''''''''''''''
If seatID >= 6 Then
Exit For
End If
'''''''''''''''''''''''''
adoTraders.Recordset.AddNew End If
Next i lbltotRent.Caption = iTotRent lblTotProfit_Loss.Caption = Format(iTotProfit, "currency")
End Sub
Private Sub Command1_Click() Do While Not EOF(1) Input #1, Last, First, datewanted(i), rent(i) Debug.Print Last, First, datewanted(i), rent(i) Trader(i) = Last & ", " & First i = i + 1
Loop Close #1
End Sub
Private Sub Form_Load() Open "c:\temp\vbtoday\traders.txt" For Input As #1 End Sub
6. Web Page Text Grabber
This code was provided by Kalieb Davis. It is very powerful. It is the basis for web crawling and sniffing on the web.
You must click Projects, Components and then Internet Transfer Control In the code it is referred to as Inte1.
Private Sub cmdGo_Click()
Dim b() As Byte
Dim dblCount As Double
Dim strData As String
Inet1.URL = txtURL.Text 'sets url in internet transfer control to the txtURL in
the
'form. This ensures that the URL is properly formed.
Inet1.Cancel ' Stops any current operations
b() = Inet1.OpenURL(Inet1.URL, icByteArray) 'convert byte array to string
For dblCount = 0 To UBound(b) - 1 ' loops though byte array concatenating
'characters onto string
strData = strData & Chr(b(dblCount))
Next dblCount
txtHTML.Text = strData ' Displays result
End Sub