CSedukit.com

MENU EDITOR

noreply@blogger.com (Anoop) — Mon, 14 Jun 2010 05:09:00 -0700

AIM:To create a menu editor

                       
   CODE

Form1
Dim s As String
Private Sub color_Click()
CommonDialog1.ShowColor
rtb1.SelColor = CommonDialog1.color
End Sub
Private Sub copy_Click()
s = rtb1.SelText
End Sub
Private Sub cut_Click()
s = rtb1.SelText
rtb1.SelText = ""
End Sub
Private Sub edit_Click(Index As Integer)
If (rtb1.SelLength = 0) Then
copy.Enabled = False
cut.Enabled = False
Else
copy.Enabled = True
cut.Enabled = True
End If
If Clipboard.GetText = "" Then
paste.Enabled = False
Else
paste.Enabled = True
End If
End Sub
Private Sub exit_Click()
End
End Sub
Private Sub font_Click()
CommonDialog1.ShowFont
rtb1.SelFontName = CommonDialog1.FontName
rtb1.SelBold = CommonDialog1.FontBold
rtb1.SelItalic = CommonDialog1.FontItalic
rtb1.SelUnderline = CommonDialog1.FontUnderline
rtb1.SelStrikeThru = CommonDialog1.FontStrikethru
rtb1.SelFontSize = CommonDialog1.FontSize
End Sub
Private Sub mnunew_Click()
rtb1 = ""
End Sub
Private Sub open_Click()
CommonDialog1.ShowOpen
rtb1.LoadFile (CommonDialog1.FileName)
End Sub
Private Sub paste_Click()
rtb1.Text = rtb1.Text & s
End Sub
Private Sub save_Click()
CommonDialog1.ShowSave
rtb1.SaveFile (CommonDialog1.FileName)
End Sub



STUDENT INFORMATION SYSTEM
noreply@blogger.com (Anoop) — Mon, 14 Jun 2010 05:06:00 -0700

AIM:To prepare a form for students information using data control
                 
   CODE

Form 1
Private Sub ADD_Click(Index As Integer)
DATA.Recordset.AddNew
End Sub
Private Sub DELETE_Click(Index As Integer)
On Error Resume Next
DATA.Recordset.DELETE
If Not DATA.Recordset.EOF Then
DATA.Recordset.MoveNext
Else
If Not DATA.Recordset.BOF Then
DATA.Recordset.MovePrevious
Else
MsgBox "THIS WAS THE LAST RECORD IN THE TABLE"
End If
End If
End Sub
Private Sub EXIT_Click(Index As Integer)
End
End Sub
Private Sub FIND_Click(Index As Integer)
Dim NAME As String
NAME = InputBox("ENTER THE NAME TO SEARCH", "SEARCH FOR ")
DATA.Recordset.Index = "NAME"
DATA.Recordset.Seek "=", NAME
End Sub
                                         59
Private Sub FIRST_Click(Index As Integer)
DATA.Recordset.MoveFirst
End Sub
Private Sub LAST_Click(Index As Integer)
DATA.Recordset.MoveLast
End Sub
Private Sub NEXT_Click(Index As Integer)
DATA.Recordset.MoveNext
If DATA.Recordset.EOF Then
MsgBox "YOU ARE ON THE LAST RECORD"
DATA.Recordset.MoveLast
End If
End Sub
Private Sub PREV_Click(Index As Integer)
DATA.Recordset.MovePrevious
If DATA.Recordset.BOF Then
MsgBox "YOU ARE ON THE FIRST RECORD"
DATA.Recordset.MoveFirst
End If
End Sub





STUDENT INFORMATION SYSTEM
noreply@blogger.com (Anoop) — Mon, 14 Jun 2010 05:06:00 -0700

AIM:To prepare a form for students information using data control
                 
   CODE

Form 1
Private Sub ADD_Click(Index As Integer)
DATA.Recordset.AddNew
End Sub
Private Sub DELETE_Click(Index As Integer)
On Error Resume Next
DATA.Recordset.DELETE
If Not DATA.Recordset.EOF Then
DATA.Recordset.MoveNext
Else
If Not DATA.Recordset.BOF Then
DATA.Recordset.MovePrevious
Else
MsgBox "THIS WAS THE LAST RECORD IN THE TABLE"
End If
End If
End Sub
Private Sub EXIT_Click(Index As Integer)
End
End Sub
Private Sub FIND_Click(Index As Integer)
Dim NAME As String
NAME = InputBox("ENTER THE NAME TO SEARCH", "SEARCH FOR ")
DATA.Recordset.Index = "NAME"
DATA.Recordset.Seek "=", NAME
End Sub
                                         59
Private Sub FIRST_Click(Index As Integer)
DATA.Recordset.MoveFirst
End Sub
Private Sub LAST_Click(Index As Integer)
DATA.Recordset.MoveLast
End Sub
Private Sub NEXT_Click(Index As Integer)
DATA.Recordset.MoveNext
If DATA.Recordset.EOF Then
MsgBox "YOU ARE ON THE LAST RECORD"
DATA.Recordset.MoveLast
End If
End Sub
Private Sub PREV_Click(Index As Integer)
DATA.Recordset.MovePrevious
If DATA.Recordset.BOF Then
MsgBox "YOU ARE ON THE FIRST RECORD"
DATA.Recordset.MoveFirst
End If
End Sub





FONT DIALOG BOX
noreply@blogger.com (Anoop) — Mon, 14 Jun 2010 05:05:00 -0700

Aim: To stimulate a Font dialog box
                          
  CODE

Form1
Private Sub cmdfont_Click()
CommonDialog1.ShowFont
With lblfont.Font
.Name = CommonDialog1.FontName
.Bold = CommonDialog1.FontBold
.Size = CommonDialog1.FontSize
.Underline = CommonDialog1.FontUnderline
End With
End Sub
Private Sub cmdstop_Click()
End
End Sub




NUMERIC CONVERSIONS
noreply@blogger.com (Anoop) — Mon, 14 Jun 2010 05:03:00 -0700
AIM:To prepare a form for binary,decimal and octal conversions

                           CODE

Form 1
Private Sub Command1_Click()
Dim dec As Integer, d As Integer, i As Integer
Dim b As Long
dec = 0
i=0
b = Val(Text1.Text)
While (b > 0)
d = b Mod 10
dec = dec + d * 2 ^ i
i=i+1
b = b / 10
Wend
Text2.Text = dec
End Sub
Private Sub Command2_Click()
Dim n, a, i As Integer
Dim b(100) As Integer
n = Val(Text2.Text)
While (n <> 0)
b(i) = n Mod 2
n=n/2
i=i+1
Wend
For i = i - 1 To 0 Step -1
Text1.Text = Text1.Text & b(i)
Next
End Sub
Private Sub Command3_Click()
Dim oct, o, i As Integer
Dim b As Long
oct = 0
i=0
b = Val(Text1.Text)
While (b > 0)
o = b Mod 10
oct = oct + o * 8 ^ i
i=i+1
b = b / 10
Wend
Text3.Text = oct
End Sub
Private Sub Command4_Click()
Text1.Text = ""
Text2.Text = ""
Text3.Text = ""
End Sub
Private Sub Command5_Click()
End
End Sub




ONLINE QUIZ PROGRAM
noreply@blogger.com (Anoop) — Mon, 14 Jun 2010 04:53:00 -0700
                        
AIM:To prepare an online quiz program
         
PROCEDURE
                    Select add-ins
                    ->Visual data manager
                    ->file
                    ->new
                    ->Microsoft Access
                    ->Version.7.7. MDB

         QUIZ TABLE
         SLNO                       FIELDS  DATATYPE
           1                         QNO      LONG
           2                      QUESTION    TEXT
           3                      OPTION 1    TEXT
           4                      OPTION 2    TEXT
           5                      OPTION 3    TEXT
           6                      OPTION 4    TEXT
           7                         ANS      TEXT
                                   

CODE

Form 1
Private Sub examination_Click()
Form3.Show
End Sub
Private Sub question_Click()
Form2.Show
End Sub
Private Sub quit_Click()
End
End Sub

Form 2
Private Sub Command1_Click()
Data.Recordset.AddNew
With Data.Recordset
.Fields("qno") = Text1.Text
.Fields("question") = Text2.Text
.Fields("option1") = Text4.Text
.Fields("option2") = Text5.Text
.Fields("option3") = Text6.Text
.Fields("option4") = Text7.Text
.Fields("ans") = Text3.Text
End With
Data.Recordset.Update
End Sub
Private Sub Command2_Click()
Data.Recordset.Delete
Data.Recordset.MoveNext
End Sub
Private Sub Command3_Click()
Text1.Text = ""
Text2.Text = ""
Text4.Text = ""
Text5.Text = ""
Text6.Text = ""
Text7.Text = ""
End Sub
Private Sub Command4_Click()
Form1.Show
End Sub
Form 3
Dim a As Integer, answer As String, mark As Integer
Private Sub Command1_Click()
Form1.Show
End Sub
Private Sub Option1_Click(Index As Integer)
answer = Option1(Index).Caption
If answer = Data.Recordset.Fields("answer") Then
label4.Caption = "right answer"
mark = mark + 1
Else
label4.Caption = "wrong answer"
End If
End Sub
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
Option1(1).Value = False
Option2(2).Value = False
Option3(3).Value = False
Option4(4).Value = False
label4.Caption = ""
a = Text1.Text
Data.Refresh
Data.Recordset.MoveFirst
With Data.Recordset
While Not .EOF
If a = .Fields("qno") Then
Label2.Caption = .Fields("qno")
Label3.Caption = .Fields("question")
Option1(1).Caption = .Fields("option1")
Option2(2).Caption = .Fields("option2")
Option3(3).Caption = .Fields("option3")
Option4(4).Caption = .Fields("option4")
Exit Sub
Else
.MoveNext
End If
End Sub








SLIDER CONTROL
noreply@blogger.com (Anoop) — Mon, 14 Jun 2010 04:50:00 -0700
AIM:To prepare a form for using slider control
                            
     CODE

Form 1
Private Sub Form_Load()
RED.Min = 0
RED.Max = 250
RED.SmallChange = 1
RED.LargeChange = 25
RED.TickFrequency = 25
RED.Value = 0
GREEN.Min = 0
GREEN.Max = 250
GREEN.SmallChange = 1
GREEN.LargeChange = 25
GREEN.TickFrequency = 25
GREEN.Value = 0
BLUE.Min = 0
BLUE.Max = 250
BLUE.SmallChange = 1
BLUE.LargeChange = 25
BLUE.TickFrequency = 25
BLUE.Value = 0
colour.BackColor = RGB(RED.Value, GREEN.Value, BLUE.Value)
colour.Caption = Chr(10) & Chr(10) & "red=" & RED.Value & Chr(10) &
"green=" & GREEN.Value & Chr(10) & "blue=" & BLUE.Value
End Sub
Private Sub GREEN_Change()
colour.BackColor = RGB(RED.Value, GREEN.Value, BLUE.Value)
colour.Caption = Chr(10) & Chr(10) & "red=" & RED.Value & Chr(10) &
"green=" & GREEN.Value & Chr(10) & "blue=" & BLUE.Value
End Sub
                                                             
Private Sub GREEN_Scroll()
colour.BackColor = RGB(RED.Value, GREEN.Value, BLUE.Value)
colour.Caption = Chr(10) & Chr(10) & "red=" & RED.Value & Chr(10) &
"green=" & GREEN.Value & Chr(10) & "blue=" & BLUE.Value
End Sub
Private Sub RED_Change()
colour.BackColor = RGB(RED.Value, GREEN.Value, BLUE.Value)
colour.Caption = Chr(10) & Chr(10) & "red=" & RED.Value & Chr(10) &
"green=" & GREEN.Value & Chr(10) & "blue=" & BLUE.Value
End Sub
Private Sub RED_Scroll()
colour.BackColor = RGB(RED.Value, GREEN.Value, BLUE.Value)
colour.Caption = Chr(10) & Chr(10) & "red=" & RED.Value & Chr(10) &
"green=" & GREEN.Value & Chr(10) & "blue=" & BLUE.Value
End Sub
Private Sub BLUE_Change()
colour.BackColor = RGB(RED.Value, GREEN.Value, BLUE.Value)
colour.Caption = Chr(10) & Chr(10) & "red=" & RED.Value & Chr(10) &
"green=" & GREEN.Value & Chr(10) & "blue=" & BLUE.Value
End Sub
Private Sub BLUE_Scroll()
colour.BackColor = RGB(RED.Value, GREEN.Value, BLUE.Value)
colour.Caption = Chr(10) & Chr(10) & "red=" & RED.Value & Chr(10) &
"green=" & GREEN.Value & Chr(10) & "blue=" & BLUE.Value
End Sub





OLE CONTROL
noreply@blogger.com (Anoop) — Mon, 14 Jun 2010 04:37:00 -0700
AIM:To prepare a form for using OLE control
                           CODE
Form 1
Private Sub OPEN_Click()
Dim fnum As Integer
On Error GoTo cancel
CommonDialog1.ShowOpen
fnum = FreeFile
Open CommonDialog1.FileName For Binary As #fnum
OLE1.ReadFromFile (fnum)
Close #fnum
Exit Sub
cancel:
MsgBox "could not load file"
Close #fnum
End Sub
Private Sub SAVE_Click()
Dim fnum As Integer
On Error GoTo cancel
fnum = FreeFile
CommonDialog1.ShowSave
Open CommonDialog1.FileName For Binary As #fnum
OLE1.SaveToFile (fnum)
Close #fnum
Exit Sub
cancel:
MsgBox "could not save file"
Close #fnum
End Sub
Private Sub EXIT_Click()
End
End Sub

Private Sub mnuExit_Click(Index As Integer)
End
End Sub
Private Sub mnuOPen_Click(Index As Integer)
Dim fnum As Integer
On Error GoTo cancel
CommonDialog1.ShowOpen
fnum = FreeFile
Open CommonDialog1.FileName For Binary As #fnum
OLE1.ReadFromFile (fnum)
Close #fnum
Exit Sub
cancel:
MsgBox "could not load file" + Err.Description
Close #fnum
End Sub
Private Sub mnuSave_Click(Index As Integer)
Dim fnum As Integer
On Error GoTo cancel
fnum = FreeFile
CommonDialog1.ShowSave
Open CommonDialog1.FileName For Binary As #fnum
OLE1.SaveToFile (fnum)
Close #fnum
Exit Sub
cancel:
MsgBox "could not save file"
Close #fnum
End Sub




PICTURE VIEWER
noreply@blogger.com (Anoop) — Mon, 14 Jun 2010 04:34:00 -0700
AIM:To prepare a form for picture viewer
                  
            CODE

Form 1
Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub
Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End Sub
Private Sub File1_Click()
Dim temp As String
temp = Dir1.Path
If Right(temp, 1) = "\" Then
Picture1.Picture = LoadPicture(Dir1.Path & File1.FileName)
Else
Picture1.Picture = LoadPicture(Dir1.Path & File1.FileName)
End If
End Sub





NUMBER APPLICATION
noreply@blogger.com (Anoop) — Mon, 14 Jun 2010 04:31:00 -0700
AIM:To display whole,even,odd,prime and Fibonacci numbers upto a limit
                              

CODE

Form 1
Dim num As Long, temp As String
Private Sub clear_Click()
display.Text = ""
End Sub
Private Sub even_Click()
display.Text = ""
temp = ""
If limit.Text = "" Then
MsgBox "please enter a number"
Exit Sub
End If
For num = 2 To CLng(limit.Text) Step 2
temp = temp & Str(num)
Next num
display.Text = temp
End Sub
Private Sub exit_Click()
End
End Sub
Private Sub fibonacci_Click()
Dim a, b, c As Long, temp As String
display.Text = ""
temp = ""
a = 1: b = 0
If limit.Text = "" Then
MsgBox "please enter a number"
Exit Sub
End If

For num = 1 To CLng(limit.Text)
c=a+b
a=b
b=c
If c >= CLng(limit.Text) Then Exit For
temp = temp & Str(c)
Next num
display.Text = temp
End Sub
Private Sub odd_Click()
Dim num As Long, temp As String
display.Text = ""
temp = ""
If limit.Text = "" Then
MsgBox "please enter a number"
Exit Sub
End If
For num = 1 To CLng(limit.Text) Step 2
temp = temp & Str(num)
Next num
display.Text = temp
End Sub
Private Sub prime_Click()
Dim i, j As Long, temp As String, flag As Boolean
display.Text = ""
temp = ""
If limit.Text = "" Then
MsgBox "please enter a number "
Exit Sub
End If

For i = 2 To CLng(limit.Text)
flag = True
For j = 2 To Sqr(i)
If i Mod j = 0 Then
flag = False
Exit For
End If
Next j
If flag Then temp = temp & Str(i)
Next i
display.Text = temp
End Sub
Private Sub whole_Click()
Dim num As Long, temp As String
display.Text = ""
temp = ""
If limit.Text = "" Then
MsgBox "please enter a number"
Exit Sub
End If
For num = 1 To CLng(limit.Text)
temp = temp & Str(num)
Next num
display.Text = temp
End Sub





FILE APPLICATION
noreply@blogger.com (Anoop) — Mon, 14 Jun 2010 04:27:00 -0700
AIM: To create a file and to perform write and read operations
     
                            

   CODE

Form 1
Private Sub Clear_Click()
Content.Text = ""
Content.SetFocus
End Sub
Private Sub Exit_Click()
End
End Sub
Private Sub Readfromfile_Click()
Dim Strg As String, fNum As Integer
On Error GoTo label
fNum = FreeFile()
Open "E:\vbhas\Sample.txt" For Input As #fNum
While Not EOF(fNum)
Line Input #fNum, Strg
Content.Text = Content.Text & Strg
Wend
Close #fNum
Content.SetFocus
Exit Sub
label:
MsgBox "Error............" & vbCrLf & Err.Description
End Sub
                                                       33
Private Sub Writetofile_Click()
Dim i As Integer, fNum As Integer
On Error GoTo label
fNum = FreeFile()
Open "E:\vbhas\Sample.txt" For Output As fNum
Print #fNum, Content.Text
Content.SetFocus
Close #fNum
Exit Sub
label:
MsgBox "Error............." & vbCrLf & Err.Description
End Sub



  


SCROLL BAR APPLICATION
noreply@blogger.com (Anoop) — Mon, 14 Jun 2010 04:25:00 -0700
AIM:To create a form showing scrollbar properties
                                     

CODE

Form 1
Private Sub Form_Load()
redScroll.Min = 0
redScroll.Max = 255
redScroll.SmallChange = 1
redScroll.LargeChange = 25
redScroll.Value = 10
greenscroll.Min = 0
greenscroll.Max = 255
greenscroll.SmallChange = 1
greenscroll.LargeChange = 25
greenscroll.Value = 100
bluescroll.Min = 0
bluescroll.Max = 255
bluescroll.SmallChange = 1
bluescroll.LargeChange = 25
bluescroll.Value = 0
redlabel.BackColor = RGB(255, 0, 0)
greenlabel.BackColor = RGB(0, 255, 0)
bluelabel.BackColor = RGB(0, 0, 255)
scrolllabel.Caption = Chr(10) & Chr(10) & Chr(10) & "red=" &
redScroll.Value & Chr(10) & "green=" & greenscroll.Value & Chr(10) &
"blue=" & bluescroll.Value
scrolllabel.BackColor = RGB(redScroll.Value, greenscroll.Value,
bluescroll.Value)
changelabel.Caption = Chr(10) & Chr(10) & Chr(10) & "red=" &
redScroll.Value & Chr(10) & "green=" & greenscroll.Value & Chr(10) &
"blue=" & bluescroll.Value
changelabel.BackColor = RGB(redScroll.Value, greenscroll.Value,
bluescroll.Value)
End Sub
Private Sub greenscroll_Change()

changelabel.Caption = Chr(10) & Chr(10) & Chr(10) & "red=" &
redScroll.Value & Chr(10) & "green=" & greenscroll.Value & Chr(10) &
"blue=" & bluescroll.Value
changelabel.BackColor = RGB(redScroll.Value, greenscroll.Value,
bluescroll.Value)
scrolllabel.Caption = Chr(10) & Chr(10) & Chr(10) & "red=" &
redScroll.Value & Chr(10) & "green=" & greenscroll.Value & Chr(10) &
"blue=" & bluescroll.Value
scrolllabel.BackColor = RGB(redScroll.Value, greenscroll.Value,
bluescroll.Value)
End Sub
Private Sub greenscroll_Scroll()
scrolllabel.Caption = Chr(10) & Chr(10) & Chr(10) & "red=" &
redScroll.Value & Chr(10) & "green=" & greenscroll.Value & Chr(10) &
"blue=" & bluescroll.Value
scrolllabel.BackColor = RGB(redScroll.Value, greenscroll.Value,
bluescroll.Value)
End Sub
Private Sub redScroll_Change()
changelabel.Caption = Chr(10) & Chr(10) & Chr(10) & "red=" &
redScroll.Value & Chr(10) & "green=" & greenscroll.Value & Chr(10) &
"blue=" & bluescroll.Value
changelabel.BackColor = RGB(redScroll.Value, greenscroll.Value,
bluescroll.Value)
scrolllabel.Caption = Chr(10) & Chr(10) & Chr(10) & "red=" &
redScroll.Value & Chr(10) & "green=" & greenscroll.Value & Chr(10) &
"blue=" & bluescroll.Value
scrolllabel.BackColor = RGB(redScroll.Value, greenscroll.Value,
bluescroll.Value)
End Sub
Private Sub redScroll_Scroll()
scrolllabel.Caption = Chr(10) & Chr(10) & Chr(10) & "red=" &
redScroll.Value & Chr(10) & "green=" & greenscroll.Value & Chr(10) &
"blue=" & bluescroll.Value
scrolllabel.BackColor = RGB(redScroll.Value, greenscroll.Value,
bluescroll.Value)
End Sub






STANDARD CALCULATOR
noreply@blogger.com (Anoop) — Mon, 14 Jun 2010 04:22:00 -0700
AIM: To create a standard calculator
                          

         CODE

Form 1
Option Explicit
Dim res As Double, cleardisp As Boolean, first As Boolean
Dim operation As String, mem As Double
Private Sub Backspace_Click()
If lbldisplay.Caption <> "" Then
lbldisplay.Caption = Mid(lbldisplay.Caption, 1, Len(lbldisplay.Caption) - 1)
End If
End Sub
Private Sub ce_Click()
lbldisplay.Caption = "0"
first = True
End Sub
Private Sub digit_Click(index As Integer)
On Error GoTo error
If cleardisp Then
lbldisplay.Caption = ""
cleardisp = False
End If
lbldisplay.Caption = lbldisplay.Caption & digit(index).Caption
Exit Sub
error:
lbldisplay.Caption = "error!" & Err.Description
End Sub
                                               
Private Sub equal_Click()
On Error GoTo error
Select Case operation
Case "+"
res = Str(res + Val(lbldisplay.Caption))
Case "-"
res = Str(res - Val(lbldisplay.Caption))
Case "*"
res = Str(res * Val(lbldisplay.Caption))
Case "/"
res = Str(res / Val(lbldisplay.Caption))
End Select
lbldisplay.Caption = Str(res)
first = True
Exit Sub
error:
lbldisplay.Caption = "error!" & Err.Description
End Sub
Private Sub Form_Load()
cleardisp = True
first = True
lbldisplay.Caption = "0"
End Sub
Private Sub off_Click()
End
End Sub
Private Sub operator_Click(index As Integer)
On Error GoTo error
If first Then
res = lbldisplay.Caption
operation = operator(index).Caption
cleardisp = True
first = False
Exit Sub
End If
                                  
Select Case operation
Case "+"
res = Str(res + Val(lbldisplay.Caption))
Case "-"
res = Str(res - Val(lbldisplay.Caption))
Case "*"
res = Str(res * Val(lbldisplay.Caption))
Case "/"
res = Str(res / Val(lbldisplay.Caption))
End Select
operation = operator(index).Caption
lbldisplay.Caption = Str(res)
cleardisp = True
Exit Sub
error:
lbldisplay.Caption = "error!" & Err.Description
End Sub
Private Sub PLUS_MINUS_Click()
On Error GoTo error
lbldisplay.Caption = Str(-1 * Val(lbldisplay.Caption))
first = True
cleardisp = True
Exit Sub
error:
lbldisplay.Caption = "error......!!" & Err.Description
End Sub
Private Sub sqrt_Click()
lbldisplay.Caption = Sqr(lbldisplay.Caption)
first = True
cleardisp = True
End Sub





LISTBOX SORTING
noreply@blogger.com (Anoop) — Mon, 14 Jun 2010 04:20:00 -0700
AIM:To sort a list of items using listbox
                                      

CODE

Form1
Private Sub Add1_Click()
Dim listitem As String
listitem = InputBox("Enter item to add to the list")
If Trim(listitem) <> "" Then
List1.AddItem listitem
End If
End Sub
Private Sub Add2_Click()
Dim listitem As String
listitem = InputBox("Enter item to add to the list")
If Trim(listitem) <> "" Then
List2.AddItem listitrem
End If
End Sub
Private Sub Backward_Click()
Dim i As Integer
For i = List2.ListCount - 1 To 0 Step -1
If List2.Selected(i) Then
List1.AddItem List2.List(i)
List2.RemoveItem i
End If
Next i
End Sub
Private Sub Clear1_Click()
List1.Clear
End Sub
Private Sub Forward_Click()
Dim i As Integer
For i = List1.ListCount - 1 To 0 Step -1
If List1.Selected(i) Then
List2.AddItem List1.List(i)
List1.RemoveItem i
End If
Next i
End Sub
Private Sub Remove1_Click()
Dim i As Integer
For i = List1.ListCount - 1 To 0 Step -1
If List1.Selected(i) Then
List1.RemoveItem i
End If
Next i
End Sub
Private Sub SelectAll1_Click()
Dim i As Integer
For i = List1.ListCount - 1 To 0 Step -1
List1.Selected(i) = True
Next i
End Sub
Private Sub SelectAll2_Click()
Dim i As Integer
For i = List2.ListCount - 1 To 0 Step -1
List2.Selected(i) = True
Next i
End Sub






COLOUR BOX USING COMBOX
noreply@blogger.com (Anoop) — Mon, 14 Jun 2010 04:17:00 -0700
AIM:To Display colours using combo box
                                
   CODE

Form 1
Dim i As Integer
Private Sub blue_Change()
colour.BackColor = RGB(Val(red.Text), Val(green.Text), Val(blue.Text))
colour.Caption = Chr(10) & Chr(10) & Chr(10) & Chr(10) & Chr(10) & "red="
& red.Text & Chr(10) & "green=" & green.Text & Chr(10) & "blue=" &
blue.Text
End Sub
Private Sub blue_Click()
colour.BackColor = RGB(Val(red.Text), Val(green.Text), Val(blue.Text))
colour.Caption = Chr(10) & Chr(10) & Chr(10) & Chr(10) & Chr(10) & "red="
& red.Text & Chr(10) & "green=" & green.Text & Chr(10) & "blue=" &
blue.Text
End Sub
Private Sub Form_Load()
For i = 0 To 255 Step 10
red.AddItem i
Next i
red.ListIndex = 1
For i = 0 To 255 Step 10
green.AddItem i
Next i
green.ListIndex = 1
For i = 0 To 255 Step 10
blue.AddItem i
Next i

blue.ListIndex = 1
redlabel.BackColor = RGB(255, 0, 0)
greenlabel.BackColor = RGB(0, 255, 0)
bluelabel.BackColor = RGB(0, 0, 255)
colour.BackColor = RGB(Val(red.Text), Val(green.Text), Val(blue.Text))
colour.Caption = Chr(10) & Chr(10) & Chr(10) & Chr(10) & Chr(10) & "red="
& red.Text & Chr(10) & "green=" & green.Text & Chr(10) & "blue=" &
blue.Text
End Sub
Private Sub green_Change()
colour.BackColor = RGB(Val(red.Text), Val(green.Text), Val(blue.Text))
colour.Caption = Chr(10) & Chr(10) & Chr(10) & Chr(10) & Chr(10) & "red="
& red.Text & Chr(10) & "green=" & green.Text & Chr(10) & "blue=" &
blue.Text
End Sub
Private Sub green_Click()
colour.BackColor = RGB(Val(red.Text), Val(green.Text), Val(blue.Text))
colour.Caption = Chr(10) & Chr(10) & Chr(10) & Chr(10) & Chr(10) & "red="
& red.Text & Chr(10) & "green=" & green.Text & Chr(10) & "blue=" &
blue.Text
End Sub
Private Sub red_Change()
colour.BackColor = RGB(Val(red.Text), Val(green.Text), Val(blue.Text))
colour.Caption = Chr(10) & Chr(10) & Chr(10) & Chr(10) & Chr(10) & "red="
& red.Text & Chr(10) & "green=" & green.Text & Chr(10) & "blue=" &
blue.Text
End Sub
Private Sub red_Click()
colour.BackColor = RGB(Val(red.Text), Val(green.Text), Val(blue.Text))
colour.Caption = Chr(10) & Chr(10) & Chr(10) & Chr(10) & Chr(10) & "red="
& red.Text & Chr(10) & "green=" & green.Text & Chr(10) & "blue=" &
blue.Text
End Sub





CHECK BOX
noreply@blogger.com (Anoop) — Mon, 14 Jun 2010 04:13:00 -0700
AIM: To create a form for check box operation
                                    
 CODE
Form 1
Dim i As Integer
Private Sub Check_Click(Index As Integer)
Message.Caption = "YOU GOT"
For i = 0 To 5
If Check(i).Value = 1 Then
Message.Caption = Message.Caption & Chr(10) & Check(i).Caption
End If
Next i
End Sub
Private Sub Clear_Click()
For i = 0 To 5
Check(i).Value = False
Next i
Message.Caption = ""
End Sub
Private Sub Exit_Click()
End
End Sub







NUMBER PROGRAM
noreply@blogger.com (Anoop) — Mon, 14 Jun 2010 04:11:00 -0700
AIM:To check whether the given number is even,odd,armstrong ,fibonacci,factorial ,prime and
 to display its square,square root,sum of digits and its reverse
                                                           CODE

Form 1
Private Sub Clear_Click(Index As Integer)
Dim i As Integer
For i = 0 To 9
OptionButton(i).Value = False
Next i
Number.Text = ""
Display.Caption = ""
Display.Visible = False
Number.SetFocus
End Sub
Private Sub Exit_Click(Index As Integer)
End
End Sub
Private Sub Form_Load()
Dim i As Integer
Display.Visible = False
For i = 0 To 9
OptionButton(i).Value = False
Next i
End Sub
Private Sub OptionButton_Click(Index As Integer)
Dim Temp As Integer, Sum As Integer, Rev As Integer, Digit As Integer, a As
Integer, b As Integer, c As Integer, i As Integer, Fact As Double, Flag As
Boolean
If IsNumeric(Number.Text) = False Then
MsgBox "Please Enter Number"
Display.Caption = ""
Exit Sub

ElseIf Val(Number.Text) < 0 Then
MsgBox "Please Enter a Positive number"
Exit Sub
ElseIf Len(Number.Text) > 4 Then
MsgBox "Enter a number upto 4 digits"
Exit Sub
End If
Display.Visible = True
Select Case Index
Case 0
If Val(Number.Text) Mod 2 = 0 Then
Display.Caption = Number.Text & "is even"
Else
Display.Caption = Number.Text & "not even"
End If
Case 1
If Val(Number.Text) Mod 2 = 1 Then
Display.Caption = Number.Text & "is odd"
Else
Display.Caption = Number.Text & "is not odd"
End If
Case 2
Temp = Val(Number.Text)
 Sum = 0
 While Temp > 0
 Digit = Temp Mod 10
 Sum = Sum + Digit ^ 3
 Temp = Int(Temp / 10)
 Wend
 If Sum = Val(Number.Text) Then
 Display.Caption = Number.Text & "is an armstrong number"
 Else
 Display.Caption = Number.Text & "is not an armstrong number"
 End If

Case 3
a = 1: b = 0
While (c < Val(Number.Text))
c = a + b: a = b: b = c
Wend
If c = Val(Number.Text) Then
Display.Caption = Number.Text & "is a Fibonacci number"
Else
Display.Caption = Number.Text & "not a fibonacci number"
End If
Case 4
Fact = 1: i = 1
While Fact < Val(Number.Text)
Fact = Fact * i: i = i + 1
Wend
If Fact = Val(Number.Text) Then
Display.Caption = Number.Text & "is a perfect factorial"
Else
Display.Caption = Number.Text & "is not a perfect factorial"
End If
Case 5
Flag = True
For i = 2 To Sqr(Val(Number.Text))
If Val(Number.Text) Mod i = 0 Then
Flag = False
Exit For
End If
Next i
If Flag Then
Display.Caption = Number.Text & "is a prime number"
Else
Display.Caption = Number.Text & "is not a prime number"
End If
Case 6
Temp = Val(Number.Text)
Sum = 0
While Temp > 0
Digit = Temp Mod 10
Sum = Sum + Digit
Temp = Int(Temp / 10)
Wend

Display.Caption = "Sum of the individual digits of" & Number.Text & "is" &
Str(Sum)
Case 7
   Display.Caption = "Square of " & Number.Text & " is " &
Str(Val(Number.Text)) ^ 2
Case 8
   Display.Caption = "square root of" & Number.Text & "is " &
Str(Sqr(Val(Number.Text)))
Case 9
   Temp = Val(Number.Text)
   Rev = 0
   While Temp > 0
   Digit = Temp Mod 10
   Rev = Rev * 10 + Digit
   Temp = Int(Temp / 10)
   Wend
   Display.Caption = "Reverse of " & Number.Text & "is" & Str(Rev)
End Select
End Sub






STOPWATCH
noreply@blogger.com (Anoop) — Mon, 14 Jun 2010 04:05:00 -0700
                      
AIM:To create a stopwatch
 
                               CODE
Form 1
Dim starttime
Private Sub cmdstart_Click()
starttime = Now
Timer1.Enabled = True
End Sub
Private Sub cmdstop_Click()
Timer1.Enabled = False
End Sub
Private Sub display_Click()
starttime = Now
End Sub
Private Sub exit_Click()
End
End Sub
Private Sub Form_Load()
display.BackColor = RGB(0, 255, 255)
display.ForeColor = RGB(0, 0, 255)
End Sub
Private Sub Timer1_Timer()
display.Caption = Format$(Now - starttime, "hh : mm : ss")
End Sub

O/P




SUM OF N NUMBERS USING ARRAY
noreply@blogger.com (Anoop) — Mon, 14 Jun 2010 03:59:00 -0700

                    
AIM:To find the sum of n numbers using array
                                  
 CODE
Form 1
Private Sub clear_Click()
Text1.Text = ""
End Sub
Private Sub end_Click()
End
End Sub
Private Sub sum_Click()
Dim i, a, n, sum As Integer
sum = 0
a=1
n = Val(Text1.Text)
Do While a <= n
sum = sum + a
a=a+1
Loop
MsgBox "The Result is" & sum
End Sub






KEYBOARD AND MOUSE EVENTS
noreply@blogger.com (Anoop) — Mon, 14 Jun 2010 03:48:00 -0700
              
AIM: To create a form for showing Keyboard and Mouse events
                             CODE
Form 1
Private Sub Clear_Click()
Dim i As Integer
message.Caption = ""
For i = 0 To 6
Day(i).Value = False
Next i
End Sub
Private Sub Day_KeyPress(Index As Integer, KeyAscii As Integer)
Dim temp As String, i As Integer
temp = ""
message.Caption = ""
message.Visible = True
If KeyAscii = 13 Then
For i = 0 To 6
If Day(i).Value = True Then temp = Day(i).Caption
Next i
message.Caption = Day(Index).Caption
End If
End Sub
Private Sub Day_MouseMove(Index As Integer, Button As Integer, Shift As
Integer, X As Single, Y As Single)
Dim temp As String, i As Integer
temp = ""
message.Caption = ""
message.Visible = True
For i = 0 To 6
If Day(i).Value = True Then temp = Day(i).Caption
Next i
message.Caption = Day(Index).Caption
End Sub
Private Sub Exit_Click()
End
End Sub







SIMPLE AND COMPOUND INTEREST
noreply@blogger.com (Anoop) — Mon, 14 Jun 2010 03:28:00 -0700
AIM:To prepare a form for calculating simple and compound interest
                                    CODE

FORM 1
Private Sub Command1_Click()
End
End Sub
Private Sub Command2_Click()
Dim p, n, r As Integer
p = Val(Text1.Text)
n = Val(Text2.Text)
r = Val(Text3.Text)
si = (p * n * r) / 100
Text4.Text = si
End Sub
Private Sub Command3_Click()
p = Val(Text1.Text)
n = Val(Text2.Text)
r = Val(Text3.Text)
ci = p * (1 + (r / 100) ^ n)
Text4.Text = ci
End Sub

o/p