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