plenderj
May 22nd, 2002, 03:38 AM
Below are more handy code snippets.
These are answers to various questions asked on VBForums.
A lot of the code fragments are very basic and some people may
even wonder why someone would post this stuff.
Well, people keep asking the questions, so, here are the answers!
In the very near future, all other scattered code fragments will be
consolidated into collection-threads like this.
Each thread will contain a table of contents like the one below,
and there will also be a single master table of contents for all
code fragment threads.
Contents, in order ;
00) Create a folder is it does not already exist
01) Return the largest number in an array of numbers
02) Sum up an array of numbers
03) Return the decimal version of a hex value
04) Highlight, and make bold if needs be, text between brackets a certain colour
05) Display the co-ordinates of the mouse pointer every 50ms
06) The occurances of a string in an array of strings
07) The occurances of a string in another string
08) Reverse the order of an array
09) Alternate implementation of reverseOrder()
10) Round up any given number
11) Code to take a screengrab and BitBlt into a PictureBox
12) An implementation of Split(), with ability to use multiple delimeters
13) Code to make a form stay on top
14) Code to open a webpage from inside your app
'' Create a folder if it does not already exist
''
Private Sub createFolder(ByVal strFolderPath As String)
If Len(Dir(strFolderPath, vbDirectory)) = 0 Then
MkDir strFolderPath
End If
End Sub
'' Return the largest number in an array of numbers
''
Private Function findLargestInArray(ByRef arrName() As Long) As Long
findLargestInArray = arrName(0): Dim i As Long
For i = 0 To UBound(arrName)
If arrName(i) > findLargestInArray Then findLargestInArray = arrName(i)
Next
End Function
'' Sum up an array of numbers
''
Private Function sumArray(ByRef arrName() As Long) As Long
Dim i As Long
For i = 0 To UBound(arrName)
sumArray = sumArray + arrName(i)
Next
End Function
'' Return the decimal version of a hex value
''
Private Function hexToDecimal(ByVal hexVal As Variant) As Long
hexToDecimal = CLng("&H" & hexVal)
End Function
'' Highlight, and make bold if needs be, text between brackets a certain colour
''
Private Sub doHighlight(colour As Long, bold As Boolean, rtb As RichTextBox)
Dim nStart As Long, nNext As Long: nStart = 1
Do
nStart = InStr(nStart, rtb.Text, "(")
If Not nStart = 0 Then
nNext = InStr(nStart, rtb.Text, ")")
If Not nNext = 0 Then
With rtb
.SelStart = nStart
.SelLength = nNext - nStart - 1
.SelBold = bold
.SelColor = colour
End With
End If
End If
If nStart = 0 Then Exit Do
nStart = nStart + 1
Loop
rtb.SelStart = 1
End Sub
'' Display the co-ordinates of the mouse pointer every 50ms
''
Private lastTick As Long
Private mouseCords As POINTAPI
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Private Sub Form_Load()
Show
Do
DoEvents
If GetTickCount - lastTick > 50 Then
lastTick = GetTickCount
GetCursorPos mouseCords
With mouseCords
Debug.Print .x & "," & .y
End With
End If
Loop
End Sub
'' The occurances of a string in an array of strings
''
Private Function occurancesOf(ByVal strString As String, ByRef strArray() As String) As Long
Dim i As Long
For i = 0 To UBound(strArray)
occurancesOf = occurancesOf + Abs(LCase(strArray(i)) = LCase(strString))
Next
End Function
'' The occurances of a string in another string
''
Private Function occurancesOfString(ByVal strSought As String, ByVal strSearchIn As String) As Long
occurancesOfString = (Len(strSearchIn) - Len(Replace(strSearchIn, strSought, ""))) / Len(strSought)
End Function
'' Reverse the order of an array
''
Private Function reverseOrder(ByRef arrName() As String) As String()
Dim i As Long, tempArr() As String: ReDim tempArr(UBound(arrName))
For i = 0 To UBound(arrName)
tempArr(i) = arrName(UBound(arrName) - i)
Next
reverseOrder = tempArr
End Function
'' Alternate implementation of reverseOrder()
'' note: Previous reverseOrder() function is about twice as fast
''
Private Function reverseOrder2(ByRef arrName() As String) As String()
reverseOrder2 = Split(StrReverse(Join(arrName, "-:!:-")), "-:!:-")
End Function
'' Round up any given number
''
Private Function doRound(ByVal num As Double) As Single
doRound = Round(num + 0.5)
End Function
'' Code to take a screengrab and BitBlt into a PictureBox
''
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Sub screenDesktop(ByVal destPBox As PictureBox)
Dim hWindow As Long, hDContext As Long
destPBox.AutoRedraw = True
hWindow = GetDesktopWindow()
hDContext = GetDC(hWindow)
BitBlt destPBox.hdc, 0, 0, Screen.Width \ Screen.TwipsPerPixelX, Screen.Height \ Screen.TwipsPerPixelY, hDContext, 0, 0, vbSrcCopy
destPBox.Refresh: destPBox.Picture = destPBox.Image
ReleaseDC hWindow, hDContext
End Sub
'' An implementation of Split(), with ability to use multiple delimeters
''
Private Function Split2(ByVal strString As String, strDelimeters() As String) As String()
Dim retVal() As String
If (Not strString = "") And (Not UBound(strDelimeters) = 0) Then
Dim canContinue As Boolean, i As Long
For i = 0 To UBound(strDelimeters)
canContinue = canContinue Or (InStr(strString, strDelimeters(i)) <> 0)
Next
If canContinue Then
ReDim retVal(0)
Dim j As Long, x As String, y As String
x = strString
y = Join(strDelimeters, "")
i = 1
While (Not x = "")
If InStr(y, Mid(x, i, 1)) <> 0 Then
retVal(UBound(retVal)) = Left(x, i - 1)
ReDim Preserve retVal(UBound(retVal) + 1)
x = Mid(x, i + 1)
i = 1
End If
i = i + 1
Wend
End If
End If
Split2 = retVal
End Function
'' Code to make a form stay on top
''
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOMOVE = 2
Private Const SWP_NOSIZE = 1
Private Const SWP_WNDFLAGS = SWP_NOMOVE Or SWP_NOSIZE
Private Sub setTopmost(frm As Form, bTopmost As Boolean)
SetWindowPos frm.hWnd, IIf(bTopMost, HWND_TOPMOST, HWND_NOTOPMOST), 0, 0, 0, 0, SWP_WNDFLAGS
End Sub
'' Code to open a webpage from inside your app
''
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Sub StartDoc(ByVal DocName As String)
ShellExecute GetDesktopWindow(), "Open", DocName, "", "C:\", 1
End Sub
These are answers to various questions asked on VBForums.
A lot of the code fragments are very basic and some people may
even wonder why someone would post this stuff.
Well, people keep asking the questions, so, here are the answers!
In the very near future, all other scattered code fragments will be
consolidated into collection-threads like this.
Each thread will contain a table of contents like the one below,
and there will also be a single master table of contents for all
code fragment threads.
Contents, in order ;
00) Create a folder is it does not already exist
01) Return the largest number in an array of numbers
02) Sum up an array of numbers
03) Return the decimal version of a hex value
04) Highlight, and make bold if needs be, text between brackets a certain colour
05) Display the co-ordinates of the mouse pointer every 50ms
06) The occurances of a string in an array of strings
07) The occurances of a string in another string
08) Reverse the order of an array
09) Alternate implementation of reverseOrder()
10) Round up any given number
11) Code to take a screengrab and BitBlt into a PictureBox
12) An implementation of Split(), with ability to use multiple delimeters
13) Code to make a form stay on top
14) Code to open a webpage from inside your app
'' Create a folder if it does not already exist
''
Private Sub createFolder(ByVal strFolderPath As String)
If Len(Dir(strFolderPath, vbDirectory)) = 0 Then
MkDir strFolderPath
End If
End Sub
'' Return the largest number in an array of numbers
''
Private Function findLargestInArray(ByRef arrName() As Long) As Long
findLargestInArray = arrName(0): Dim i As Long
For i = 0 To UBound(arrName)
If arrName(i) > findLargestInArray Then findLargestInArray = arrName(i)
Next
End Function
'' Sum up an array of numbers
''
Private Function sumArray(ByRef arrName() As Long) As Long
Dim i As Long
For i = 0 To UBound(arrName)
sumArray = sumArray + arrName(i)
Next
End Function
'' Return the decimal version of a hex value
''
Private Function hexToDecimal(ByVal hexVal As Variant) As Long
hexToDecimal = CLng("&H" & hexVal)
End Function
'' Highlight, and make bold if needs be, text between brackets a certain colour
''
Private Sub doHighlight(colour As Long, bold As Boolean, rtb As RichTextBox)
Dim nStart As Long, nNext As Long: nStart = 1
Do
nStart = InStr(nStart, rtb.Text, "(")
If Not nStart = 0 Then
nNext = InStr(nStart, rtb.Text, ")")
If Not nNext = 0 Then
With rtb
.SelStart = nStart
.SelLength = nNext - nStart - 1
.SelBold = bold
.SelColor = colour
End With
End If
End If
If nStart = 0 Then Exit Do
nStart = nStart + 1
Loop
rtb.SelStart = 1
End Sub
'' Display the co-ordinates of the mouse pointer every 50ms
''
Private lastTick As Long
Private mouseCords As POINTAPI
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Private Sub Form_Load()
Show
Do
DoEvents
If GetTickCount - lastTick > 50 Then
lastTick = GetTickCount
GetCursorPos mouseCords
With mouseCords
Debug.Print .x & "," & .y
End With
End If
Loop
End Sub
'' The occurances of a string in an array of strings
''
Private Function occurancesOf(ByVal strString As String, ByRef strArray() As String) As Long
Dim i As Long
For i = 0 To UBound(strArray)
occurancesOf = occurancesOf + Abs(LCase(strArray(i)) = LCase(strString))
Next
End Function
'' The occurances of a string in another string
''
Private Function occurancesOfString(ByVal strSought As String, ByVal strSearchIn As String) As Long
occurancesOfString = (Len(strSearchIn) - Len(Replace(strSearchIn, strSought, ""))) / Len(strSought)
End Function
'' Reverse the order of an array
''
Private Function reverseOrder(ByRef arrName() As String) As String()
Dim i As Long, tempArr() As String: ReDim tempArr(UBound(arrName))
For i = 0 To UBound(arrName)
tempArr(i) = arrName(UBound(arrName) - i)
Next
reverseOrder = tempArr
End Function
'' Alternate implementation of reverseOrder()
'' note: Previous reverseOrder() function is about twice as fast
''
Private Function reverseOrder2(ByRef arrName() As String) As String()
reverseOrder2 = Split(StrReverse(Join(arrName, "-:!:-")), "-:!:-")
End Function
'' Round up any given number
''
Private Function doRound(ByVal num As Double) As Single
doRound = Round(num + 0.5)
End Function
'' Code to take a screengrab and BitBlt into a PictureBox
''
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Sub screenDesktop(ByVal destPBox As PictureBox)
Dim hWindow As Long, hDContext As Long
destPBox.AutoRedraw = True
hWindow = GetDesktopWindow()
hDContext = GetDC(hWindow)
BitBlt destPBox.hdc, 0, 0, Screen.Width \ Screen.TwipsPerPixelX, Screen.Height \ Screen.TwipsPerPixelY, hDContext, 0, 0, vbSrcCopy
destPBox.Refresh: destPBox.Picture = destPBox.Image
ReleaseDC hWindow, hDContext
End Sub
'' An implementation of Split(), with ability to use multiple delimeters
''
Private Function Split2(ByVal strString As String, strDelimeters() As String) As String()
Dim retVal() As String
If (Not strString = "") And (Not UBound(strDelimeters) = 0) Then
Dim canContinue As Boolean, i As Long
For i = 0 To UBound(strDelimeters)
canContinue = canContinue Or (InStr(strString, strDelimeters(i)) <> 0)
Next
If canContinue Then
ReDim retVal(0)
Dim j As Long, x As String, y As String
x = strString
y = Join(strDelimeters, "")
i = 1
While (Not x = "")
If InStr(y, Mid(x, i, 1)) <> 0 Then
retVal(UBound(retVal)) = Left(x, i - 1)
ReDim Preserve retVal(UBound(retVal) + 1)
x = Mid(x, i + 1)
i = 1
End If
i = i + 1
Wend
End If
End If
Split2 = retVal
End Function
'' Code to make a form stay on top
''
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOMOVE = 2
Private Const SWP_NOSIZE = 1
Private Const SWP_WNDFLAGS = SWP_NOMOVE Or SWP_NOSIZE
Private Sub setTopmost(frm As Form, bTopmost As Boolean)
SetWindowPos frm.hWnd, IIf(bTopMost, HWND_TOPMOST, HWND_NOTOPMOST), 0, 0, 0, 0, SWP_WNDFLAGS
End Sub
'' Code to open a webpage from inside your app
''
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Sub StartDoc(ByVal DocName As String)
ShellExecute GetDesktopWindow(), "Open", DocName, "", "C:\", 1
End Sub