Find a Factorial In VB

Public Function Factorial(ByVal Factor As Byte) As Variant

On Error GoTo ErrorHandler
If Factor = 0 Then
Factorial = 1
Else
Factorial = Factor * Factorial(Factor - 1)
End If
Exit Function

ErrorHandler:
MsgBox Err.Description
End Function

Private Sub Form_Load()
MsgBox Factorial(3)
End Sub

Change system colors

Private Declare Function SetSysColors Lib "user32" (ByVal nValues As Long, lpSysColor As Long, lpColorValue As Long) As Long
Private Const COLOR_SCROLLBAR = 0
Private Const COLOR_BACKGROUND = 1
Private Const COLOR_ACTIVECAPTION = 2
Private Const COLOR_INACTIVECAPTION = 3
Private Const COLOR_MENU = 4
Private Const COLOR_WINDOW = 5
Private Const COLOR_WINDOWFRAME = 6
Private Const COLOR_MENUTEXT = 7
Private Const COLOR_WINDOWTEXT = 8
Private Const COLOR_CAPTIONTEXT = 9
Private Const COLOR_ACTIVEBORDER = 10
Private Const COLOR_INACTIVEBORDER = 11
Private Const COLOR_APPWORKSPACE = 12
Private Const COLOR_HIGHLIGHT = 13
Private Const COLOR_HIGHLIGHTTEXT = 14
Private Const COLOR_BTNFACE = 15
Private Const COLOR_BTNSHADOW = 16
Private Const COLOR_GRAYTEXT = 17
Private Const COLOR_BTNTEXT = 18
Private Const COLOR_INACTIVECAPTIONTEXT = 19
Private Const COLOR_BTNHIGHLIGHT = 20
Private Sub Form_Load()
'you now have ablue desktop ;-)
X = SetSysColors(1, COLOR_BACKGROUND, &HFF0F00)
End
End Sub

Change text color in a text box

Option Explicit
Private Declare Function SetSysColors Lib "user32" (ByVal nChanges _
As Long, lpSysColor As Long, lpColorValues As Long) As Long


Dim NewColor(0) As Long
Dim IndexArray(0) As Long
Private Const COLOR_GRAYTEXT = 17


Private Sub Command1_Click()
IndexArray(0) = COLOR_GRAYTEXT
NewColor(0) = QBColor(Int(Rnd * 16))
SetSysColors 1, IndexArray(0), NewColor(0)
End Sub


Private Sub Command2_Click()
Text1.Enabled = False
End Sub

Change text color in a text box

Option Explicit
Private Declare Function SetSysColors Lib "user32" (ByVal nChanges _
As Long, lpSysColor As Long, lpColorValues As Long) As Long


Dim NewColor(0) As Long
Dim IndexArray(0) As Long
Private Const COLOR_GRAYTEXT = 17


Private Sub Command1_Click()
IndexArray(0) = COLOR_GRAYTEXT
NewColor(0) = QBColor(Int(Rnd * 16))
SetSysColors 1, IndexArray(0), NewColor(0)
End Sub


Private Sub Command2_Click()
Text1.Enabled = False
End Sub

Cascade windows

Dim cascade As New Shell32.Shell

Private Sub Command1_Click()
cascade.CascadeWindows
End Sub


Add a reference to Microsoft Shell Controls and Automation

Binary to decimal and decimal to binary conversions

Public Function BinaryToDecimal(Binary As String) As Long
Dim n As Long
Dim s As Integer
For s = 1 To Len(Binary)
n = n + (Mid(Binary, Len(Binary) - s + 1, 1) * (2 ^ (s - 1)))
Next s

BinaryToDecimal = n
End Function

Public Function DecimalToBinary(DecimalNum As Long) As String
Dim tmp As String
Dim n As Long

n = DecimalNum

tmp = Trim(Str(n Mod 2))
n = n \ 2

Do While n <> 0
tmp = Trim(Str(n Mod 2)) & tmp
n = n \ 2
Loop

DecimalToBinary = tmp
End Function

Check for administrative rights for XP and 2000

Private Declare Function IsNTAdmin Lib "advpack.dll" (ByVal dwReserved As Long, ByRef lpdwReserved As Long) As Long

Private Sub Form_Load()

Dim blnAdmin As Boolean
blnAdmin = CBool(IsNTAdmin(ByVal 0&, ByVal 0&))

end sub

VB Conect to an Access database

Dim objConn As New ADODB.Connection
objConn.ConnectionString = "Provider = Microsoft.Jet.OLEDB.4.0;"_
& "Data Source =C:\pop.mdb"
objConn.open

Use drag and drop in a application

If you have a listbox with some elements and want to drag&drop a selected one into a textbox. I know there are easier ways to do this but it's just for making the point.

Make a form with a textbox (text1) and a listbox (list1). Fill the listbox with some items...
Make a label (label1). Set it invisible = False

Put the next code at the appropiate places:

Sub List1_MouseDown (Button as Integer, Shift as Integer, X as Single, Y as Single)
Dim DY

DY = TextHeight("A")
Label1.Move list1.Left, list1.Top + Y - DY / 2, list1.Width, DY
Label1.Drag

End Sub

Sub List1_DragOver (Source as Control, X as Single, Y as Single, state as Integer)
If state = 0 Then Source.MousePointer = 12
If state = 1 Then Source.MousePointer = 0

End Sub

Sub Form_DragOver (Source as Control, X as Single, Y as Single, state as Integer)
If state = 0 Then Source.MousePointer = 12
If state = 1 Then Source.MousePointer = 0

End Sub

Sub Text1_DragDrop (Index as Integer, Source as Control, X as Single, Y as Single)
text1.text = list1

End Sub

Put your application on top

Declare Function SetWindowPos Lib "User" (ByVal hWnd as Integer, ByVal hWndinsertafter as Integer, ByVal x as Integer, ByVal Y as Integer, ByVal cx as Integer, ByVal cy as Integer, ByVal wFlags as Integer) as Integer
Global Const HWND_TOPMOST = -1
Global Const HWND_NOTOPMOST = -2


Sub MakeTopMost (frmForm as Form, LX%, LY%, RX%, RY%)
dim succes as Long

succes = SetWindowPos(frmForm.hWnd, HWND_TOPMOST, LX%, LY%, RX%, RY%, 0)

End Sub

Sub UnMakeTopMost (frmForm as Form)
dim succes as Long

succes = SetWindowPos(frmForm.hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, 0)

End Sub

Return

Redim Preserve a 2d array

To redim preserve the first element of a 2d array, use the following code:

'Purpose : A ReDim Preserve routine for a 2-d array
'Inputs : vaValues Array to resize
' lLBound The New LBound of the first element of the 2d Array
' lUBound The New UBound of the first element of the 2d Array
'Outputs :
'Notes : Doesn't work with fixed arrays


Sub ReDimPreserve2d(ByRef vaValues As Variant, lLBound As Long, lUBound As Long)
Dim lThisRow As Long, lThisCol As Long, vaResults() As Variant, lNumDims As Long
Dim lLBound2 As Long, lUBound2 As Long

On Error GoTo ExitSub
If IsArray(vaValues) Then
lNumDims = lUBound - lLBound + 1
If lNumDims <= 0 Then
'Delete Array
On Error Resume Next
Erase vaValues
vaValues = Empty
On Error GoTo 0
Else
'Create the Result Array
lLBound2 = LBound(vaValues, 2)
lUBound2 = UBound(vaValues, 2)
ReDim vaResults(lLBound To lUBound, lLBound2 To lUBound2)
'Copy vaValues into vaResults
For lThisRow = lLBound2 To lUBound2
For lThisCol = lLBound To lUBound
vaResults(lThisCol, lThisRow) = vaValues(lThisCol, lThisRow)
Next
Next
'Copy Result array to input array
On Error GoTo ArrayDimmed
vaValues = vaResults
End If
End If
GoTo ExitSub

ArrayDimmed:
'The Input array has been dimmed as an array,
'copy each element of Result array to Input array
ReDim vaValues(lLBound To lUBound, lLBound2 To lUBound2)
For lThisRow = lLBound2 To lUBound2
For lThisCol = lLBound To lUBound
vaValues(lThisCol, lThisRow) = vaResults(lThisCol, lThisRow)
Next
Next
On Error GoTo 0
ExitSub:
End Sub

Removing an item from a 1d array

Option Explicit

'Use of Program : To Removes an item from a 1d array.
'Inputs : avRemoveFrom The array to remove the item from.
' [lIndex] The index of the item to remove.
' [vItemToRemove] The value of the item to remove.
' [bPreserveOrder] If True the order of the array is preserved (slightly slower)
'Outputs : Returns True if removed item from array.
'Notes : Specify EITHER the lIndex OR vItemToRemove.
' If vItemToRemove is specified and the array contains more than one item with this value,
' the first item in which matches this value will be removed. Will NOT work with fixed
' arrays (eg. Dim myArray(1 to 5) as String). Arrays must be declared as dynamic (eg.
' Dim myArray() as String).

Function Array1DRemove(ByRef avRemoveFrom As Variant, Optional lIndex As Long, Optional vItemToRemove As Variant, Optional bPreserveOrder As Boolean = False) As Boolean
Dim lUbound As Long, vTempVal As Variant, lLBound As Long, bFoundItem As Boolean
Dim lThisItem As Long

On Error GoTo ErrFailed
lUbound = UBound(avRemoveFrom)
lLBound = LBound(avRemoveFrom)

If IsMissing(vItemToRemove) Then
If lUbound >= lIndex Then
'Found item
bFoundItem = True
End If
Else
'Remove item by value, find the item in the array
For lIndex = lLBound To lUbound
If avRemoveFrom(lIndex) = vItemToRemove Then
'Found item
bFoundItem = True
Exit For
End If
Next
End If

If bFoundItem Then
'Found item
If bPreserveOrder Then
'Preserve the order of the array,
'by copying the values up the order fo the array
For lThisItem = lIndex To lUbound - 1
avRemoveFrom(lThisItem) = avRemoveFrom(lThisItem + 1)
Next
Else
'Copy last item into a temp variable
vTempVal = avRemoveFrom(lUbound)
'Overwrite item to delete
avRemoveFrom(lIndex) = vTempVal
End If
'Resize the array
ReDim Preserve avRemoveFrom(lLBound To lUbound - 1)
Array1DRemove = True
End If

Exit Function

ErrFailed:
Debug.Print Err.Description
Array1DRemove = False
On Error GoTo 0
End Function

'Demonstration routine
Sub Test()
Dim alValues() As Long, lThisItem As Long

ReDim alValues(1 To 5)
For lThisItem = 1 To 5
alValues(lThisItem) = lThisItem * 2
Next

'Remove item with a value 4 (preserving the order of the array)
Array1DRemove alValues, , 4, True

'Remove item 1 (preserving the order of the array)
Array1DRemove alValues, 1, True
End Sub

Validating An Email Address

Public Function Validate_EmailAddress(ByVal EAddress As String) As Boolean
Const AllowChars = "1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ" + _
"abcdefghijklmnopqrstuvwxyz._-"
Dim UserName As String
Dim ServerName As String
Dim x As Long

x = InStr(1, EAddress, "@")
If x = 0 Then GoTo BadAddress
If InStr(x + 1, EAddress, "@") > 0 Then GoTo BadAddress
UserName = Left$(EAddress, x - 1)
ServerName = Right$(EAddress, Len(EAddress) - x)
If Left$(UserName, 1) = "." Or Right$(UserName, 1) = "." Then GoTo BadAddress
If Left$(ServerName, 1) = "." Or Right$(ServerName, 1) = "." Or _
InStr(1, ServerName, ".") = 0 Then GoTo BadAddress
For i = 1 To Len(UserName)
If InStr(1, AllowChars, Mid$(UserName, i, 1)) = 0 Then GoTo BadAddress
Next
For i = 1 To Len(ServerName)
If InStr(1, AllowChars, Mid$(ServerName, i, 1)) = 0 Then GoTo BadAddress
Next
Validate_EmailAddress = True
Exit Function

BadAddress:
Validate_EmailAddress = False

End Function

Give your application a splashscreen

Sub Form_Load()
Top = (Screen.Height * 0.9) / 2 - Height / 2
Left = Screen.Width / 2 - Width / 2
Me.Show
Me.Refresh
Load Form2

Form2.Show
Unload Form1

End Sub


Return

Function to round a value up,down,or near to another value.

Function doRound(value As Double, RStep As Double, Mode As String) As
Double

' Mode function
' UP RoundUp
' DN RoundDN
' NE Nearest
'

If Mode = "DN" Then
doRound = (Int(value / RStep) * RStep)
Exit Function
End If

' **** mode up
If Mode = "UP" Then
If value Mod RStep > 0 Then
doRound = ((Int(value / RStep) * RStep) + RStep)
Else
doRound = value
End If
Exit Function
End If

If Mode = "NE" Then
value = value + (RStep / 2)
doRound = (Int(value / RStep) * RStep)
Exit Function
End If
End Function

Function to find the number of working days there are between two dates.

'Here is function that will find the number of working
'days (weekdays) there are between two dates.


Function getBusDays(SDate As Date, EDate As Date) As Integer
'
' This function will find the number of
' business days between two dates.

Dim tmpDay As Integer
getBusDays = 0
Do Until SDate = EDate
tmpDay = Format(SDate, "w")
Select Case tmpDay
Case 2, 3, 4, 5, 6
getBusDays = getBusDays + 1
End Select
SDate = DateAdd("d", 1, SDate)
Loop

End Function

Function to add simple encryption to a string.

'Trivial String Encryption

'Plug this guy in your app to quickly encrypt a string.
'Will keep your average busybody out.

Function crypt$ (action$, key$, src$)
'trivial encryption algorithm)
'usage crypt$("E"ncrypt or "D"ecrypt, keyword, source string))
Dim count%, keypos%, keylen%, srcasc%, dest$, srcpos%, xtest$)
keylen = Len(key))
If UCase$(action) = "E" Then)
For srcpos = one To Len(src))
srcasc = Asc(Mid$(src, srcpos, one)))
If keypos

'Here is a function to round a value up,down,or near
'to another value.


Function doRound(value As Double, RStep As Double, Mode As String) As
Double
' Mode function
' UP RoundUp
' DN RoundDN
' NE Nearest
'
If Mode = "DN" Then
doRound = (Int(value / RStep) * RStep)
Exit Function
End If

' **** mode up
If Mode = "UP" Then
If value Mod RStep > 0 Then
doRound = ((Int(value / RStep) * RStep) + RStep)
Else
doRound = value
End If
Exit Function
End If

If Mode = "NE" Then
value = value + (RStep / 2)
doRound = (Int(value / RStep) * RStep)
Exit Function
End If
End Function

Function to round a value up,down,or near to another value.

Function doRound(value As Double, RStep As Double, Mode As String) As
Double

If Mode = "DN" Then
doRound = (Int(value / RStep) * RStep)
Exit Function
End If

' **** mode up
If Mode = "UP" Then
If value Mod RStep > 0 Then
doRound = ((Int(value / RStep) * RStep) + RStep)
Else
doRound = value
End If
Exit Function
End If

If Mode = "NE" Then
value = value + (RStep / 2)
doRound = (Int(value / RStep) * RStep)
Exit Function
End If
End Function

> Decimal Numbers to Binary

Function DecToBin(ByVal DecValue As Byte)

'Dimension some variables.
Dim strOut As String
Dim x As Long
strOut = String$(8, Asc("0")) 'return 8 chr's

For x = 0 To 7
If (DecValue And 1) Then Mid$(strOut, 8 - x, 1) = "1"
DecValue = (DecValue And -2) / 2
Next x

DecToBin = strOut

End Function

Converting numbers > Hexadecimal to Decimal

Sub Form_Load ()

Dim x as String
Dim y as Variant

x = "fffe"
y = CLng("&H" & x)

If y < 0 Then y = y + 65536 ' returns 65534

MsgBox y

End Sub


* Converting a string to an integer: Cal Stover

Dim SomeVariable as Integer
SomeVariable = CInt(Label2.Caption) + 100

Dim SomeVariable as Single
SomeVariable = CSng(Val(Label2.Caption) + 100)


* convert a number in Hexadecimal to Binary -chris

A very fast conversion from hex to binary can be done with a sixteen
element look-up table - a single hex digit converts to four binary
digits. So:

Function Hex2Bin$(HexValue$)
CONST BinTbl ="0000000100100011010001010110011110001001101010111100110111101111"
dim X, Work$
Work$ = ""
For X = 1 to Len(HexValue$)
Work$ = Work$ + Mid$(BinTbl, (Val("&h" + Mid$(HexValue$, X, 1) - 1) * 4 + 1, 4)
Next
Hex2Bin$ = Work$
End Function



Return

Convert integer to Hex

Sub cmdColor_Click()
dim RedValue, GreenValue, BlueValue
dim AColor

'see help on Flags for settings
CMDialog1.Flags = &H1& Or &H4&
'action 3 means show colorpalette
CMDialog1.Action = 3
'when you press OKE the color will be put into the variable AColor
AColor = CMDialog1.Color

RedValue = (ACOLOR And &HFF&)
GreenValue = (ACOLOR And &HFF00&) \ 256
BlueValue = (ACOLOR And &HFF0000) \ 65536
ChoosenColor = Format(Hex(RedValue) & Hex(GreenValue) & Hex(BlueValue), "000000")
msgbox ChoosenColor

End Sub
Return

Convert a pointer to a string into a string

Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (pTo As Any, uFrom As Any, ByVal lSize As Long)
Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long


'Purpose : Converts a pointer to a string into a string.
'Inputs : lPtr A long pointer to a string held in memory
'Outputs : The string held at the specified memory address
'Notes :
'Revisions :

Private Function StrFromPtr(ByVal lPtr As Long) As String
Dim lLen As Long
Dim abytBuf() As Byte

'Get the length of the string at the memory location
lLen = lstrlenW(lPtr) * 2 - 1 'Unicode string (must double the buffer size)

If lLen > 0 Then
ReDim abytBuf(lLen)
'Copy the memory contents
'into a they byte buffer
Call CopyMem(abytBuf(0), ByVal lPtr, lLen)
'convert and return the buffer
StrFromPtr = abytBuf
End If
End Function

'Demonstration routine
Sub Test()
Dim sTest As String
sTest = "Andrew"
Debug.Print StrFromPtr(StrPtr(sTest))
End Sub

Binary Numbers to Decimal

'This function receives a string, hopefully containing a
'binary number and returns the decimal equivalent.
Function BinToDec(ByVal BinValue As String) As Byte

'Dimension some variables.
Dim lngValue As Byte
Dim x As Long
Dim k As Long
k = Len(BinValue)
For x = k To 1 Step -1
If Mid$(BinValue, x, 1) = "1" Then
If k - x > 30 Then
lngValue = lngValue Or -2147483648# 'avoid overflow
Else
lngValue = lngValue + 2 ^ (k - x)
End If
End If
Next x

BinToDec = lngValue

End Function

Loops In VB

Do-Loops

The most basic form of loop in Visual Basic is the Do-Loop. Its construct is very simple:

Do
(Code to execute)
Loop

This, quite simply, executes the block of code, and when it reaches Loop, returns to the beginning of the Do Loop and executes the same block of code again. The same block of code will be repeatedly executed until it is told to stop executing. So let's try to apply this to our problem of generating the Fibonacci series:


Dim X As Integer

Dim Y As Integer



Do

Debug.Print X



X = Y + X

Y = X - Y

Loop



And, believe it or not, this code works! Well, sorta. If you try to run this code, it will indeed generate the Fibonacci series; however, it will continually generate and print out the next number infinitely--or, in this case, until it reaches an overflow error. This is known as the problem of the infinite do-loop, one that all programmers will experience, and some quite frequently.

Exit Do

So we clearly need some way to escape from the Do-Loop. You could, of course, simply End the program once you have calculated enough values, but what if you still need to perform tasks after you're done calculating? The answer is to use the Exit Do statement. Whenever your program reaches an Exit Do statement within a loop, it will exit the current loop.

So, let's try a somewhat different approach to the Fibonacci problem. We decide that we want to calculate only eight values of the Fibonacci series, so we'll keep a counter and increment it each time throughout the loop. Then, once the counter reaches eight, we'll exit the loop.


Public Sub Main()

Dim X As Integer

Dim Y As Integer

Dim cnt As Integer 'Our counter.

cnt = 1

Do

Debug.Print X

X = Y + X

Y = X - Y



If cnt >= 8 Then

Exit Do

Else
cnt = cnt + 1

End If

Loop

End Sub

And now we're talking! This program successfully computes and prints out the first eight values of the Fibonacci series.

Do Until

As an alternative approach to nesting an If-Statement inside the loop, and invoking Exit Do once we're done looping, Visual Basic provides a Do Until statement. Its syntax is the following:

Do Until (Expression)
(Code to execute)
Loop

(Expression) can be any legal logical expression that we wish to evaluate to determine whether or not to exit the loop. Each time the program reaches Loop it will evaluate this expression. If the expression is True, it will exit the loop for us, but otherwise it will continue looping.. So let's try rewriting our Fibonacci program to use a Do-Until loop instead of Exit Do.

1.
Public Sub Main()
2.
Dim X As Integer
3.
Dim Y As Integer
4.
Dim cnt As Integer 'Our counter.
5.

6.
cnt = 1
7.

8.
Do Until cnt >= 8
9.
Debug.Print X
10.

11.
X = Y + X
12.
Y = X - Y
13.
cnt = cnt + 1
14.
Loop
15.
End Sub



Here we've replaced the hideous If cnt >= 8 Then ... Else: Exit Do with a very simple Until cnt >= 8. We must, however, still be sure to increment our counter every time through the loop, or else the Until expression will never be True, resulting in an infinite Do Loop.

Do While

In the place of Do Until, you can also use Do While. Its syntax is the following:

Do While (Expression)
(Code to execute)
Loop

(Expression) can be any legal logical expression that we wish to evaluate to determine whether or not to exit the loop. Each time the program reaches Loop it will verify that this expression is True, and if it is False, it will exit the loop for us. Thus, instead of exiting when an expression is True, it now exits only once this expression is false. Let's try rewriting our Fibonacci program to use a Do-While loop instead of a Do-Until loop.

Public Sub Main()

Dim X As Integer

Dim Y As Integer

Dim cnt As Integer 'Our counter.



cnt = 1

Do While cnt < 8

Debug.Print X

X = Y + X

Y = X - Y



cnt = cnt + 1

Loop

End Sub

For-Next Loops

In situations where you merely want to run the loop a predefined number of times, it can become quite tiresome to have to create and manage a counter for each loop, which is why we also have something called a For-Next Loop. This kind of loop allows you to specify a counter, to tell it to count from one number to another each time through the loop, and to exit once the counter has reached its upper limit. The syntax is as follow:
Dim I As Integer

For I = (Integer) To (Integer)
(Code to execute)
Next I

We used the variable name "I" above, as it is the most common name used for For-Loops; however, you can use any variable name you want, so long as the variable is of the type Integer. Now, let's improve our Fibonacci program even further:


Public Sub Main()

Dim X As Integer

Dim Y As Integer

Dim cnt As Integer 'Our counter.



For cnt = 1 To 8

Debug.Print X

X = Y + X

Y = X - Y

Loop

End Sub



In the example above, we first dimensioned cnt as an Integer, and then, in the declaration of the For-Next loop, set its value to 1. Each time through the loop, the value of cnt was incremented by 1 until it reached 8, at which point the loop was executed.

Exit For

As with Do Loops, there is a statement that can be used to exit a For-Next loop, and it is called Exit For. Simply invoke this statement anywhere within a For-Next loop and the current loop will be exited.

Step

By default, the variable used in the declaration of the For-Next loop is incremented by 1 each time through the loop; however, if you want to increment this value by a different amount each time through the loop, you can simply append Step (Integer) to the end of the For-Next loop declaration. If, for instance, we wanted to print out every even number counting backward from 20 to 0, we could do this using the following code:


Dim I As Integer



For I = 20 To 0 Step -2

Debug.Print I

Next I

if, else, and select statements

In VB, the following form is preferred for implementing the If-Then-Else structure (this is the "block", or "multi-line" form of the If statement):

If Then

Else

End If

If the conditional expression is true, the statements between the keywords Then and Else will be executed (and the statements between the keywords Else and End If will be bypassed). If the conditional expression is false, the statements between the keywords Else and End If will be executed (and the statements between the keywords Then and Else will be bypassed). In any case, program control will resume with the statement following End If.

Example:

If sngNumberOfCredits <>

lblStatus = "PART-TIME STUDENT"

dblTuitionAmount = sngNumberOfCredits * 175

Else

lblStatus = "FULL-TIME STUDENT"

dblTuitionAmount = 2000

End If

STYLE TIPS FOR THE BLOCK IF STATEMENT:

(1) Indent the "true" actions 4 spaces from the keyword "If"

(2) Code the keyword "Else" on a separate line, aligned with the keyword "If"

(3) Code the "false" actions 4 spaces from the keyword "Else"

(4) Align the keywords "End If" with the keywords "If" and "Else"

Split a given string into different words

Function SplitString%(TheString$, Delim$, DynArray$())
dim p%, t%
dim sTempString$, tmp$
t% = 0
' Remove trailing blanks
sTempString$ = Trim(TheString$)
' If the last character is the delimiter, remove it
If Right(sTempString$, 1) = Delim$ Then sTempString$ = Left(sTempString$, Len(sTempString$) - 1)
' Add a delimiter to end
sTempString$ = sTempString$ & Delim$
Do
p% = InStr(sTempString$, Delim$)
If p% = 0 Then exit Do
ReDim Preserve DynArray$(t%)
tmp$ = Left(sTempString$, p% - 1)
sTempString$ = Right$(sTempString$, Len(sTempString$) - p%)
DynArray$(t%) = Trim(tmp$)
t% = t% + 1
Loop
' Returns the last availabe index
SplitString% = UBound(DynArray$)
End Function

** Calling procedure example:

' text$ is the string to be splitted
' n= number of words found - 1
' delimiter is ","

Dim Words$()
Text$ = Trim(Text$)
n = SplitString(Text$, ",", Words$())



Return

Calculator Project In VB

The basic layout of the screen is shown in the figure 5. There are two control arrays of buttons one for the digits 0 to 9 and another for operators +, -, /, * and =. The form is given the name ‘calculator’ and its icon property is set to calculator icon. The display label is given the name ‘Readout’ and the caption ‘0.’. The number buttons 0 to 9 are given the same name ‘Number’, their captions and indexes are set as 0, 1, 2, 3, 4, 5, 6, 7, 8 and 9 respectively. The operator buttons /, +, X, - and = are given the same name, “Operator” , and their indexes are set as 0, 1, 2, 3 and 4 respy. The ‘%’ button is given the name ‘Percent’, the ‘.’ button is given the name ‘Decimal’, the ‘C’ button is given the name ‘Cancel’ and the ‘CE’ button is given the name ‘CancelEntry’. The codes are entered in the code window as shown in the figure 5a. Save and run the project and check that the calculator functions properly.

Option Explicit
Dim Op1, Op2 ' Previously input operand.
Dim DecimalFlag As Integer ' Decimal point present yet?
Dim NumOps As Integer ' Number of operands.
Dim LastInput ' Indicate type of last keypress event.
Dim OpFlag ' Indicate pending operation.
Dim TempReadout
' Click event procedure for C (cancel) key.
' Reset the display and initializes variables.
Private Sub Cancel_Click()
Readout = Format(0, "0.")
Op1 = 0
Op2 = 0
Form_Load
End Sub
' Click event procedure for CE (cancel entry) key.
Private Sub CancelEntry_Click()
Readout = Format(0, "0.")
DecimalFlag = False
LastInput = "CE"
End Sub
' Click event procedure for decimal point (.) key.
' If last keypress was an operator, initialize
' readout to "0." Otherwise, append a decimal
' point to the display.
Private Sub Decimal_Click()
If LastInput = "NEG" Then
Readout = Format(0, "-0.")
ElseIf LastInput <> "NUMS" Then
Readout = Format(0, "0.")
End If
DecimalFlag = True
LastInput = "NUMS"
End Sub

' Initialization routine for the form.
' Set all variables to initial values.
Private Sub Form_Load()
DecimalFlag = False
NumOps = 0
LastInput = "NONE"
OpFlag = " "
Readout = Format(0, "0.")
'Decimal.Caption = Format(0, ".")
End Sub
' Click event procedure for number keys (0-9).
' Append new number to the number in the display.
Private Sub Number_Click(Index As Integer)
If LastInput <> "NUMS" Then
Readout = Format(0, ".")
DecimalFlag = False
End If
If DecimalFlag Then
Readout = Readout + Number(Index).Caption
Else
Readout = Left(Readout, InStr(Readout, Format(0, ".")) - 1) + Number(Index).Caption + Format(0, ".")
End If
If LastInput = "NEG" Then Readout = "-" & Readout
LastInput = "NUMS"
End Sub
' Click event procedure for operator keys (+, -, x, /, =).
' If the immediately preceeding keypress was part of a
' number, increments NumOps. If one operand is present,
' set Op1. If two are present, set Op1 equal to the
' result of the operation on Op1 and the current
' input string, and display the result.
Private Sub Operator_Click(Index As Integer)
TempReadout = Readout
If LastInput = "NUMS" Then
NumOps = NumOps + 1
End If
Select Case NumOps
Case 0
If Operator(Index).Caption = "-" And LastInput <> "NEG" Then
Readout = "-" & Readout
LastInput = "NEG"
End If
Case 1
Op1 = Readout
If Operator(Index).Caption = "-" And LastInput <> "NUMS" And OpFlag <> "=" Then
Readout = "-"
LastInput = "NEG"
End If
Case 2
Op2 = TempReadout
Select Case OpFlag
Case "+"
Op1 = CDbl(Op1) + CDbl(Op2)
Case "-"
Op1 = CDbl(Op1) - CDbl(Op2)
Case "X"
Op1 = CDbl(Op1) * CDbl(Op2)
Case "/"
If Op2 = 0 Then
MsgBox "Can't divide by zero", 48, "Calculator"
Else
Op1 = CDbl(Op1) / CDbl(Op2)
End If
Case "="
Op1 = CDbl(Op2)
Case "%"
Op1 = CDbl(Op1) * CDbl(Op2)
End Select
Readout = Op1
NumOps = 1
End Select
If LastInput <> "NEG" Then
LastInput = "OPS"
OpFlag = Operator(Index).Caption
End If
End Sub
' Click event procedure for percent key (%).
' Compute and display a percentage of the first operand.
Private Sub Percent_Click()
Readout = Readout / 100
LastInput = "Ops"
OpFlag = "%"
NumOps = NumOps + 1
DecimalFlag = True
End Sub

Progress Bar In VB

Private Sub cmdStart_Click()
' Set minimum and maximum values for progress
ProgressBar1.Min = 1
ProgressBar1.Max = 5000
' Loop 5000 times
For i = 1 To 5000
' Set current value to loop value so progress will show status
ProgressBar1.Value = i
Text1 = CStr(i / 50) + "%completed"
Next i
' Tell user routine is complete
MsgBox "Done", vbInformation, "Complete."
End Sub

TreeView Control In VB

Private Sub Command1_Click()
Dim nodx As Node
Set nodx = TreeView1.Nodes.Add(, , "R", "FoodTypes")
Set nodx = TreeView1.Nodes.Add("R", tvwChild, "Ft", "Fruits")
Set nodx = TreeView1.Nodes.Add("R", tvwChild, "Vg", "Vegetables")
Set nodx = TreeView1.Nodes.Add("R", tvwChild, "Mt", "Meat")
Set nodx = TreeView1.Nodes.Add("R", tvwChild, "Jf", "Juicy Food")
Set nodx = TreeView1.Nodes.Add("R", tvwChild, "Sf", "Salty Snacks")
nodx.EnsureVisible
End Sub

Private Sub Command2_Click()
Set nodx = TreeView1.Nodes.Add("Ft", tvwChild, "Ap", "Apple")
Set nodx = TreeView1.Nodes.Add("Ft", tvwChild, "Or", "Orange")
Set nodx = TreeView1.Nodes.Add("Ft", tvwChild, "Pr", "Pear")
End Sub

Private Sub Command3_Click()
Set nodx = TreeView1.Nodes.Add("Vg", tvwChild, "Bn", "Beans")
Set nodx = TreeView1.Nodes.Add("Vg", tvwChild, "Cr", "Carrot")
Set nodx = TreeView1.Nodes.Add("Vg", tvwChild, "Rd", "Raddish")
End Sub

BubbleSort In VB

Sub BubbleSort(arr As Variant, Optional numEls As Variant, _
Optional descending As Boolean)

Dim value As Variant
Dim index As Long
Dim firstItem As Long
Dim indexLimit As Long, lastSwap As Long

' account for optional arguments
If IsMissing(numEls) Then numEls = UBound(arr)
firstItem = LBound(arr)
lastSwap = numEls

Do
indexLimit = lastSwap - 1
lastSwap = 0
For index = firstItem To indexLimit
value = arr(index)
If (value > arr(index + 1)) Xor descending Then
' if the items are not in order, swap them
arr(index) = arr(index + 1)
arr(index + 1) = value
lastSwap = index
End If
Next
Loop While lastSwap
End Sub

Age Claculator In VB

Private Sub Command1_Click()
Dim mdate As Date
Dim i, j, k As Integer
mdate = Text1.Text
i = DateDiff("yyyy", mdate, Now)
j = DateDiff("m", mdate, Now)
If i > 12 Then
j = (j Mod 12)
If j <> 0 Then
i = i - 1
End If
End If
Label1.Caption = "age is " & i & "years" & j & "months"
End Sub

Login code For VB

Dim i As Integer
Private Sub Command1_Click()
If Text1.Text = "pop" Then
MsgBox "welcome"
Else
i = i + 1
If i = 3 Then
MsgBox "u r try over"
End
Else
MsgBox "wrong pwd"
End If
End If
End Sub
Private Sub Form_Load()
i = 0
End Sub

Transposing a 2d array

Function Array2DTranspose(avValues As Variant) As Variant
Dim lThisCol As Long, lThisRow As Long
Dim lUb2 As Long, lLb2 As Long
Dim lUb1 As Long, lLb1 As Long
Dim avTransposed As Variant

If IsArray(avValues) Then
On Error GoTo ErrFailed
lUb2 = UBound(avValues, 2)
lLb2 = LBound(avValues, 2)
lUb1 = UBound(avValues, 1)
lLb1 = LBound(avValues, 1)

ReDim avTransposed(lLb2 To lUb2, lLb1 To lUb1)
For lThisCol = lLb1 To lUb1
For lThisRow = lLb2 To lUb2
avTransposed(lThisRow, lThisCol) = avValues(lThisCol, lThisRow)
Next
Next
End If

Array2DTranspose = avTransposed
Exit Function

ErrFailed:
Debug.Print err.description
Debug.Assert False
Array2DTranspose = Empty
Exit Function
Resume
End Function

MsgBox In VB

Private Sub Command1_Click()
intresponse = MsgBox("This is vb Critical", vbCritical)
End Sub

Private Sub Command2_Click()
intresponse = MsgBox("This is vb Questation", vbQuestion)

End Sub

Private Sub Command3_Click()
intresponse = MsgBox("This is vb warning", vbExclamation)

End Sub

Private Sub Command4_Click()
intresponse = MsgBox("This is vb Information", vbInformation)
End Sub

Inputbox In VB

Private Sub Command1_Click()
stranswer = InputBox("what is ur name", "get name")
If (stranswer = "pop") Then
MsgBox "hello " + stranswer
Else
MsgBox stranswer + " Shut up!"
End If
End Sub

Pay Slip In VB

Dim bs As Integer
Dim da As Integer
Dim hra As Integer
Dim net As Integer
Private Sub Command1_Click()
bs = Text3.Text
If bs >= 5000 And bs < 7500 Then
hra = (10 * bs) / 100
da = (bs * 15) / 100
Else
If bs >= 7500 Then
hra = (20 * bs) / 100
da = (20 * bs) / 100
End If
End If
net = bs + da + hra
Text4.Text = da
Text5.Text = hra
Text7.Text = net
'End If
End Sub

Fibonanci Series In VB

Dim i, f1, f2, f3, n As Integer


Private Sub Command1_Click()
n = Text1.Text
i = 3
While (i <= n)
f3 = f1 + f2
f1 = f2
f2 = f3
Next
Print f3
End Sub

Basic Salary Program in VB

Private Sub Command1_Click()
da = Text2.Text * 5 / 100
hra = Text2.Text * 7 / 100
tax = Text2.Text * 2 / 100
net = Int(Text2.Text) + Int(da) + Int(hra) - Int(tax)

Label4.Caption = "The DA is " & da & "/-"
Label5.Caption = "The HRA is " & hra & "/-"
Label6.Caption = "The TAX is " & tax & "/-"
Label3.Caption = "The Netsal is " & net & "/- Rs Only."
End Sub

Arithmatic Operation In VB

Dim a, b, c As Integer
Private Sub Command1_Click()
a = Text1.Text
b = Text2.Text
c = Val(a) + Val(b)
Label2.Caption = c
End Sub

Private Sub Command2_Click()
a = Text1.Text
b = Text2.Text
c = a - b
Label2.Caption = c
End Sub

Private Sub Command3_Click()
a = Text1.Text
b = Text2.Text
c = a * b
Label2.Caption = c
End Sub

Private Sub Command4_Click()
a = Text1.Text
b = Text2.Text
c = a / b
Label2.Caption = c
End Sub

Private Sub Command5_Click()
Text1.Text = ""
Text2.Text = ""
Label2.Caption = ""
End Sub

Private Sub Command6_Click()
End
End Sub

Area Of Circle In VB

Dim r, b, pi As Integer
'code for calculate button
Private Sub Command1_Click()
pi = 3.14
r = Text1.Text
b = pi * (r * r)
Label2.Caption = "The Area is " & b

End Sub

'code for exit button
Private Sub Command2_Click()
End
End Sub
'clear button
Private Sub Command3_Click()
Text1.Text = ""
Label2.Caption = ""
End Sub

Visual Basic-6 has emerged as one of the standard Windows Programming Language and it has become a must for all Software people for developing Applications in Visual Environment. So it is, one must learn Visual Basic-6.

What is our Objective in this Courseware?


The Overall Objective in this Courseware is to give a Hands-on Approach to develop different projects in Visual Basic-6.0 using intrinsic, professional and user–created ActiveX controls and also develop projects using databases, DAO’s, ADO’s, DLL’s, Documents, Crystal Reports etc. covering almost all the essential features of VB-6 Professional Edition. After reading one lesson any interested reader will be able to get complete hands-on experience with the VB project and get a sense of fulfilment and achievement. Learning by doing is the motto with which this courseware is written. After giving a short introduction about VB-6 we will explain how to create and execute a project in VB using some intrinsic ActiveX controls. Creating and executing projects will be the central theme of all the lessons which we will be giving in this courseware.

What is Visual Basic-6?


Visual Basic-6 has its origin in Basic which was developed round about the year 1960, when high level languages were just being introduced to the computer community. Microsoft has made it extremely powerful by gearing all its good features to the Windows environment. Starting with the version 3 and then with 4, and then with 6, Visual Basic is now at version 6. Basic is a Procedure Oriented Language intended to implement single tasks in text based environment whereas Visual Basic is an Event Driven Language intended to implement Projects or Applications containing multiple tasks in Windows Environment.

What can Visual Basic do for you?

Visual Basic can serve as an ideal front end tool for the clients to interact. It has got connectivity mechanisms for all types of databases situated far and wide in a network and so it can cater to the needs of a large body of clients. Using the latest ActiveX technologies, it can integrate the functionalities provided by other applications like Word Excel and other Windows. Its internet capabilities provide easy access to documents and applications across the internet. Above all it embodies the Object Oriented Technology, which is the cutting edge technology for all the present day developments in the Software World. The final application is a true EXE file and so can be freely distributed.


Structure of VB-6 Projects:


We said earlier that VB-6 implements projects or applications. A project is developed using one or more Forms. A Form is simply a window containing one or more Controls. Controls in VB consist of labels, text boxes, list boxes, combo boxes, scroll bars etc. which are the constituents of windows environment. It is only the controls that give VB, its immense power and so there is a lot of interest in creating more and more powerful controls. ActiveX controls mark a significant development in controls technology. In fact all controls in VB-6 are ActiveX controls, which have the extension .ocx. These controls have properties whose values can be initialized at design time and also varied during run time. The properties are something like variables. The controls are activated by codes written in a high level language. By associating our problem variables with the properties of the controls, our problem variables can be manipulated to give the problem solution. In summary we can say that a VB project is made of forms, controls and their properties and codes.

Integrated Development Environment:

The working environment in VB is often referred to as the Integrated Development Environment or IDE, because it integrates many different functions such as design, editing, compiling and debugging within a common environment. Since all our projects are developed only in the IDE, let us now have a brief look at its features. You will be able to understand their uses at the time of building projects. The VB IDE looks as shown in the figure.