Adding a horizontal scroll bar to a listbox

Option Explicit

Private Declare Function SendMessageA Lib "user32" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long


'Purpose : Adds items to a listbox and if neccessary sets the
' width of the horizontal scroll bar to the maximum width of the
' items in the listbox.
'Inputs : lbListbox The listbox to add the item to.
' sItemText The text to add to the listbox.
' [iIndex] The position within the object where the new item or row is placed.
'Outputs : Returns True on success
'Notes :
'Revisions :
'Assumptions :

Function ListboxAddItem(lbListbox As ListBox, sItemText As String, Optional iIndex As Integer = -1) as Boolean
Dim fTextWidth As Single, fExistScrollWidth As Single
Dim oParentFont As StdFont
Const LB_SETHORIZONTALEXTENT = &H194, LB_GETHORIZONTALEXTENT = &H193

On Error Resume Next

'Add item to listbox
If iIndex > -1 Then
lbListbox.AddItem sItemText, iIndex
Else
lbListbox.AddItem sItemText
End If

'Store the form's original font
Set oParentFont = lbListbox.Parent.Font
'Set the form's font to the listbox's font
Set lbListbox.Parent.Font = lbListbox.Font
'Get width of text on the form
fTextWidth = lbListbox.Parent.TextWidth(sItemText & " ") 'Extra space allows for vertical scroll bar
'Restore the form's font
Set lbListbox.Parent.Font = oParentFont

'Get the width of the existing scroll bar
fExistScrollWidth = SendMessageA(lbListbox.hwnd, LB_GETHORIZONTALEXTENT, 0, 0)

If lbListbox.Parent.ScaleMode = vbTwips Then
'Change twips to pixels
fTextWidth = fTextWidth / Screen.TwipsPerPixelX
End If

If fTextWidth > fExistScrollWidth Then
'Increase width of scroll bar
Call SendMessageA(lbListbox.hwnd, LB_SETHORIZONTALEXTENT, fTextWidth, 0)
End If
ListboxAddItem = (Err.Number = 0)
End Function


'Purpose : Modifies the text of an item in a listbox and if neccessary sets the
' width of the horizontal scroll bar to the maximum width of the
' items in the listbox.
'Inputs : lbListbox The listbox to update the item in.
' sNewItemText The new text for the item in the listbox.
' [iIndex] The index of the item to update within the listbox.
'Outputs : Returns True on Success
'Notes :
'Revisions :
'Assumptions :

Function ListboxUpdateItem(lbListbox As ListBox, sNewItemText As String, iIndex As Integer) As Boolean
Dim fTextWidth As Single, fExistScrollWidth As Single
Dim oParentFont As StdFont
Const LB_SETHORIZONTALEXTENT = &H194, LB_GETHORIZONTALEXTENT = &H193

'Add item to listbox
On Error GoTo ErrFailed
If lbListbox.List(iIndex) <> sNewItemText Then
lbListbox.List(iIndex) = sNewItemText
'Get width of text
Set oParentFont = lbListbox.Parent.Font
Set lbListbox.Parent.Font = lbListbox.Font
fTextWidth = lbListbox.Parent.TextWidth(sNewItemText & " ") 'Extra space allows for vertical scroll bar
Set lbListbox.Parent.Font = oParentFont
fExistScrollWidth = SendMessageA(lbListbox.hwnd, LB_GETHORIZONTALEXTENT, 0, 0)

If lbListbox.Parent.ScaleMode = vbTwips Then
'Change twips to pixels
fTextWidth = fTextWidth / Screen.TwipsPerPixelX
End If

If fTextWidth > fExistScrollWidth Then
'Increase width of scroll bar
Call SendMessageA(lbListbox.hwnd, LB_SETHORIZONTALEXTENT, fTextWidth, 0)
End If
End If
ListboxUpdateItem = True

Exit Function

ErrFailed:
Debug.Print "Error in ListboxAddItem: " & lbListbox.Name & " Description: " & Err.Description
ListboxUpdateItem = False
End Function


'Purpose : Adds a horizontal scroll bar to a listbox
'Inputs : lbListbox The listbox to add the scrollbar to.
'Outputs : Returns True on success
'Notes :
'Revisions :
'Assumptions :

Function ListboxAddHorizontalScollBar(lbListbox As ListBox) As Boolean
On Error GoTo ErrFailed
Dim fTextWidth As Single
Dim oParentFont As StdFont, fExistScrollWidth As Single
Dim lThisListItem As Long, fMaxScollWidth As Single, lMaxTextLen As Long
Const LB_SETHORIZONTALEXTENT = &H194, LB_GETHORIZONTALEXTENT = &H193

'Add item to listbox
On Error GoTo ErrFailed
'Set the parent font
Set oParentFont = lbListbox.Parent.font
Set lbListbox.Parent.font = lbListbox.font
Set lbListbox.Parent.font = oParentFont

'Determine max. length of text
For lThisListItem = 0 To lbListbox.ListCount - 1
If Len(lbListbox.list(lThisListItem)) > lMaxTextLen Then
lMaxTextLen = Len(lbListbox.list(lThisListItem))
End If
Next

'Get the text length
fTextWidth = lbListbox.Parent.TextWidth(String(lMaxTextLen + 1, "W")) 'Extra space allows for vertical scroll bar
'Restore the form's font
Set lbListbox.Parent.font = oParentFont

'Get the width of the existing scroll bar
fExistScrollWidth = SendMessage(lbListbox.hwnd, LB_GETHORIZONTALEXTENT, 0, 0)

If lbListbox.Parent.ScaleMode = vbTwips Then
'Change twips to pixels
fTextWidth = fTextWidth / Screen.TwipsPerPixelX
End If

If fTextWidth > fExistScrollWidth Then
'Increase width of scroll bar
Call SendMessage(lbListbox.hwnd, LB_SETHORIZONTALEXTENT, fTextWidth, 0)
End If
ListboxAddHorizontalScollBar = (err.number = 0)

Exit Function

ErrFailed:
Debug.Print err.description
Debug.Assert False
ListboxAddHorizontalScollBar = (err.number = 0)
End Function

Calling ODBC from ADO to connect to thirdparty driver

Dim ADOCN As New ADODB.Connection
Dim ADORS As New ADODB.Recordset
Dim mysql As String
With ADOCN
'here how to call odbc from ADO!
.ConnectionString = "DSN=odbc namet;UID=YOURUSERID;PWD=YOURPASSWORD;"
.Mode = adModeReadOnly
.Open
End With

With ADORS
.CursorLocation = adUseClient
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.ActiveConnection = ADOCN
mysql = "select whatever from my table"
.Source = mysql
.Open
'for good preformance, I did store the record set in variant type variable so I can disconnect from host sooner

.ctiveConnection = Nothing
myrows = .RecordCount
mycola = .Fields.Count
mydata = .GetRows()

'now I can loop through my result

Sending Crystal Reports to MAPI

Dim App as New craxdrt.Application
Dim rpt as craxdrt.Report

Set rpt = App.OpenReport("\\cms_live\Reports\Report Maker
2k1\Admin\ImpBuddyProfile.RPT")

With rpt.ExportOptions
.DestinationType = crEDTEMailMAPI
.FormatType = crEFTPortableDocFormat

.MailToList = "steve"

.MailSubject = "Mail Subject"
.MailMessage = strMessage
End With

With rpt
.DisplayProgressDialog = False
.EnableParameterPrompting = False
.ParameterFields(1).AddCurrentValue "Any Old Value"
.Export False
End With

Finding the position of the first character from a list of characters

The code below is useful when you want to find the position of first character from a list of characters within a string. This would typically be used when looking for carriage returns, eg:

Debug.Print StringFirstFirstChars(sSearch,vbNewline,vbCr,vbLf)

The code below is useful when you want to find the position of first character from a list of characters within a string. This would typically be used when looking for carriage returns, eg:

Debug.Print StringFirstFirstChars(sSearch,vbNewline,vbCr,vbLf)

'Purpose : Finds the position of the first character found in a string from a list of characters.
'Inputs : sSearchIn The string to search for the first instance of a character from the character list
' avChars The list of characters to search through "sSearchIn" for
'Outputs : Returns the position of first instance of a character found in a string from the list of supplied characters,
' or zero if none of the characters are found
'Example : If your wanted to find a line feed, you might use:
' Debug.Print StringFindFirstChar("ABCDEF","B","E","F")
' 'This would return 2, i.e. the position of character "B"
'Revisions :

Function StringFindFirstChar(sSearchIn As String, ParamArray avChars() As Variant) As Long
Dim lPosChar As Long, lPosTest As Long, vChar As Variant

On Error GoTo ErrFailed
If Len(sSearchIn) Then
For Each vChar In avChars
lPosTest = InStr(1, sSearchIn, CStr(vChar))
If lPosTest Then
If lPosChar = 0 Then
lPosChar = lPosTest
ElseIf lPosTest < lPosChar Then
lPosChar = lPosTest
End If
End If
Next
End If
StringFindFirstChar = lPosChar
Exit Function

ErrFailed:
Debug.Print Err.Description
Debug.Assert False
'Try the next line
Resume Next
End Function

Search for a specific string and replace it with another

Function sReplace(SearchLine as String, SearchFor as String, ReplaceWith as String)
Dim vSearchLine as String, found as Integer

found = InStr(SearchLine, SearchFor): vSearchLine = SearchLine
If found <> 0 Then
vSearchLine = ""
If found > 1 Then vSearchLine = Left(SearchLine, found - 1)
vSearchLine = vSearchLine + ReplaceWith
If found + Len(SearchFor) - 1 < Len(SearchLine) Then _
vSearchLine = vSearchLine + Right$(SearchLine, Len(SearchLine) - found - Len(SearchFor) + 1)
end If
sReplace = vSearchLine

End Function

* another routine *


Only 17 lines of code for a super-fast find-and-replace function:

-- start code --

' Copy *both* functions to VBScript or VB application:
' FindReplace and ReplaceFirstInstance
'
Function FindReplace(SourceString, SearchString, ReplaceString)
tmpString1 = SourceString
do Until vFixed
tmpString2 = tmpString1
tmpString1 = ReplaceFirstInstance(tmpString1, SearchString,ReplaceString)
If tmpString1 = tmpString2 Then vFixed = True
Loop
FindReplace = tmpString1
end Function

Function ReplaceFirstInstance(SourceString, SearchString, ReplaceString)
FoundLoc = InStr(1, SourceString, SearchString)
If FoundLoc <> 0 Then
ReplaceFirstInstance = Left(SourceString, FoundLoc - 1) & _
ReplaceString & Right(SourceString, _
Len(SourceString) - (FoundLoc - 1) - Len(SearchString))
Else
ReplaceFirstInstance = SourceString
end If
end Function

--- end code -

Just to clarify, one function is used to go through the entire string and
replace all instances of the search string ("Replace All"). The other
function is used to only replace the first instance of the search string
("Replace"). The former loops the latter until there are no more instances
of the search string.
>


Function FindReplace(SourceString, searchstring, replacestring)
tmpString1 = SourceString
do Until vFixed
tmpString2 = tmpString1
tmpString1 = ReplaceFirstInstance(tmpString1, searchstring,
replacestring)
If tmpString1 = tmpString2 Then vFixed = True
loop
FindReplace = tmpString1
End Function

Function ReplaceFirstInstance(SourceString, searchstring, replacestring)
Static StartLoc '*
If StartLoc = 0 Then StartLoc = 1 '*
FoundLoc = InStr(StartLoc, SourceString, searchstring) '*
If FoundLoc <> 0 Then
ReplaceFirstInstance = Left(SourceString, FoundLoc - 1) & _
replacestring & Right(SourceString, _
Len(SourceString) - (FoundLoc - 1) - Len(searchstring))
StartLoc = FoundLoc + Len(replacestring) '*
Else
StartLoc = 1 '*
ReplaceFirstInstance = SourceString
end If
End Function


Return

Search and Replace Text

To search and replace text in a variable use the following (please read the notes for guidance on how to use this routine).

'Purpose : Searches and replaces all instances of a string within a variable.
'Inputs : sText The string to search.
' sReplaceThis The string to replace.
' sWithThis The replacement string.
' [lNumReplacements] Returns the number of times a replacement was made.
'Outputs : N/A
'Notes : This routines output parameters are passed in ByRef for speed and hence it should be called:
' Dim sOutputText as String 'Create a variable to hold the value in
' sOutputText = "aaaaaa"
' SearchAndReplace sOutputText, "a", "b"
' Debug.Print sOutputText

Sub SearchAndReplace(ByRef sText As String, ByVal sReplaceThis As String, ByVal sWithThis As String, Optional ByRef lNumReplacements As Long)
Dim lPos As Long, lLenOriginal As Long, lLenReplace As Long

lLenOriginal = Len(sReplaceThis)
lLenReplace = Len(sWithThis)

If lLenOriginal Then
lPos = InStr(1, sText, sReplaceThis)
Do While lPos > 0
lNumReplacements = lNumReplacements + 1
If lLenOriginal = lLenReplace Then
Mid$(sText, lPos, Len(sReplaceThis)) = sWithThis
Else
sText = Left$(sText, lPos - 1) & sWithThis & Mid$(sText, lPos + lLenOriginal)
End If
lPos = InStr(lPos + lLenOriginal, sText, sReplaceThis)
Loop
End If
End Sub

Finding the position of the first character from a list of characters

The code below is useful when you want to find the position of first character from a list of characters within a string. This would typically be used when looking for carriage returns, eg:

Debug.Print StringFirstFirstChars(sSearch,vbNewline,vbCr,vbLf)

The code below is useful when you want to find the position of first character from a list of characters within a string. This would typically be used when looking for carriage returns, eg:

Debug.Print StringFirstFirstChars(sSearch,vbNewline,vbCr,vbLf)

'Purpose : Finds the position of the first character found in a string from a list of characters.
'Inputs : sSearchIn The string to search for the first instance of a character from the character list
' avChars The list of characters to search through "sSearchIn" for
'Outputs : Returns the position of first instance of a character found in a string from the list of supplied characters,
' or zero if none of the characters are found
'Example : If your wanted to find a line feed, you might use:
' Debug.Print StringFindFirstChar("ABCDEF","B","E","F")
' 'This would return 2, i.e. the position of character "B"
'Revisions :

Function StringFindFirstChar(sSearchIn As String, ParamArray avChars() As Variant) As Long
Dim lPosChar As Long, lPosTest As Long, vChar As Variant

On Error GoTo ErrFailed
If Len(sSearchIn) Then
For Each vChar In avChars
lPosTest = InStr(1, sSearchIn, CStr(vChar))
If lPosTest Then
If lPosChar = 0 Then
lPosChar = lPosTest
ElseIf lPosTest <>
lPosChar = lPosTest
End If
End If
Next
End If
StringFindFirstChar = lPosChar
Exit Function

ErrFailed:
Debug.Print Err.Description
Debug.Assert False
'Try the next line
Resume Next
End Function

Trin Function : Performing a custom Trim() on an input string

The RTrim, LTrim and Trim functions are useful from removing blank spaces. However, sometimes you want to remove different trailing/leading characters (eg, Remove all the vbNewLine from the start and end of a string). The function below allows you to specify a custom Trim:


'Purpose : Trims trailing a leading characters from a string buffer
'Inputs : sValue The string to trim
' sRemove The character/s to remove from the start/end of the sValue
' [bRtrim] If True removes any matching right hand side chars
' [bLtrim] If True removes any matching left hand side chars
' [eCompare] The method of comparison
'Outputs : Returns the string trimed from the specified characters
'Notes : Trim2("aaaaaBBBBCCCaaaa", "a") returns "BBBBCCC"


Function Trim2(ByVal sValue As String, sRemove As String, Optional bRtrim As Boolean = True, Optional bLTrim As Boolean = True, Optional eCompare As VbCompareMethod = vbBinaryCompare) As String
Dim lPos As Long, lLastChar As Long, lLenRemove As Long
On Error GoTo ErrFailed

lLenRemove = Len(sRemove)

If lLenRemove > 0 And Len(sValue) > 0 Then
If bLTrim Then
'Remove the left hand chars
lPos = 1 - lLenRemove
lLastChar = 1 - lLenRemove

'Loop finding the chars to replace
Do
lPos = InStr(lPos + lLenRemove, sValue, sRemove, eCompare)
If lPos = lLastChar + lLenRemove Then
lLastChar = lPos
Else
'Found all the matching characters
Exit Do
End If
Loop
If lLastChar Then
sValue = Mid$(sValue, lLastChar + lLenRemove)
End If
End If

If bRtrim = True And Len(sValue) > 0 Then
'Remove the right hand chars
lPos = Len(sValue) + 1
lLastChar = lPos

'Loop finding the chars to replace
Do
lPos = InStrRev(sValue, sRemove, lPos - 1, eCompare)
If lPos = lLastChar - lLenRemove Then
lLastChar = lPos
Else
'Found all the matching characters
Exit Do
End If
Loop
If lLastChar Then
sValue = Left$(sValue, lLastChar - 1)
End If
End If
End If
Trim2 = sValue
Exit Function

ErrFailed:
Debug.Print "Error in Trim2: " & Err.Description
Debug.Assert False
End Function

Finding the position of the first character from a list of characters

Debug.Print StringFirstFirstChars(sSearch,vbNewline,vbCr,vbLf)

'Purpose : Finds the position of the first character found in a string from a list of characters.
'Inputs : sSearchIn The string to search for the first instance of a character from the character list
' avChars The list of characters to search through "sSearchIn" for
'Outputs : Returns the position of first instance of a character found in a string from the list of supplied characters,
' or zero if none of the characters are found
'Example : If your wanted to find a line feed, you might use:
' Debug.Print StringFindFirstChar("ABCDEF","B","E","F")
' 'This would return 2, i.e. the position of character "B"
'Revisions :

Function StringFindFirstChar(sSearchIn As String, ParamArray avChars() As Variant) As Long
Dim lPosChar As Long, lPosTest As Long, vChar As Variant

On Error GoTo ErrFailed
If Len(sSearchIn) Then
For Each vChar In avChars
lPosTest = InStr(1, sSearchIn, CStr(vChar))
If lPosTest Then
If lPosChar = 0 Then
lPosChar = lPosTest
ElseIf lPosTest <>
lPosChar = lPosTest
End If
End If
Next
End If
StringFindFirstChar = lPosChar
Exit Function

ErrFailed:
Debug.Print Err.Description
Debug.Assert False
'Try the next line
Resume Next
End Function

Strings sample source codes

'Purpose : Counts the number of instances of a specified string within another string.
'Inputs : sText The string to search in.
' sSearchFor The string to search for.
' [bIgnoreCase] If True does a case insensitive comparison.
' [sIgnoreText] If specified will ignore items between subsequent instances of
' "sSearchFor" which match this text (see example 2)
'Outputs : Returns the number of instances of the string.
'Example : eg. Find the instances of the character "A" within a string
' 1.
' Debug.Print CountString("ABCAA","A")
' Returns 3.

' Now find how many lines of data are contained within a string, ignoring any blanks lines.
' 2.
' Debug.Print CountString("red" & vbnewline & "yellow" & vbnewline & vbnewline & "IS" & vbnewline & "GREAT!" & vbnewline,vbnewline,,"")
' Returns 3 (NOT 4).
'Revisions :

Function CountString(sText As String, sSearchFor As String, Optional bIgnoreCase As Boolean = True, Optional sIgnoreText As String) As Long
Dim asItems() As String, lThisItem As Long
On Error GoTo ErrFailed

If bIgnoreCase Then
asItems = Split(UCase$(sText), UCase$(sSearchFor))
CountString = UBound(asItems)
Else
asItems = Split(sText, sSearchFor)
CountString = UBound(asItems)
End If

If Len(sIgnoreText) Then
'Deduct any items which contain the specified "sIgnoreText"
For lThisItem = 0 To UBound(asItems) - 1
If asItems(lThisItem) = sIgnoreText Then
'Deduct this item
CountString = CountString - 1
End If
Next
End If

Exit Function

ErrFailed:
'Error occurred
Debug.Print "Error in CountString " & Err.Description
Debug.Assert False
CountString = 0
End Function

Convert Hex string to Long

converts a hexadecimal string into a long
Returns zero if error occurs


Public Function ConvertHexToLong(sHex As String) As Long

On Error GoTo errHandler:
Dim n As Integer
Dim sTemp As String * 1
Dim nTemp As Integer
Dim nFinal() As Integer
Dim bNegative As Boolean
ReDim nFinal(0)
If LenB(sHex) = 0 Then
ConvertHexToLong = 0
Exit Function
End If
bNegative = False
For n = Len(sHex) To 1 Step -1
sTemp = Mid$(sHex, n, 1)
nTemp = Val(sTemp)
If nTemp = 0 Then
Select Case UCase(sTemp)
Case "A"
nTemp = 10
Case "B"
nTemp = 11
Case "C"
nTemp = 12
Case "D"
nTemp = 13
Case "E"
nTemp = 14
Case "F"
nTemp = 15
Case "-"
bNegative = True
Case Else
nTemp = 0
End Select
End If
ReDim Preserve nFinal(UBound(nFinal) + 1)
nFinal(UBound(nFinal)) = nTemp
Next
ConvertHexToLong = nFinal(1)
For n = 2 To UBound(nFinal)
ConvertHexToLong = ConvertHexToLong + (nFinal(n) * (4 ^ (n * 2 - 2)))
Next
If bNegative Then ConvertHexToLong = ConvertHexToLong - (ConvertHexToLong * 2)
Exit Function
errHandler:

ConvertHexToLong = 0

End Function

Convert an array to a string and a string to an array

Option Explicit

'Purpose : Converts a 1d or 2d array to a deliminated String
'Inputs : avInArray The array to convert to a string
' sDelimRows Delimeter to seperate rows
' sDelimCols Delimeter to seperate columns (for 2d arrays)
'Outputs : A string containing all the elements of avInArray seperated by sDelimRows
'Notes :

Function ArrayToString(avInArray As Variant, Optional sDelimRows As String = "æ", Optional sDelimCols As String = "") As String
Dim lThisItem As Long, lNumItems As Long, lFirstRow As Long, lLastRow As Long
Dim lThisRow As Long, lThisCol As Long, lFirstCol As Long, lLastCol As Long

On Error GoTo ExitProc
Select Case ArrayNumDimensions(avInArray)
Case 0
'Empty array
Case 1
'1D Array
For lThisItem = LBound(avInArray) To UBound(avInArray)
ArrayToString = ArrayToString & (CStr(avInArray(lThisItem)) & sDelimRows) 'Join the small to the large
Next
Case 2
'2D Arrays
lFirstRow = LBound(avInArray, 2)
lLastRow = UBound(avInArray, 2)
lFirstCol = LBound(avInArray, 1)
lLastCol = UBound(avInArray, 1)
'Loop over each column then row to create the result string
For lThisCol = lFirstCol To lLastCol
For lThisRow = lFirstRow To lLastRow
ArrayToString = ArrayToString & (CStr(avInArray(lThisCol, lThisRow)) & sDelimRows) 'Join the small to the large
Next
ArrayToString = ArrayToString & sDelimCols
Next
Case Else
MsgBox "ArrayToString: Invalid array structure"
End Select

ExitProc:
On Error GoTo 0
End Function

'Purpose : Converts a string to string array.
'Inputs : sThisString The string to convert to an array
' asResults String array containing results
' sDelimRows Delimeter to seperate rows
' sDelimCols Delimeter to seperate columns (for 2d arrays)
'Outputs : N/A
'Notes :
'Revisions :

Sub StringToArray(ByVal sThisString As String, asResults() As String, Optional sDelimRows As String = "æ", Optional sDelimCols As String = "")
Dim lPos1dDel As Long, lPos2dDel As Long, lLenString As Long, lColSepLen As Long
Dim lLastPos As Long, lNumCols As Long, lThisRow As Long, lThisCol As Long, lRowSepLen As Long

lLenString = Len(sThisString)

If lLenString Then
lLastPos = 1
lPos1dDel = InStr(1, sThisString, sDelimRows)
lPos2dDel = InStr(1, sThisString, sDelimCols)
lNumCols = StringCount(sThisString, sDelimCols, vbTextCompare)
lRowSepLen = Len(sDelimRows)

If lNumCols Then
'Convert a 2d string
lThisCol = 1
lColSepLen = Len(sDelimCols)
'Create buffer to store results
On Error GoTo 0
ReDim asResults(1 To lNumCols, 1 To Int(lLenString / 2))
Do While lPos1dDel
lThisRow = lThisRow + 1
If lPos1dDel > lPos2dDel Then
'Next Column
lThisCol = lThisCol + 1
lThisRow = 0
lPos2dDel = InStr(lPos2dDel + 1, sThisString, sDelimCols)
lLastPos = lLastPos + lColSepLen
Else
'Store Row
asResults(lThisCol, lThisRow) = Mid$(sThisString, lLastPos, lPos1dDel - lLastPos)
lLastPos = lPos1dDel + lRowSepLen
End If
lPos1dDel = InStr(lLastPos, sThisString, sDelimRows)
Loop
ReDim Preserve asResults(1 To lNumCols, 1 To lThisRow)
Else
'Convert a 1d string
'Create buffer to store results
ReDim asResults(1 To Int(lLenString / 2))
lPos1dDel = InStr(lLastPos, sThisString, sDelimRows)
Do While lPos1dDel
lThisRow = lThisRow + 1
asResults(lThisRow) = Mid$(sThisString, lLastPos, lPos1dDel - lLastPos)
lLastPos = lPos1dDel + lRowSepLen
lPos1dDel = InStr(lLastPos, sThisString, sDelimRows)
Loop
ReDim Preserve asResults(1 To lThisRow)
End If
Else
Erase asResults
End If
End Sub

'Purpose : Calculates the number of dimensions in an array
'Inputs : avInArray. The array to evaluate.
'Outputs : The number of dimensions the array has.
'Notes :

Function ArrayNumDimensions(avInArray As Variant) As Long
Dim lNumDims As Long

If IsArray(avInArray) Then
On Error GoTo ExitSub
Do
lNumDims = UBound(avInArray, ArrayNumDimensions + 1)
ArrayNumDimensions = ArrayNumDimensions + 1
Loop
End If

ExitSub:
On Error GoTo 0
End Function

'Purpose : Count the number of matching instances of one string within another
'Inputs : sSearchString The string to search
' sForItem The string to search for
' [tCompare] The method of comparison. Defaults to a case insensative search.
' Can also specify vbBinaryCompare.
'Outputs : Returns the number of instances of the sForItem within sSearchString
'Notes :
'Revisions :

Function StringCount(sSearchString As String, sForItem As String, Optional tCompare As Long = vbTextCompare) As Long
Dim lPos As Long, lLenItem As Long

lLenItem = Len(sForItem)
Do
lPos = InStr(lPos + lLenItem, sSearchString, sForItem, tCompare)
If lPos Then
StringCount = StringCount + 1
Else
Exit Do
End If
Loop
End Function

Add an icon to the systemtray

BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "clsSysTray"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
'
'clsSysTray
'
'WHO, WHAT, WHERE:
' provided 'as is', no warranty, no guarantees
'
'TACTICS:
' create object Dim systray as Object
' set systray = New clsSysTray
' set icon systray.Icon = frmMAIN.Icon
' set tooltip text systray.ToolTip = "My System Tray Icon !"
' set owner control systray.OwnerControl = frmMAIN.picAnimate
' activate it systray.Add
'...
' now, when the user clicks on the the created icon, the corresponding MOUSEMOVE event
' of the owning control is activated. Here a sample of such code: '
private Sub picAnimate_MouseMove(Button as Integer, _ '
Shift as Integer, X as Single, Y as Single) '
Select case Hex(X) ' case "1E3C" 'Right-Button-Down
' MsgBox "Right-Button-Down" '
case "1830" 'Right-Button-Down LARGE FONTS '
MsgBox "Right-Button-Down LARGE FONTS" ' Case
"1E0F" 'Left-Button-Down ' MsgBox
"Left-Button-Down" ' case "1E2D"
'Left-Button-Double-Click ' MsgBox
"Left-Button-Double-Click" ' case "1824"
'Left-Button-Double-Click LARGE FONTS ' MsgBox
"Left-Button-Double-Click LARGE FONTS" ' case "1E5A"
'Right-Button-Double-Click ' MsgBox
"Right-Button-Double-Click" ' end Select '
end Sub '... 'when active, you can do the following ' modify the icon
shown systray.Icon = frmSetup.Icon ' modify the tooltip text systray.ToolTip
= "Modified Text !" ' remove the icon systray.Remove ' (this is not
done automatic when your program ends !) ' ' Option Explicit private Type
NOTIFYICONDATA_TYPE
cbSize as Long
hWnd as Long
uID as Long
uFlags as Long
uCallbackMessage as Long
hIcon as Long
szTip as String * 64
End Type

Private Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" _
(ByVal dwMessage as Long, lpData as NOTIFYICONDATA_TYPE) as Long

Private mvarSysTray as NOTIFYICONDATA_TYPE
Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2
Private Const NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4
Private Const WM_MOUSEMOVE = &H200

Private blnIsActive as Boolean 'status flag
Private blnOwnerControlIsSet as Boolean 'status flag
Private blnIconIsSet as Boolean 'status flag
Private mvarOwnerControl as object 'local copy

Public Property Let OwnerControl(ByVal vData as Object)
'calling program should set owning control
If blnIsActive Then
MsgBox "WARNING: clsSysTray cannot change owner control for an icon when active",
vbExclamation
Else
set mvarOwnerControl = vData
blnOwnerControlIsSet = True
end If
End Property

Public Property Get OwnerControl() as Object
'if calling program wants to know it
set OwnerControl = mvarOwnerControl
End Property

Public Property Let ToolTip(ByVal vData as String)
'calling program can set ToolTip (optional)
If vData = "" Then
mvarSysTray.szTip = vbNullChar
Else
mvarSysTray.szTip = " " & vData & " " & vbNullChar
end If
'modify shown text if active
If blnIsActive Then Shell_NotifyIcon NIM_MODIFY, mvarSysTray
End Property

Public Property Get ToolTip() as String
Attribute ToolTip.VB_UserMemId = 0
'if calling program wants to know it
ToolTip = mvarSysTray.szTip
End Property

Public Property Let Icon(ByVal vData as Object)
'calling program should set icon
mvarSysTray.hIcon = vData
'set status
blnIconIsSet = True
'modify shown icon if active
If blnIsActive Then Shell_NotifyIcon NIM_MODIFY, mvarSysTray
End Property

Public Property Get Icon() as Object
'if calling program wants to know it
set Icon = mvarIcon
End Property

Public Function Remove() as Boolean
'to remove the icon from the system tray
'NOT done automatic if your program ends !
If blnIsActive = True Then
Shell_NotifyIcon NIM_DELETE, mvarSysTray
'set status
blnIsActive = False
end If
Remove = True
End Function

Public Function Add() as Boolean
'verify environment
If blnIsActive Then MsgBox "ERROR: clsSysTray is already acive", vbExclamation
If Not blnIconIsSet Then MsgBox "ERROR: clsSysTray cannot activate when the icon has
not been set", vbExclamation If Not blnOwnerControlIsSet Then MsgBox "ERROR:
clsSysTray cannot activate when the owner control has not been set", vbExclamation
'set other variables mvarSysTray.cbSize = Len(mvarSysTray) mvarSysTray.hWnd =
mvarOwnerControl.hWnd mvarSysTray.uID = 1& mvarSysTray.uFlags = NIF_MESSAGE Or
NIF_ICON Or NIF_TIP mvarSysTray.uCallbackMessage = WM_MOUSEMOVE Shell_NotifyIcon
NIM_ADD, mvarSysTray 'set status blnIsActive = True Add = True
End Function


Return

Show tooltips on controls

'tooltips bij controls
'make a form with a lable called 'lbToolTip'
'make it invisible; set the background and foreground color as you wish
'put a command.control called 'cmdButton'

Sub cmdButton_MouseMove(Button as Integer, shift as Integer, X as Single, Y as Single)
Call ShowToolTip("commandbutton", cmdButton)

End Sub

Sub ShowToolTip(tekst$, X as Control)

lbToolTip.Caption = tekst$
lbToolTip.Left = X.Left + (X.Width / 2)
lbToolTip.Top = X.Top + X.Height + 100
lbToolTip.Visible = True

End Sub

'for disaparance of the tooltip

Sub Form_MouseMove(Button as Integer, shift as Integer, X as Single, Y as Single)
If lbToolTip.Visible Then lbToolTip.Visible = False

End Sub

'if you want you can put the same line of code in other MouseMove events

Return

Use of the Toolbar Control

'first Check that have add the custom controls
'Microsoft Windows Common Controls -> Comctl32.ocx

'step 1:
'From componant add the control Imagelist
'set the propertie Custom
'General: size
'Images: click 'Insert Picture' to add the necessary pictures

'step 2:
'add the control Toolbar
'set the propertie Custom
'General: Imagelist
'Buttons: to add a button just click on 'Insert Button'
'at 'Image' you need to set the index-number of the wanted picture
'this number is the same as the pictures index in the ImageList
'place - if you want - a ToolTipText
'or if you just want text place it behind the propertie 'Caption'
'click on 'OKE' when you are finished

'and the toolbar is ready

'now the code
'put it under the

Private sub Toolbar1_ButtonClick(ByVal Button as Button)
select case Button.Index
case 1 'click on the first button
case 2 'click on the second button
case 3 'click on the third button
'and so on
end Select

End Sub

'you can change most properties a runtime

Toolbar1.Buttons(1).Visible = False 'makes the first button disappear
Toolbar1.Buttons(1).ToolTipText = "an other one" 'change the tooltip text of the first button
Toolbar1.Buttons(2).Enabled = False 'disable the second button
Toolbar1.Buttons(3).Caption = "KATHER" 'change the caption of the third button

'BTW you cannot set the property Toolbar1.ShowTips at runtime!

Return

how to save and load images to and from a database

Option Explicit

Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long

'Purpose : Saves pictures in image boxes (or similiar) to a field in a recordset
'Inputs : oPictureControl A control containing an image
' adoRS ADO recordset to add the image to
' sFieldName The field name in adoRS, to add the image to
'Outputs : Returns True if succeeded in updating the recordset
'Notes : The field specified in sFieldName, must have a binary field type (ie. OLE Object in access)
' Save the image at the currect cursor location in the recordset.
'Revisions :

Public Function SavePictureToDB(oPictureControl As Object, adoRS As ADODB.Recordset, sFieldName As String) As Boolean
Dim oPict As StdPicture
Dim sDir As String, sTempFile As String
Dim iFileNum As Integer
Dim lFileLength As Long
Dim abBytes() As Byte
Dim iCtr As Integer

On Error GoTo ErrHandler

Set oPict = oPictureControl.Picture
If oPict Is Nothing Then
SavePictureToDB = False
Exit Function
End If

'Save picture to temp file
sTempFile = FileGetTempName
SavePicture oPict, sTempFile

'read file contents to byte array
iFileNum = FreeFile
Open sTempFile For Binary Access Read As #iFileNum
lFileLength = LOF(iFileNum)
ReDim abBytes(lFileLength)
Get #iFileNum, , abBytes()
'put byte array contents into db field
adoRS.Fields(sFieldName).AppendChunk abBytes()
Close #iFileNum

'Don't return false if file can't be deleted
On Error Resume Next
Kill sTempFile
SavePictureToDB = True
Exit Function

ErrHandler:
SavePictureToDB = False
Debug.Print Err.Description
End Function


'Purpose : Loads a Picture, saved as binary data in a database, from a recordset into a picture control.
'Inputs : oPictureControl A control to load the image into
' adoRS ADO recordset to add the image to
' sFieldName The field name in adoRS, to add the image to
'Outputs : Returns True if succeeded in loading the image
'Notes : Loads the image at the currect cursor location in the recordset.


Public Function LoadPictureFromDB(oPictureControl As Object, adoRS As ADODB.Recordset, sFieldName As String) As Boolean
Dim oPict As StdPicture
Dim sDir As String
Dim sTempFile As String
Dim iFileNum As Integer
Dim lFileLength As Long
Dim abBytes() As Byte
Dim iCtr As Integer

On Error GoTo ErrHandler
sTempFile = FileGetTempName

iFileNum = FreeFile
Open sTempFile For Binary As #iFileNum
lFileLength = LenB(adoRS(sFieldName))

abBytes = adoRS(sFieldName).GetChunk(lFileLength)
Put #iFileNum, , abBytes()
Close #iFileNum

oPictureControl.Picture = LoadPicture(sTempFile)

Kill sTempFile
LoadPictureFromDB = True
Exit Function

ErrHandler:
LoadPictureFromDB = False
Debug.Print Err.Description
End Function


'Purpose : The FileGetTempName function returns a name of a temporary file.
'Inputs : [sFilePrefix] The prefix of the file name.
'Outputs : Returns the name of the next free temporary file name (and path).
'Notes : The filename is the concatenation of specified path and prefix strings,
' a hexadecimal string formed from a specified integer, and the .TMP extension


Function FileGetTempName(Optional sFilePrefix As String = "TMP") As String
Dim sTemp As String * 260, lngLen As Long
Static ssTempPath As String

If LenB(ssTempPath) = 0 Then
'Get the temporary path
lngLen = GetTempPath(260, sTemp)
'strip the rest of the buffer
ssTempPath = Left$(sTemp, lngLen)
If Right$(ssTempPath, 1) <> "\" Then
ssTempPath = ssTempPath & "\"
End If
End If

'Get a temporary filename
lngLen = GetTempFileName(ssTempPath, sFilePrefix, 0, sTemp)
'Remove all the unnecessary chr$(0)'s
FileGetTempName = Left$(sTemp, InStr(1, sTemp, Chr$(0)) - 1)
End Function


'SAMPLE USAGE
'NOTE : Add a PictureBox control to a form before running this code
Sub TestLoadPicture()
Dim sConn As String
Dim oConn As New ADODB.Connection
Dim oRs As New ADODB.Recordset

On Error GoTo ErrFailed
sConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\MyDb.MDB;Persist Security Info=False"

oConn.Open sConn
oRs.Open "SELECT * FROM MyTable", oConn, adOpenKeyset, adLockOptimistic
If oRs.EOF = False Then
LoadPictureFromDB Picture1, oRs, "MyFieldName"
End If
oRs.Close
Exit Sub
ErrFailed:
MsgBox "Error " & Err.Description
End Sub

'SAMPLE USAGE
'NOTE : Add a PictureBox control to a form before running this code
Sub TestSavePicture()
Dim sConn As String
Dim oConn As New ADODB.Connection
Dim oRs As New ADODB.Recordset

On Error GoTo ErrFailed
sConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\MyDb.MDB;Persist Security Info=False"

oConn.Open sConn
oRs.Open "SELECT * FROM MYTABLE", oConn, adOpenKeyset, adLockOptimistic
If oRs.EOF = False Then
oRs.AddNew
SavePictureToDB Picture1, oRs, "MYFIELD"
oRs.Update
End If
oRs.Close
Exit Sub
ErrFailed:
MsgBox "Error " & Err.Description
End Sub

how to update a database using a disconnected recordset

Option Explicit

'Purpose : Open a disconnected recordset.
'Inputs : oCon The connection to open the recordset on.
' sSQL The SQL to open the recordset with.
' oRS The resulting recordset.
'Outputs : Returns True if the recordset was opened and contained results.


Public Function RSOpenDisconnected(oCon As ADODB.Connection, sSQL As String, oRS As ADODB.Recordset, Optional eLocking As LockTypeEnum = adLockBatchOptimistic) As Boolean
On Error GoTo ErrFailed
If oCon.State = adStateOpen Then
'Connection is open
Set oRS = New ADODB.Recordset
'Set cursor to client (i.e. Local Machine)
oRS.CursorLocation = adUseClient
'Open Recordset (NB. The CursorType is always "adOpenStatic" for client-side cursors)
oRS.Open sSQL, oCon, adOpenStatic, eLocking
'Set connection to nothing (disconnect recordset)
Set oRS.ActiveConnection = Nothing
If oRS.EOF = False Then
'Return results
RSOpenDisconnected = True
Else
'Empty recorset
RSOpenDisconnected = False
End If
End If
Exit Function

ErrFailed:
Debug.Print "Failed to open recordset: " & Err.Description
Debug.Assert False 'Error occurred
RSOpenDisconnected = False
On Error GoTo 0
End Function


'Demonstrates how to open a disconnected recordset and then update a value in
'a field in the database.
Sub Test()
Dim oRS As ADODB.Recordset
Dim oConn As ADODB.Connection
Const clRecordUpdated As Long = -2147217864

On Error GoTo ErrUpdateFailed
'Open a connection to a database
Set oConn = New ADODB.Connection
oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\MyPath\MyDatabase.mdb; Persist Security Info=False"
'Open a disconnected recordset
RSOpenDisconnected oConn, "Select * from tblHoliday", oRS
'Update a field in the recordset
oRS.Fields("MyField").Value = "My New Value"
'Reconnect to database
Set oRS.ActiveConnection = oConn

'Update table
oRS.UpdateBatch

'Close the connection
oRS.Close
Set oRS = Nothing
oConn.Close
Set oConn = Nothing

Exit Sub

ErrUpdateFailed:
If Err.Number = clRecordUpdated Then
MsgBox "The record you altered has been altered by another user... " & vbNewLine & Err.Description, vbCritical
Else
MsgBox "Error in disconnected update routine... " & vbNewLine & Err.Description, vbCritical
End If
End Sub

Use of the ProgressBar Control

Private sub Form_Load()
Me.Show
Timer1.Interval = 1000
Timer1.Enabled = True

End Sub

Private sub Timer1_Timer()

PauseTime = 5 ' set duration
ProgressBar1.Max = ((PauseTime + 1) * Timer1.Interval)

start = timer ' set start time.
do While timer < start + PauseTime
ProgressBar1.Value = ProgressBar1.Value + 10
DoEvents ' Yield to other processes.
Loop
Finish = timer ' set end time.
TotalTime = Finish - start ' Calculate total time.
MsgBox "Paused for " & TotalTime & " seconds"
Timer1.Enabled = False

End Sub


Return

Microsoft DataGrid Control 6.0

DataGrid control is the not the default item in the Visual Basic control toolbox, you have add it from the VB6 components. To add the DataGrid control, click on the project in the menu bar and select components where a dialog box that displays all the available VB6 components. Select Microsoft DataGrid Control 6.0 by clicking the checkbox beside this item. Before you exit the dialog box, you also need to select the Microsoft ADO data control so that you are able to access the database. Lastly, click on the OK button to exit the dialog box. Now you should be able to see that the DataGrid control and the ADO data control are added to the toolbox. The next step is to drag the DataGrid control and the ADO data control into the form.

Before you proceed , you need to create a database file using Microsoft Access. Here I created a file to store my the information of my books and I name the table book.
Now you need to connect the database to the ADO data control. To do that, right click on the ADO data control and select the ADODC properties
Next click on the Build button and the Data Link Properties dialog box will appear . In this dialog box, select the database file you have created, in my case, the file name is books.mdb. Press test connection to see whether the connection is successful. If the connection is successful, click OK to return to the ADODC property pages dialog box. At the ADODC property pages dialog box, click on the Recordsource tab and select 2-adCmdTable under command type and select book as the table name, then click OK.
Finally you need to display the data in the DataGrid control. To accomplish this, go to the properties window and set the DataSource property of the DataGrid to Adodc1. You can also permit the user to add and edit your records by setting the AllowUpdate property to True. If you set this property to false, the user cannot edit the records.

ADODC in VB , Creating VB database applications using ADO control

Data control is not a very flexible tool as it could only work with limited kinds of data and must work strictly in the Visual Basic environment. To overcome these limitations, we can use a much more powerful data control in Visual Basic, known as ADO control. ADO stands for ActiveX data objects. As ADO is ActiveX-based, it can work in different platforms (different computer systems) and different programming languages. Besides, it can access many different kinds of data such as data displayed in the Internet browsers, email text and even graphics other than the usual relational and non relational database information.

To be able to use ADO data control, you need to insert it into the toolbox. To do this, simply press Ctrl+T to open the components dialog box and select Microsoft ActiveX Data Control 6. After this, you can proceed to build your ADO-based VB database applications.

The following example will illustrate how to build a relatively powerful database application using ADO data control. First of all, name the new form as frmBookTitle and change its caption to Book Titles- ADO Application. Secondly, insert the ADO data control and name it as adoBooks and change its caption to book. Next, insert the necessary labels, text boxes and command buttons. The runtime interface of this program is shown in the diagram below, it allows adding and deletion as well as updating and browsing of data.

To be able to access and manage a database, you need to connect the ADO data control to a database file. We are going to use POP.MDB that comes with VB6. To connect ADO to this database file , follow the steps below:

a) Click on the ADO control on the form and open up the properties window.

b) Click on the ConnectionString property, the following dialog box will appear.

when the dialog box appear, select the Use Connection String's Option. Next, click build and at the Data Link dialog box, double-Click the option labeled Microsoft Jet 3.51 OLE DB provider.

After that, click the Next button to select the file POP.MDB. You can click on Text Connection to ensure proper connection of the database file. Click OK to finish the connection.

Finally, click on the RecordSource property and set the command type to adCmd Table and Table name to Titles. Now you are ready to use the database file.


Now, you need to write code for all the command buttons. After which, you can make the ADO control invisible.

　

　

For the Save button, the program codes are as follow:

Private Sub cmdSave_Click()

adoBooks.Recordset.Fields("Title") = txtTitle.Text
adoBooks.Recordset.Fields("Year Published") = txtPub.Text
adoBooks.Recordset.Fields("ISBN") = txtISBN.Text
adoBooks.Recordset.Fields("PubID") = txtPubID.Text
adoBooks.Recordset.Fields("Subject") = txtSubject.Text
adoBooks.Recordset.Update

End Sub

For the Add button, the program codes are as follow:

Private Sub cmdAdd_Click()

adoBooks.Recordset.AddNew

End Sub

For the Delete button, the program codes are as follow:

Private Sub cmdDelete_Click()

Confirm = MsgBox("Are you sure you want to delete this record?", vbYesNo, "Deletion Confirmation")
If Confirm = vbYes Then
adoBooks.Recordset.Delete
MsgBox "Record Deleted!", , "Message"
Else
MsgBox "Record Not Deleted!", , "Message"
End If

End Sub
　

For the Cancel button, the program codes are as follow:

Private Sub cmdCancel_Click()

txtTitle.Text = ""
txtPub.Text = ""
txtPubID.Text = ""
txtISBN.Text = ""
txtSubject.Text = ""

End Sub

For the Previous (<) button, the program codes are

Private Sub cmdPrev_Click()


If Not adoBooks.Recordset.BOF Then
adoBooks.Recordset.MovePrevious
If adoBooks.Recordset.BOF Then
adoBooks.Recordset.MoveNext
End If
End If



End Sub

For the Next(>) button, the program codes are

Private Sub cmdNext_Click()


If Not adoBooks.Recordset.EOF Then
adoBooks.Recordset.MoveNext
If adoBooks.Recordset.EOF Then
adoBooks.Recordset.MovePrevious
End If
End If

End Sub

Arrays In VB

By definition, an array is a list of variables, all with the same data type and name. When we work with a single item, we only need to use one variable. However, if we have a list of items which are of similar type to deal with, we need to declare an array of variables instead of using a variable for each item. For example, if we need to enter one hundred names, we might have difficulty in declaring 100 different names, this is a waste of time and efforts. So, instead of declaring one hundred different variables, we need to declare only one array. We differentiate each item in the array by using subscript, the index value of each item, for example name(1), name(2),name(3) .......etc. , which will make declaring variables streamline and much systematic.

An array can be one dimensional or multidimensional. One dimensional array is like a list of items or a table that consists of one row of items or one column of items. A twodimensional array will be a table of items that make up of rows and columns. While the format for a one dimensional array is ArrayName(x), the format for a two dimensional array is ArrayName(x,y) while a three dimensional array is ArrayName(x,y,z) . Normally it is sufficient to use one dimensional and two dimensional array ,you only need to use higher dimensional arrays if you need with engineering problems or even some accounting problems.Let me illustrates the the arrays with tables.

Declaring Arrays

We could use Public or Dim statement to declare an array just as the way we declare a single variable. The Public statement declares an array that can be used throughout an application while the Dim statement declare an array that could be used only in a local procedure.

The general format to declare a one dimensional array is as follow:

Dim arrayName(subs) as dataType

where subs indicates the last subscript in the array.

Dim Count(100 to 500) as Integer



declares an array that consists of the first element starting from Count(100) and ends at Count(500)


The general format to declare a two dimensional array is as follow:



Dim ArrayName(Sub1,Sub2) as dataType

The code

Dim studentName(10) As String
Dim num As Integer

Private Sub addName()
For num = 1 To 10
studentName(num) = InputBox("Enter the student name", "Enter Name", "", 1500, 4500)
If studentName(num) <> "" Then
Form1.Print studentName(num)
Else
End
End If

Next
End Sub



*************************************

Dim studentName(10) As String
Dim num As Integer

Private Sub addName( )
For num = 1 To 10
studentName(num) = InputBox("Enter the student name")
List1.AddItem studentName(num)
Next
End Sub
Private Sub Start_Click()
addName

End Sub


The above program accepts data entry through an input box and displays the entries in the form itself. As you can see, this program will only allows a user to enter 10 names each time he click on the start button.

Creating User-Defined Functions

The general format of a function is as follows:

Public Function functionName (Arg As dataType,..........) As dataType

or

Private Function functionName (Arg As dataType,..........) As dataType

* Public indicates that the function is applicable to the whole project and
Private indicates that the function is only applicable to a certain module or procedure.




Example 14.1

In this example, a user can calculate the future value of a certain amount of money he has today based on the interest rate and the number of years from now, supposing he will invest this amount of money somewhere .The calculation is based on the compound interest rate.



The code

Public Function FV(PV As Variant, i As Variant, n As Variant) As Variant

'Formula to calculate Future Value(FV)
'PV denotes Present Value
FV = PV * (1 + i / 100) ^ n

End Function

Private Sub compute_Click()

'This procedure will calculate Future Value
Dim FutureVal As Variant
Dim PresentVal As Variant
Dim interest As Variant
Dim period As Variant
PresentVal = PV.Text
interest = rate.Text
period = years.Text

'calling the funciton

FutureVal = FV(PresentVal, interest, period)
MsgBox ("The Future Value is " & FutureVal)

End Sub



******************************

The Code



Public Function grade(mark As Variant) As String

Select Case mark
Case Is >= 80
grade = "A"
Case Is >= 70
grade = "B"
Case Is >= 60
grade = "C"
Case Is >= 50
grade = "D"
Case Is >= 40
grade = "E"
Case Else
grade = "F"
End Select

End Function



Private Sub compute_Click()

grading.Caption = grade(mark)



End Sub

String Manipulation Functions In VB

(i)The Len Function



The length function returns an integer value which is the length of a phrase or a sentence, including the empty spaces. The format is

Len (“Phrase”)

For example,

Len (VisualBasic) = 11 and Len (welcome to VB tutorial) = 22

The Len function can also return the number of digits or memory locations of a number that is stored in the computer. For example,

Private sub Form_Activate ( )

X=sqr (16)

Y=1234

Z#=10#

Print Len(x), Len(y), and Len (z)

End Sub

will produce the output 1, 4 , 8. The reason why the last value is 8 is because z# is a double precision number and so it is allocated more memory spaces.

(ii) The Right Function

The Right function extracts the right portion of a phrase. The format is

Right (“Phrase”, n)

Where n is the starting position from the right of the phase where the portion of the phrase is going to be extracted. For example,

Right(“Visual Basic”, 4) = asic

(iii)The Left Function

The Left$ function extract the left portion of a phrase. The format is

Left(“Phrase”, n)

Where n is the starting position from the left of the phase where the portion of the phrase is going to be extracted. For example,

Left (“Visual Basic”, 4) = Visu

(iv) The Ltrim Function

The Ltrim function trims the empty spaces of the left portion of the phrase. The format is

Ltrim(“Phrase”)

.For example,

Ltrim (“ Visual Basic”, 4)= Visual basic

(v) The Rtrim Function

The Rtrim function trims the empty spaces of the right portion of the phrase. The format is

Rtrim(“Phrase”)

.For example,

Rtrim (“Visual Basic ”, 4) = Visual basic

(vi) The Trim function



The Ttrim function trims the empty spaces on both side of the phrase. The format is

Trim(“Phrase”)

.For example,

Trim (“ Visual Basic ”) = Visual basic

(viii) The Mid Function



The Mid function extracts a substring from the original phrase or string. It takes the following format:

Mid(phrase, position, n)

Where position is the starting position of the phrase from which the extraction process will start and n is the number of characters to be extracted. For example,

Mid(“Visual Basic”, 3, 6) = ual Bas

(ix) The InStr function



The InStr function looks for a phrase that is embedded within the original phrase and returns the starting position of the embedded phrase. The format is

Instr (n, original phase, embedded phrase)

Where n is the position where the Instr function will begin to look for the embedded phrase. For example

Instr(1, “Visual Basic”,” Basic”)=8

(x) The Ucase and the Lcase functions



The Ucase function converts all the characters of a string to capital letters. On the other hand, the Lcase function converts all the characters of a string to small letters. For example,

Ucase(“Visual Basic”) =VISUAL BASiC

Lcase(“Visual Basic”) =visual basic


(xi) The Str and Val functions



The Str is the function that converts a number to a string while the Val function converts a string to a number. The two functions are important when we need to perform mathematical operations.


(xii) The Chr and the Asc functions

The Chr function returns the string that corresponds to an ASCII code while the Asc function converts an ASCII character or symbol to the corresponding ASCII code. ASCII stands for “American Standard Code for Information Interchange”. Altogether there are 255 ASCII codes and as many ASCII characters. Some of the characters may not be displayed as they may represent some actions such as the pressing of a key or produce a beep sound. The format of the Chr function is

Chr(charcode)

and the format of the Asc function is

Asc(Character)

The following are some examples:

Chr(65)=A, Chr(122)=z, Chr(37)=% , Asc(“B”)=66, Asc(“&”)=38

Mathematical Functions In VB

VB is rich of variuos inbuilt functions. The mathematical functions are very useful and important in programming because very often we need to deal with mathematical concepts in programming such as chance and probability, variables, mathematical logics, calculations, coordinates, time intervals and etc. The common mathematical functions in Visual Basic are Rnd, Sqr, Int, Abs, Exp, Log, Sin, Cos, Tan , Atn, Fix and Round.

(i) Rnd is very useful when we deal with the concept of chance and probability. The Rnd function returns a random value between 0 and 1. In Example 1. When you run the program, you will get an output of 10 random numbers between 0 and 1. Randomize Timer is a vital statement here as it will randomize the process.

Example 1:

Private Sub Form_Activate

Randomize Timer

For x=1 to 10

Print Rnd

Next x

End Sub


Random numbers in its original form are not very useful in programming until we convert them to integers. For example, if we need to obtain a random output of 6 random integers ranging from 1 to 6, which make the program behave as a virtual die, we need to convert the random numbers using the format Int(Rnd*6)+1. Let’s study the following example:

In this example, Int(Rnd*6) will generate a random integer between 0 and 5 because the function Int truncates the decimal part of the random number and returns an integer. After adding 1, you will get a random number between 1 and 6 every time you click the command button. For example, let say the random number generated is 0.98, after multiplying it by 6, it becomes 5.88, and using the integer function Int(5.88) will convert the number to 5; and after adding 1 you will get 6.

In this example, you place a command button and change its caption to ‘roll die’. You also need to insert a label into the form and clear its caption at the designing phase and make its font bigger and bold. Then set the border value to 1 so that it displays a border; and after that set the alignment to center. The statement Label1.Caption=Num means the integer generated will be displayed as the caption of the label.

Example 2:

Dim num as integer

Private Sub Command1_Click ( )

Randomize Timer

Num=Int(Rnd*6)+1

Label1.Caption=Num

End Sub
The Numeric Functions

The numeric functions are Int, Sqr, Abs, Exp, Fix, Round and Log.

a) Int is the function that converts a number into an integer by truncating its decimal part and the resulting integer is the largest integer that is smaller than the number. For example, Int(2.4)=2, Int(4.8)=4, Int(-4.6)= -5, Int(0.032)=0 and so on.

b) Sqr is the function that computes the square root of a number. For example, Sqr(4)=2, Sqr(9)=2 and etc.

c) Abs is the function that returns the absolute value of a number. So Abs(-8) = 8 and Abs(8)= 8.

d) Exp of a number x is the value of ex. For example, Exp(1)=e1 = 2.7182818284590

e) Fix and Int are the same if the number is a positive number as both truncate the decimal part of the number and return an integer. However, when the number is negative, it will return the smallest integer that is larger than the number. For example, Fix(-6.34)= -6 while Int(-6.34)=-7.

f) Round is the function that rounds up a number to a certain number of decimal places. The Format is Round (n, m) which means to round a number n to m decimal places. For example, Round (7.2567, 2) =7.26

g) Log is the function that returns the natural Logarithm of a number. For example,

Log 10= 2.302585
Example 3

This example computes the values of Int(x), Fix(x) and Round(x,n) in a table form. It uses the Do Loop statement and the Rnd function to generate 10 numbers. The statement x = Round (Rnd * 7, 7) rounds a random number between 0 and 7 to 7 decimal places. Using commas in between items will create spaces between them and hence a table of values can be created. The program and output are shown below

Private Sub Form_Activate ()

n = 1

Print " n", " x", "Int(x)", "Fix(x)", "Round(x, 4)"

Do While n < 11

Randomize Timer

x = Round (Rnd * 7, 7)

Print n, x, Int(x), Fix(x), Round(x, 4)

n = n + 1

Loop

End Sub