Government College Sector-9
Gurugram
Practical File
on
“Visual Basics”
Submitted To: Submitted By:
Punya Prakash
BCA 3rd Year
Roll No. - 1230098113
Reg. No. - 231280400106
Sr. No. Program Title Date Signature
Design a form for arithmetic operations
1
using textbox, label, command button.
Design a form for speed control program
2
using scroll bars.
Design a form to display a picture using
image box/picture box selected from a file
3
in file list box directory list box, drive list
box.
Design a form using shape control to
4 display signal and change it timely using
timer control.
Design form to create a font dialog box
5 using combo/ list, text, option buttons,
and check box control.
Design a simple application using OLE
6
control.
Design a form using Tab control, image
7 list, status bar, tool bar which facilitates
different arithmetic operations.
Design a form using menu editor, MDI,
common dialog box which has standard
8
format like Notepad. (Eg. File, Edit,
format) open copy, font, save and cut.
Design a simple database application
which covers all database concepts. (Data
9 control, DAO, RDO, ADO, DB-list, DB
combo), Create property pages without
using the property page wizard.
1. Design a form for arithmetic operations using textbox, label, command button.
Source Code:
Option Explicit
Private Sub Form_Load()
[Link] = ""
End Sub
Private Function GetInputs(ByRef a As Double, ByRef b As Double) As Boolean
If Trim([Link]) = "" Or Trim([Link]) = "" Then
MsgBox "Please enter both numbers.", vbExclamation, "Input required"
GetInputs = False
Exit Function
End If
If Not IsNumeric([Link]) Then
MsgBox "Number 1 is not valid.", vbExclamation, "Invalid input"
[Link]
GetInputs = False
Exit Function
End If
If Not IsNumeric([Link]) Then
MsgBox "Number 2 is not valid.", vbExclamation, "Invalid input"
[Link]
GetInputs = False
Exit Function
End If
a = CDbl([Link])
b = CDbl([Link])
GetInputs = True
End Function
Private Sub cmdAdd_Click()
Dim a As Double, b As Double
If Not GetInputs(a, b) Then Exit Sub
[Link] = a + b
End Sub
Private Sub cmdSub_Click()
Dim a As Double, b As Double
If Not GetInputs(a, b) Then Exit Sub
[Link] = a - b
End Sub
Private Sub cmdMul_Click()
Dim a As Double, b As Double
If Not GetInputs(a, b) Then Exit Sub
[Link] = a * b
End Sub
Private Sub cmdDiv_Click()
Dim a As Double, b As Double
If Not GetInputs(a, b) Then Exit Sub
If b = 0 Then
MsgBox "Cannot divide by zero.", vbExclamation, "Math error"
Exit Sub
End If
[Link] = a / b
End Sub
Private Sub cmdClear_Click()
[Link] = ""
[Link] = ""
[Link] = ""
[Link]
End Sub
Private Sub cmdExit_Click()
Unload Me
End Sub
Output:
2. Design a form for speed control program using scroll bars.
Source Code:
Private Sub Form_Load()
' Use pixels so width/height values match the scroll values directly
[Link] = vbPixels
' Initialize scrollbars (these values should match the properties you set in the designer)
[Link] = 10
[Link] = 300
[Link] = 150
[Link] = 10
[Link] = 200
[Link] = 100
' Position shape (adjust if needed)
[Link] = 50
[Link] = 50
' Set initial shape size from scrollbars
[Link] = [Link]
[Link] = [Link]
' Show initial values in labels (optional)
[Link] = "Width: " & [Link]
[Link] = "Height: " & [Link]
End Sub
Private Sub HScroll1_Change()
' Update shape width and label when horizontal scrollbar is used
[Link] = [Link]
[Link] = "Width: " & [Link]
End Sub
Private Sub VScroll1_Change()
' Update shape height and label when vertical scrollbar is used
[Link] = [Link]
[Link] = "Height: " & [Link]
End Sub
Private Sub Command1_Click()
Unload Me
End Sub
Output:
3. Design a form to display a picture using image box/picture box selected from a file in
file list box directory list box, drive list box.
Source Code:
Option Explicit
' --- ResizeImageToFit: loads picture and fits it into Image1 keeping aspect ratio ---
Private Sub ResizeImageToFit(p As StdPicture)
On Error GoTo ErrHandler
Dim picWidthTwips As Long
Dim picHeightTwips As Long
Dim imgW As Long, imgH As Long
Dim scaleX As Double, scaleY As Double, scale As Double
Dim newWidthTwips As Long, newHeightTwips As Long
If p Is Nothing Then Exit Sub
' Picture sizes are in HIMETRIC/Twips depending on StdPicture; use .Width/.Height (twips).
picWidthTwips = [Link]
picHeightTwips = [Link]
' Convert Image1 client size (pixels) to twips:
imgW = [Link] ' ScaleWidth/ScaleHeight reflect the draw area in twips
imgH = [Link]
' Prevent divide by zero
If picWidthTwips <= 0 Or picHeightTwips <= 0 Then Exit Sub
scaleX = imgW / picWidthTwips
scaleY = imgH / picHeightTwips
' Use the smaller scale to keep whole picture visible
If scaleX < scaleY Then
scale = scaleX
Else
scale = scaleY
End If
newWidthTwips = CLng(picWidthTwips * scale)
newHeightTwips = CLng(picHeightTwips * scale)
ExitHere:
Exit Sub
ErrHandler:
MsgBox "Error resizing picture: " & [Link], vbExclamation, "Resize Error"
Resume ExitHere
End Sub
' --- Load picture from the selected file safely ---
Private Sub LoadSelectedPicture()
Dim fullPath As String
On Error GoTo LoadErr
If [Link] = "" Then
' Nothing selected
[Link] = Nothing
Exit Sub
End If
' Build full path ([Link] normally contains the directory)
fullPath = [Link]
If Right$(fullPath, 1) <> "\" Then fullPath = fullPath & "\"
fullPath = fullPath & [Link]
' Check file exists
If Dir$(fullPath) = "" Then
MsgBox "File not found: " & fullPath, vbExclamation, "File Not Found"
[Link] = Nothing
Exit Sub
End If
' Load the picture
Dim p As StdPicture
Set p = LoadPicture(fullPath)
If p Is Nothing Then
MsgBox "Could not load picture. Supported formats: BMP, JPG, GIF.", vbExclamation, "Load Failed"
[Link] = Nothing
Exit Sub
End If
Exit Sub
LoadErr:
MsgBox "Error loading image: " & [Link], vbExclamation, "Load Error"
[Link] = Nothing
End Sub
' --- Event: file selected or double-clicked ---
Private Sub File1_Click()
LoadSelectedPicture
End Sub
' Support double-click to open quickly
Private Sub File1_DblClick()
LoadSelectedPicture
End Sub
' --- Sync Dir list when Drive changes ---
Private Sub Drive1_Change()
On Error Resume Next
[Link] = [Link]
[Link] = [Link]
End Sub
' --- Sync File list when Dir changes ---
Private Sub Dir1_Change()
On Error Resume Next
[Link] = [Link]
End Sub
' --- Refresh button: re-read current directory listing and (re)load selection ---
Private Sub cmdRefresh_Click()
On Error Resume Next
[Link] = [Link]
[Link]
LoadSelectedPicture
End Sub
' --- Close button ---
Private Sub cmdClose_Click()
Unload Me
End Sub
' --- Form Load: initialize paths and UI ---
Private Sub Form_Load()
On Error Resume Next
' Optionally set a starting folder
' [Link] = "C:" ' uncomment to set initial drive
[Link] = [Link]
[Link] = [Link]
[Link] = Nothing
End Sub
Output:
4. Design a form using shape control to display signal and change it timely using timer
control.
Source Code:
Option Explicit
Dim myposition As String
Private Sub Form_Load()
' initial state
myposition = "stop"
[Link] = vbRed
[Link] = vbWhite
[Link] = vbWhite
[Link] = 10000
[Link] = False
End Sub
Private Sub Command1_Click() ' Start
myposition = "stop" ' ensure consistent starting state
[Link] = vbRed
[Link] = vbWhite
[Link] = vbWhite
[Link] = True
End Sub
Private Sub Command2_Click() ' Exit
End
End Sub
Private Sub Timer1_Timer()
Select Case myposition
Case "stop"
[Link] = vbWhite
[Link] = vbYellow
[Link] = vbWhite
myposition = "wait"
Case "wait"
[Link] = vbWhite
[Link] = vbWhite
[Link] = vbGreen
myposition = "go"
Case "go"
[Link] = vbRed
[Link] = vbWhite
[Link] = vbWhite
myposition = "stop"
End Select
End Sub
Output:
5. Design form to create a font dialog box using combo/ list, text, option buttons, and
check box control.
Source Code:
Private Sub Form_Load()
Dim i As Integer
' Populate ComboBox with available fonts using [Link]
' CORRECTED: [Link] requires an index parameter
For i = 0 To [Link] - 1
[Link] [Link](i)
Next i
' Set default selections
[Link] = [Link]
[Link] = True ' Default: Normal font
[Link] = 0 ' Default: Small size (0 = False)
End Sub
Private Sub Combo1_Click()
' Change TextBox font to selected font when ComboBox selection changes
[Link] = [Link]
End Sub
Private Sub Combo1_LostFocus()
' Also update font when ComboBox loses focus (in case user types manually)
[Link] = [Link]
End Sub
Private Sub Option1_Click()
' Make text bold
[Link] = True
[Link] = False
End Sub
Private Sub Option2_Click()
' Make text normal
[Link] = False
[Link] = False
End Sub
Private Sub Check1_Click()
' Change font size
If [Link] = 1 Then ' 1 = Checked, 0 = Unchecked
[Link] = 24
Else
[Link] = 12
End If
End Sub
Private Sub Command1_Click()
' Exit application
Unload Me
' Or: End
End Sub
Output:
6. Design a simple application using OLE control.
Source Code:
' Command button: exit the program
Private Sub Command1_Click()
End
End Sub
' Start the manual OLE drag when the user presses mouse on Text1
Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
' Start drag operation
[Link]
End Sub
' When the drag completes, show which effect was returned
Private Sub Text1_OLECompleteDrag(Effect As Long)
MsgBox "Returned OLE effect: " & Effect
End Sub
' Populate the DataObject when the drag starts
Private Sub Text1_OLEStartDrag(Data As DataObject, AllowedEffects As Long)
' Put the Text1 text into the DataObject as CF_TEXT
[Link] [Link], vbCFText
' Only allow Move effect (you can change to vbDropEffectCopy etc.)
AllowedEffects = vbDropEffectMove
End Sub
' When the target receives the drop, grab the data and put it in Text2
Private Sub Text2_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer,
X As Single, Y As Single)
On Error GoTo ErrHandler
' Retrieve text and set into Text2
[Link] = [Link](vbCFText)
Exit Sub
ErrHandler:
MsgBox "Drop failed: " & [Link], vbExclamation
End Sub
Output:
7. Design a form using Tab control, image list, status bar, tool bar which facilitates
different arithmetic operations.
Source Code:
Private Sub Form_Load()
[Link](1).Text = "Ready - Enter two numbers and select operation"
End Sub
Private Sub Command1_Click()
' Clear all textboxes
[Link] = ""
[Link] = ""
[Link] = ""
End Sub
Private Sub Toolbar1_ButtonClick(ByVal Button As [Link])
Dim msgpress As Integer
' Check if both fields have values
If [Link] = "" Or [Link] = "" Then
MsgBox "Please enter numbers in both fields!", vbExclamation
Exit Sub
End If
' Check if values are numbers
If Not IsNumeric([Link]) Or Not IsNumeric([Link]) Then
MsgBox "Please enter valid numbers only!", vbExclamation
Exit Sub
End If
Select Case [Link]
Case "ADD"
[Link] = CInt([Link]) + CInt([Link])
Case "SUB"
[Link] = CInt([Link]) - CInt([Link])
Case "MUL"
[Link] = CInt([Link]) * CInt([Link])
Case "DIV"
If CInt([Link]) = 0 Then
MsgBox "Cannot divide by zero!", vbExclamation
[Link] = "Error"
Else
[Link] = CInt([Link]) / CInt([Link])
End If
Case "EXIT"
Unload Me
End
End Select
' Update status bar
[Link](1).Text = "Result: " & [Link]
End Sub
Output:
8. Design a form using menu editor, MDI, common dialog box which has standard
format like Notepad. (Eg. File, Edit, format) open copy, font, save and cut.
Source Code:
For Child Form
Option Explicit
Public FileName As String
Public IsSaved As Boolean
Private Sub Form_Load()
FileName = ""
IsSaved = True
[Link] = "Untitled"
' Ensure textbox fills the client area on load
[Link] 0, 0, [Link], [Link]
End Sub
Private Sub Form_Resize()
On Error Resume Next
[Link] 0, 0, [Link], [Link]
End Sub
Private Sub txtEditor_Change()
IsSaved = False
UpdateCaption
End Sub
Public Sub UpdateCaption()
If FileName = "" Then
If IsSaved Then [Link] = "Untitled" Else [Link] = "Untitled*"
Else
If IsSaved Then [Link] = Dir(FileName) Else [Link] = Dir(FileName) & "*"
End If
End Sub
For Parent Form
Option Explicit
' Create a new child document and return reference
Private Function CreateNewChild() As frmChild
Dim f As New frmChild
' Show modeless — MDI parent will host it because [Link] = True at design time
[Link]
Set CreateNewChild = f
End Function
' File menu
Private Sub mnuFileNew_Click()
Dim ch As frmChild
Set ch = CreateNewChild()
[Link] = ""
[Link] = ""
[Link] = True
[Link]
End Sub
Private Sub mnuFileOpen_Click()
On Error GoTo OpenErr
[Link] = "Text files (*.txt)|*.txt|All files (*.*)|*.*"
[Link]
If [Link] = "" Then Exit Sub
Dim s As String, line As String
s = ""
Open [Link] For Input As #1
Do While Not EOF(1)
Line Input #1, line
s = s & line & vbCrLf
Loop
Close #1
Dim ch As frmChild
Set ch = CreateNewChild()
[Link] = s
[Link] = [Link]
[Link] = True
[Link]
Exit Sub
OpenErr:
If [Link] <> 32755 Then MsgBox "Open error: " & [Link], vbExclamation
[Link]
End Sub
Private Sub mnuFileSave_Click()
If Not TypeOf [Link] Is frmChild Then Exit Sub
Dim ch As frmChild
Set ch = [Link]
If [Link] = "" Then
mnuFileSaveAs_Click
Else
SaveChildToFile ch, [Link]
End If
End Sub
Private Sub mnuFileSaveAs_Click()
If Not TypeOf [Link] Is frmChild Then Exit Sub
Dim ch As frmChild
Set ch = [Link]
On Error GoTo SaveErr
[Link] = "Text files (*.txt)|*.txt|All files (*.*)|*.*"
[Link]
If [Link] = "" Then Exit Sub
SaveChildToFile ch, [Link]
[Link] = [Link]
[Link] = True
[Link]
Exit Sub
SaveErr:
If [Link] <> 32755 Then MsgBox "Save error: " & [Link], vbExclamation
[Link]
End Sub
Private Sub SaveChildToFile(ch As frmChild, fname As String)
On Error GoTo SErr
Open fname For Output As #1
' Use semicolon in print to avoid extra blank line
Print #1, [Link];
Close #1
[Link] = True
[Link]
Exit Sub
SErr:
MsgBox "Could not save file: " & [Link], vbExclamation
[Link]
End Sub
Private Sub mnuFileExit_Click()
Unload Me
End Sub
' Edit menu
Private Sub mnuEditCut_Click()
If Not TypeOf [Link] Is frmChild Then Exit Sub
Dim ch As frmChild: Set ch = [Link]
If Len([Link]) > 0 Then
[Link] [Link]
[Link] = ""
End If
End Sub
Private Sub mnuEditCopy_Click()
If Not TypeOf [Link] Is frmChild Then Exit Sub
Dim ch As frmChild: Set ch = [Link]
If Len([Link]) > 0 Then
[Link] [Link]
End If
End Sub
Private Sub mnuEditPaste_Click()
If Not TypeOf [Link] Is frmChild Then Exit Sub
Dim ch As frmChild: Set ch = [Link]
On Error Resume Next
[Link] = [Link]()
End Sub
Private Sub mnuEditSelectAll_Click()
If Not TypeOf [Link] Is frmChild Then Exit Sub
With [Link]
.SelStart = 0
.SelLength = Len(.Text)
End With
End Sub
' Format menu
Private Sub mnuFormatFont_Click()
If Not TypeOf [Link] Is frmChild Then Exit Sub
On Error GoTo FontErr
[Link]
With [Link]
.Name = [Link]
.Size = [Link]
.Bold = [Link]
.Italic = [Link]
.Underline = [Link]
End With
Exit Sub
FontErr:
If [Link] <> 32755 Then MsgBox "Font dialog error: " & [Link], vbExclamation
[Link]
End Sub
Output:
9. Design a simple database application which covers all database concepts. (Data
control, DAO, RDO, ADO, DB-list, DB combo), Create property pages without using
the property page wizard.
Source Code:
Option Explicit
' Database connection variables
Dim Cn As New [Link]
Dim rs As New [Link]
Dim strSql As String
Dim dbPath As String
' Form Load Event
Private Sub Form_Load()
' Initialize controls
InitializeControls
dbPath = [Link] & "\[Link]"
End Sub
' Initialize all controls
Private Sub InitializeControls()
' Hide controls initially
[Link] = False
[Link] = False
[Link] = False
[Link] = False
[Link] = False
[Link] = False
[Link] = False
[Link] = False
' Disable buttons until database is created
[Link] = False
[Link] = False
[Link] = False
[Link] = False
[Link] = False
[Link] = False
' Remove the read-only property assignments
' Set these properties in design time instead
End Sub
' Setup ADO Data Control
Private Sub SetupADODC()
With Adodc1
.ConnectionString = "Provider=[Link].4.0;Data Source=" & dbPath
.CommandType = adCmdText
.RecordSource = "SELECT * FROM Customers"
.Refresh
End With
' Bind textboxes to ADODC
[Link] = "CustomerID"
[Link] = "CompanyName"
[Link] = "ContactName"
[Link] = "Country"
Set [Link] = Adodc1
Set [Link] = Adodc1
Set [Link] = Adodc1
Set [Link] = Adodc1
End Sub
' Setup Data Bound Controls
Private Sub SetupDataBoundControls()
' Setup DBCombo - Company Names
With DBCombo1
Set .RowSource = Adodc1
.ListField = "CompanyName"
.BoundColumn = "CustomerID"
.Text = "Select Company..."
End With
' Setup DBList - Customer IDs
With DBList1
Set .RowSource = Adodc1
.ListField = "CustomerID"
.BoundColumn = "CustomerID"
End With
End Sub
' Print ADO Records
Private Function PrintADO()
On Error GoTo ErrorHandler
If rs Is Nothing Then Exit Function
If [Link] <> adStateOpen Then Exit Function
If Not [Link] And Not [Link] Then
[Link] = "ID: " & rs!CustomerID & vbCrLf & _
"Company: " & rs!CompanyName & vbCrLf & _
"Contact: " & rs!ContactName & vbCrLf & _
"Country: " & rs!Country & vbCrLf & _
"City: " & rs!City
[Link]
If [Link] Then
[Link]
End If
Else
[Link] = "No records found"
End If
Exit Function
ErrorHandler:
MsgBox "Error reading record: " & [Link], vbCritical
End Function
' BUTTON CLICK EVENTS
Private Sub cmdCreateDB_Click()
CreateDatabase
End Sub
Private Sub cmdShowADO_Click()
[Link] = True
If [Link] = adStateOpen Then
PrintADO
Else
[Link] = "Please create database first"
End If
End Sub
Private Sub cmdShowADODC_Click()
[Link] = True
[Link] = True
[Link] = True
[Link] = True
[Link] = True
[Link] = True
[Link] = True
[Link] = True
End Sub
Private Sub cmdNextRecord_Click()
PrintADO
End Sub
Private Sub cmdOrderCountry_Click()
[Link] = "SELECT * FROM Customers ORDER BY Country, CompanyName"
[Link]
MsgBox "Ordered by Country", vbInformation
End Sub
Private Sub cmdOrderCity_Click()
[Link] = "SELECT * FROM Customers ORDER BY City, CompanyName"
[Link]
MsgBox "Ordered by City", vbInformation
End Sub
Private Sub cmdResetOrder_Click()
[Link] = "SELECT * FROM Customers ORDER BY CustomerID"
[Link]
MsgBox "Order reset to Customer ID", vbInformation
End Sub
' DATA BOUND CONTROL EVENTS
Private Sub DBCombo1_Change()
If [Link] <> "" Then
[Link] = "SELECT * FROM Customers WHERE CustomerID = '" &
[Link] & "'"
[Link]
End If
End Sub
Private Sub DBList1_Click()
If [Link] <> "" Then
[Link] = "SELECT * FROM Customers WHERE CustomerID = '" &
[Link] & "'"
[Link]
End If
End Sub
' Clean up on form close
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
If Not rs Is Nothing Then
If [Link] = adStateOpen Then [Link]
End If
If Not Cn Is Nothing Then
If [Link] = adStateOpen Then [Link]
End If
Set rs = Nothing
Set Cn = Nothing
End Sub
Output: