Visual Basic 6.0 Code Bank
This is a collection of highly
requested Visual Basic code that I put together back in 2013 and 2014. Almost
all of these samples will work on fine on Visual Basic 6.0 .If you aren't able
to find what you need here, you can search by keywords.
|
Visual Basic Code Bank
|
|
Code Title
|
Code Description
|
|
Add a Menu to
Another Program
|
An
example of how to add a menu to another program.
|
|
Beep like QBasic's
Sound
|
This
shows you how to set the frequency & duration of a beep sound (kinda like
qbasic's sound function).
|
|
Center a Form
|
Check
this code out if you want to know how to put your forms in the center of the
screen.
|
|
Convert VB3 Forms
to VB6 Forms
|
This
will explain how to convert 16 bit Visual Basic forms to 32 bit Visual Basic
forms.
|
|
Count Lines
|
This
code shows you how to count the number of lines that are in a textbox.
|
|
Count the Times
Loaded
|
This
code shows you how to count the number of times the user has used your
program.
|
|
Count Words
|
This
code shows you how to count the number of words that are in a textbox.
|
|
Cut, Copy, Paste,
& Undo
|
Ever
wanted to use the cut, copy, paste, & undo commands in your program?
Check this out.
|
|
Disable/Enable
Ctrl+Alt+Del
|
This
shows you how to use the Windows API to disable/enable ctrl+alt+del. This only works
for Windows 95 and Windows 98.
|
|
Encrypt/Decrypt
Text
|
This
code will let you easily encrypt/decrypt strings of text.
|
|
Flip Picture
|
This
is an example that shows you a fast way to flip a picture in a picturebox
horizontally or vertically.
|
|
Font Lister
|
This
code shows you one way on how you can add a list of all the fonts on your
computer to a listbox.
|
|
Form Mover
|
This
code will show you how to move a form with a label.
|
|
Get HTML Color
|
This
example shows you how to get the HTML value of a color.
|
|
Get Your Computer's
Name
|
This
is some code that shows you how to get your computer's name (yep, it has a
name).
|
|
Hex-Editor Related
Code
|
VB
probably isn't the best language to make a hex editor with, but here are some
hex type examples anyway.
|
|
HTML Color Fade
|
This
is a short example on how to fade one color into another with HTML tags.
|
|
HTML Color Fade
Preview
|
This
is an example on how to preview color faded text in a picturebox.
|
|
HTML Waving Text
|
This
is an example on how to generate the HTML code for waving text.
|
|
Icons in System
Tray
|
For
some reason this is requested a lot, so I thought I'd put up an example on
how to do it. This code only works in Windows 95 and Windows 98.
|
|
Kill Duplicate
Items in a Listbox
|
Ever
wanta get rid of all the duplicates that are in a listbox? This code shows
you how.
|
|
Listbox Open
|
An
example of how to open files to a listbox.
|
|
Listbox Save
|
An
example of how to save the list inside of a listbox.
|
|
Macro Font Draw
|
This
is a code example that shows you how to create an ASCII Art Font option for
an ASCII Art Shop program.
|
|
Open Default
Browser
|
This
example shows you how to open up to a webpage using your default browser.
|
|
PictureBox Fade
|
This
code shows you how to fade a picturebox from one color to another.
|
|
Play Midi
|
Shows
you one way you can play a midi (*.mid) file.
|
|
Play Wav
|
Shows
you one way you can play a wav file.
|
|
Random Numbers
|
This
code shows you how to generate random numbers within a given range.
|
|
Replacing Text in a
String
|
This
code shows you one way to replace text within a string.
|
|
Resize it (Form
Stretch)
|
This
code lets you easily resize the controls on your form when you resize it. It
creates a cool stretch effect.
|
|
Scramble
|
Shows
you how to scramble words. This code is good for something like a Scrambler
game.
|
|
Screen Saver
Creation
|
This
explains how to create screen savers in Visual Basic.
|
|
Score Keeper
|
This
is a KeepScore function. It's for keeping score in games like Scrambler where
points are usually kept in a listbox with people's names.
|
|
Select All the List
Items
|
This
shows you the fastest way to select all the items in a listbox (the Windows
API way).
|
|
Set Windows
Wallpaper
|
This
code shows you how to set the wall paper for Windows.
|
|
Spell Checker
|
This
is a code example that shows you how to make a spell checker for your VB
programs! It works by calling up MSWord's spell checker to spell check your
documents.
|
|
StayOnTop
|
This
code will make your forms so they stay on top of all of the other windows on
the screen.
|
|
Tile a Pic in the
Background
|
This
shows you how to tile a picture in the background of a form.
|
|
Timeout/Pause
|
This
code will allow your program to use timeout statements, giving time for
certain events to happen.
|
|
VB3 Interface for
VB5/6
|
Just
when you get used to VB3's interface, they change things up on you in VB5 and
VB6. This explains how to set VB5/6's interface so it acts just like VB3.
|
|
Total
|
41
Code Examples
|
Add a Menu to Another Program
This code shows you how to add a
menu to another program. The only thing is that nothing will happen when you
click on the items. To make something happen when you click on an item you have
to subclass the menu (I'd help with that but I don't have any subclassing
controls, or at least not right now). Put this in your *.bas file:
Public
Declare Function AppendMenu Lib "user32" Alias
"AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal
wIDNewItem As Long, ByVal lpNewItem As Any) As Long
Public
Declare Function CreatePopupMenu Lib "user32" () As Long
Public
Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As
Long
Public
Declare Function FindWindow Lib "user32" Alias
"FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As
String) As Long
Public
Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Public
Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long,
ByVal nPos As Long) As Long
Public
Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long)
As Long
Public
Declare Function GetMenuString Lib "user32" Alias
"GetMenuStringA" (ByVal hMenu As Long, ByVal wIDItem As Long, ByVal
lpString As String, ByVal nMaxCount As Long, ByVal wFlag As Long) As Long
Public
Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal
nPos As Long) As Long
Public
Declare Function SendMessage Lib "user32" Alias
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam
As Long, lParam As Any) As Long
Public
Const MF_ENABLED = &H0&
Public
Const MF_POPUP = &H10&
Public
Const MF_STRING = &H0&
Public
Const WM_NCPAINT = &H85
Then put something like this in
a button:
Dim
newMenu As Long
newMenu
= CreatePopupMenu
Call
AppendMenu(newMenu, MF_ENABLED Or MF_STRING, 0, "Item One")
Call
AppendMenu(newMenu, MF_ENABLED Or MF_STRING, 1, "Item Two")
Call
AppendMenu(newMenu, MF_ENABLED Or MF_STRING, 2, "Item Three")
Call
AppendMenu(newMenu, MF_ENABLED Or MF_STRING, 3, "Item Four")
Call
AppendMenu(newMenu, MF_ENABLED Or MF_STRING, 4, "Item Five")
'
Find the notepad application window
Dim
notepad As Long
notepad
= FindWindow("notepad", vbNullString)
'
Add our menu to the window we found above
Dim
notepadMenu As Long
notepadMenu
= GetMenu(notepad)
Call
AppendMenu(notepadMenu, MF_POPUP, newMenu, "Item List")
'
Ensure that the user sees the new menu immediately
Call
SendMessage(notepad, WM_NCPAINT, 0&, 0&)
Beep Function
This shows you how to set the
frequency & duration of a beep sound. Put this in your *.bas file1:53 AM
8/19/2007:
Declare
Function Beep Lib "kernel32" (ByVal dwFreq As Long, ByVal dwDuration
As Long) As Long
Put something like this in a
button:
Dim
ret As Long
ret
= Beep(1500, 300)
Or, if you want to do something
a little more fun, try this:
Dim
ret As Long, i As Integer
For
i = 0 To 4000 Step 100
ret = Beep(i, 100)
Next
Center A Form
Here's how to center a form so
it will appear in the middle of the screen, put this in a button:
Me.Top
= (Screen.Height - Me.Height) / 2
Me.Left
= (Screen.Width - Me.Width) / 2
Convert VB3 Forms to VB6 Forms
Here's how to convert old 16 bit
VB froms into 32 bit VB forms: In a 16 bit version of VB (like VB3), select
"File" from the menu, then click on "Save File As..." A
dialog box will pop up. Look for a checkbox on that dialog box that says
"Save as Text." Make sure that is checked. Once you do that, save the
file. You should now be able to use that form in 32 bit versions of VB (like
VB6).
Count the Lines of Text in a TextBox
This code will count how many
lines of text there are in a string by counting the number of times the
"carriage return" character shows up and adding one to that. This
code will not count lines of text that wrap in a textbox. Put this code in a
button:
Dim
lineCount As Integer, pos As Integer, txt As String
lineCount
= 0
pos
= 1
txt
= Text1.Text
Do
While pos <> 0
pos = InStr(pos + 1, txt, Chr$(13))
lineCount
= lineCount + 1
DoEvents
Loop
MsgBox
"Number of line(s) of text in text1.text: " + CStr(lineCount), 32,
"Line Count"
Count the Number of Times a Program
is Opened
This code shows you how to count
the number of times your program is used. Place this function in your *.bas
file:
Function
getLoadedCount() As Double
Dim programINI As String, countString As
String, countNum As Double
programINI = App.Path & App.EXEName
& "_info.ini"
' See if an ini has been created, if not,
create the file and set the
' number of times this program has been
loaded to 1
If Len(Dir(programINI)) = 0 Then
' Create an ini to hold the number of
times the program is opened
Open programINI For Output As #1
Print #1, "Times Loaded: 1"
Close #1
countNum = 1
Else
' Open the ini and see how many times
the program has been opened
If FileLen(programINI) <> 0 Then
Open programINI For Input As #1
Line Input #1, countString
Close #1
End If
' make sure the file has the correct
format
If Len(countString) < 15 Then
countNum = 1
Else
countNum = Val(Mid(countString,
14)) + 1
End If
Open programINI For Output As #1
Print #1, "Times Loaded: "
& countNum
Close #1
End If
getLoadedCount = countNum
End
Function
Example on how to use this
function, put something like this in the form load event:
Dim
numTimes As Double
numTimes
= getLoadedCount()
MsgBox
"This program has been loaded: " & numTimes & "
time(s)"
Count the Words in a TextBox
This code lets you count the
number of words that are in a textbox (note this is very different from the len
function which counts the number of characters in a string). Put these two
functions in your *.bas file:
'
This function determines if a given block of text is a "word".
'
Below we say anything that starts with an alphabet character
'
is a word.
Function
isWord(str As String) As Boolean
Dim ret As Boolean
If str = Null Then
ret = False
ElseIf Len(str) = 0 Then
ret = False
ElseIf Mid(str, 1, 1) >= "A"
And Mid(str, 1, 1) <= "Z" Then
ret = True
ElseIf Mid(str, 1, 1) >= "a"
And Mid(str, 1, 1) <= "z" Then
ret = True
Else
ret = False
End If
isWord = ret
End
Function
'
This function counts the number of words in a string.
'
It does this by spliting the text into an array based on
'
the space character and then checking to see which elements
'
in the array are "words".
Function
countWords(str As String) As Long
Dim words() As String, i As Long, numWords
As Long
words = Split(str, " ")
For i = LBound(words) To UBound(words)
If isWord(words(i)) Then
numWords = numWords + 1
End If
Next
countWords = numWords
End
Function
Then put something like this in
a button:
Dim
numWords As Long
numWords
= countWords(Text1.text)
MsgBox
"Total number of words in text1.text: " + CStr(numWords),
vbInformation, "Number of Words"
Cut, Copy, Paste, & Undo
Ever wanted to use the cut,
copy, paste, & undo commands in your program? Now you can, check this out:
Cut: (put this in a button)
Clipboard.SetText
Text1.SelText
Text1.SelText
= ""
Copy: (put this in a button)
Clipboard.SetText
Text1.SelText
Paste: (put this in a button)
Text1.SelText
= Clipboard.GetText(1)
Undo: (put this in your bas)
Declare
Function SendMessage Lib "user32" Alias "SendMessageA"
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any)
As Long
Public
Const WM_UNDO = &H304
Put this in a button:
Call
SendMessage(Text1.hwnd, WM_UNDO, 0&, 0&)
Disable/Enable Ctrl+Alt+Del
The following code only works in
Windows 95 and Windows 98. Put this in your *.bas file:
Public
Declare Function SystemParametersInfo Lib "User32" Alias
"SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long,
ByVal lpvParam As String, ByVal fuWinIni As Long) As Long
Then put this in a button to
disable c+a+d:
Call
SystemParametersInfo(97, True, 0&, 0)
Then put this in a button to
enable c+a+d:
Call
SystemParametersInfo(97, False, 0&, 0)
Encrypting/Decrypting a String
Below is an example of a substitution
cipher. Substitution ciphers can be broken by a cryptanalyst who knows what
they're doing, so this method of encryption shouldn't be used if you want your
data to be 99% secure. However, substitution ciphers will keep common users
from being able to see your data. For high levels of security look into public
key encryption and AES.
To continue on, copy and paste the function below into your *.bas file:
Public
Function Encrypt(text As String) As String
Dim charSet1 As String, charSet2 As String,
i As Long
Dim pos As Long, encryptedChar,
encryptedText
charSet1 = "
?!@#$%^&*()_+|0123456789abcdefghijklmnopqrstuvwxyz.,-~ABCDEFGHIJKLMNOPQRSTUVWXYZ¿¡²³ÀÁÂÃÄÅÒÓÔÕÖÙÛÜàáâãäåض§Ú¥"
charSet2 = "
¿¡@#$%^&*()_+|01²³456789ÀbÁdÂÃghÄjklmÅÒÓqÔÕÖÙvwÛÜz.,-~AàáâãFGHäJKåMNضQR§TÚVWX¥Z?!23acefinoprstuxyBCDEILOPSUY"
For i = 1 To Len(text)
pos = InStr(charSet1, Mid(text, i, 1))
If pos > 0 Then
encryptedChar = Mid(charSet2, pos,
1)
encryptedText = encryptedText +
encryptedChar
Else
encryptedText = encryptedText +
Mid(text, i, 1)
End If
Next
Encrypt = encryptedText
End
Function
How to use this function:
To encrypt a word just put
something like this in a button:
Text1.Text
= Encrypt(Text1)
And then to unencrypt the word
just call the function again!
Text1.Text
= Encrypt(Text1)
Flip a Picture
This code demonstrates a fast
way to flip a picture in a picturebox horizontally or vertically. Put this in
your *.bas file:
Declare
Function StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, ByVal
nSrcHeight As Long, ByVal dwRop As Long) As Long
Public
Const SRCCOPY = &HCC0020
Then put something like this in
a button:
Picture1.scalemode
= 3 ' pixels
'flip
horizontal
Call
StretchBlt(Picture1.hdc, Picture1.ScaleWidth, 0, Picture1.ScaleWidth * -1,
Picture1.ScaleHeight, Picture1.hdc, 0, 0, Picture1.ScaleWidth,
Picture1.ScaleHeight, SRCCOPY)
'flip
vertically
Call
StretchBlt(Picture1.hdc, 0, Picture1.ScaleHeight, Picture1.ScaleWidth,
Picture1.ScaleHeight * -1, Picture1.hdc, 0, 0, Picture1.ScaleWidth,
Picture1.ScaleHeight, SRCCOPY)
Add a List of Fonts to a Listbox
This isn't the fastest way to
add all the fonts on your computer to a listbox, but it's the easiest. Put
something like this in a button:
Dim
x as integer
For
x = 0 To Screen.FontCount - 1
List1.AddItem Screen.Fonts(x)
Next
Move a Form With a Label
Copy this code into your *.bas
file:
Global
leftX
Global
topY
How to Use:
Put this code in the label's
MouseDown event:
Private
Sub Label1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As
Single)
leftX = X
topY = Y
End
Sub
Put this code in the label's
MouseMove event:
Private
Sub Label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As
Single)
If Button And 1 Then
Me.Left = Me.Left + X - leftX
Me.Top = Me.Top + Y - topY
End If
End
Sub
Get the HTML Value of a Color
This is an example that shows
you how to get the html color value (ie, the hex value) of a color. You will
need to add the Microsoft Common Dialog control to your project for this to
work. Put this code in a button:
On
Error GoTo handleError
Dim
theColor As Long, red As String, green As String, blue As String
CommonDialog1.CancelError
= True
CommonDialog1.ShowColor
theColor
= CommonDialog1.Color
red
= Hex(theColor And 255)
green
= Hex(theColor \ 256 And 255)
blue
= Hex(theColor \ 65536 And 255)
If
Len(red) < 2 Then red = "0" & red
If
Len(green) < 2 Then green = "0" & green
If
Len(blue) < 2 Then blue = "0" & blue
MsgBox
"The HTML color value is: #" & red & green & blue
handleError:
Exit Sub
Get Your Computer's Name
Did you ever want to know what
your computer's name was? Not me, but anyway, if you do want to know try
this... Put this code in your *.bas file:
Public
Declare Function GetComputerName Lib "kernel32" Alias
"GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Then put something like this in
a button:
Dim
computerName As String
computerName
= String(50, Chr(0))
Call
GetComputerName(computerName, 50)
MsgBox
"Your computer is named: " & computerName, 32, "Name"
Some Hex Related Codes...
Ok, this example code will show
you how to open up an exe, copy it, replace strings in the copy with strings of
your choice, and then make a new program with the new strings in it.
For this to work you need to
have two textboxes on a form (named: txtProgInput and txtProgOutput) and two
lists (named lstOldStrings and lstNewStrings). txtProgInput contains the name
of program you're editing (like:"C:\somefile.exe") and txtProgOutput
contains the name of the program you're making from this program. lstOldStrings
contains a list of strings your replacing and lstNewStrings contains the list
of what you're replacing them with. IMPORTANT NOTE: The length of the string
you're replacing must be the same as the length of the string you're replacing it
with, otherwise you'll get an error. Put this code in a button:
Dim
inputProg As String, outputProg As String, filedata As String
Dim
i As Long, pos As Long
inputProg
= txtProgInput.text ' Program to Edit
outputProg
= txtProgOutput.text ' Program to Make
'
Make sure this file you want to edit exists
If
Len(Dir$(inputProg)) = 0 Then
MsgBox Chr(34) + inputProg + Chr(34) +
" does not exist!", vbCritical, "Error"
Exit Sub
End
If
'
Open the file to make and the file your making this file with
Open
outputProg For Output As #1
Open inputProg For Binary As #2
Do While Not EOF(2)
' Grab the next 8000 characters out
of the file
filedata = Input$(8000, #2)
' Loop through all the items in the
replacement listbox and replace the old strings
' with the new strings
For i = 0 To
lstOldStrings.ListCount - 1
Do
pos = InStr(pos + 1,
LCase$(filedata), LCase$(lstOldStrings.List(i)))
If pos <> 0 Then
filedata =
Mid(filedata, 1, pos - 1) + lstNewStrings.List(i) + Mid(filedata, pos +
Len(lstNewStrings.List(i)))
End If
Loop Until pos = 0
Next
' Print the new characters into the
file you're making
Print #1, filedata;
Loop
Close #2
Close
#1
MsgBox
Chr(34) + outputProg + Chr(34) + " has been created.", vbInformation,
"Complete"
HTML Color Fading Example
HTML color values are stored in
a hexadecimal
format. Each HTML color value is divided into 3 parts: the color's amount of
red, green, & blue - #FF0000. The amount of
red a color can have is in the range of 0 to 255 (same goes for green &
blue). So if you have 255 for red and 20 for blue and green, your color will be
sort of redish looking.
Anyway, the following is an
example on how to fade one color into another. Put this function in your *.bas
file:
Function
getColorValue(startVal As Long, stepVal As Double, stepNum As Long)
Dim hexStr As String
hexStr = Hex(startVal + (stepVal *
stepNum))
If Len(hexStr) < 2 Then
hexStr = "0" + hexStr
End If
getColorValue = hexStr
End
Function
Then put something like this in
a button:
Dim
red1 As Long, green1 As Long, blue1 As Long
Dim
red2 As Long, green2 As Long, blue2 As Long
Dim
i As Long, inputText As String, fadedText As String
Dim
redStep As Double, greenStep As Double, blueStep As Double
inputText
= "The text I want to fade!"
red1
= 255 ' The amount of red in color1
green1
= 0 ' The amount of green in color1
blue1
= 0 ' The amount of blue in color1
red2
= 0 ' The amount of red in color2
green2
= 0 ' The amount of green in color2
blue2
= 255 ' The amount of blue in color2
redStep
= (red2 - red1) / (Len(inputText) - 1)
greenStep
= (green2 - green1) / (Len(inputText) - 1)
blueStep
= (blue2 - blue1) / (Len(inputText) - 1)
For
i = 0 To Len(inputText) - 1
fadedText = fadedText + "<font
color""#" + getColorValue(red1, redStep, i) +
getColorValue(green1, greenStep, i) + getColorValue(blue1, blueStep, i) +
""">" + Mid(inputText, i + 1, 1) +
"</font>"
Next
MsgBox
fadedText
HTML Color Fading Preview Example
This example shows you how to
create a fade preview of color faded text inside of a picturebox. You will need
to add a picturebox control named "Picture1" to your form for this to
work. Put this code in a button:
Dim
red1 As Long, green1 As Long, blue1 As Long
Dim
red2 As Long, green2 As Long, blue2 As Long
Dim
i As Long, inputText As String, fadedText As String
Dim
redStep As Double, greenStep As Double, blueStep As Double
Dim
doWave As Boolean, wavPos As Long
inputText
= "The text I want to fade!"
red1
= 255 ' The amount of red in color1
green1
= 0 ' The amount of green in color1
blue1
= 0 ' The amount of blue in color1
red2
= 0 ' The amount of red in color2
green2
= 0 ' The amount of green in color2
blue2
= 255 ' The amount of blue in color2
redStep
= (red2 - red1) / (Len(inputText) - 1)
greenStep
= (green2 - green1) / (Len(inputText) - 1)
blueStep
= (blue2 - blue1) / (Len(inputText) - 1)
Picture1.Cls
Picture1.CurrentX
= 0
Picture1.CurrentY
= 0
doWave
= False ' If this is true then your preview will also preview waved text
'
Loop through the text on letter at a time
For
i = 0 To Len(inputText) - 1
If doWave = True Then
wavPos = wavPos + 1
If wavPos > 4 Then wavPos = 1
Select Case wavPos
Case 1: Picture1.CurrentY =
Picture1.CurrentY - 15
Case 2: Picture1.CurrentY =
Picture1.CurrentY + 15
Case 3: Picture1.CurrentY =
Picture1.CurrentY + 15
Case 4: Picture1.CurrentY =
Picture1.CurrentY - 15
End Select
End If
Picture1.ForeColor = RGB(red1 + redStep *
i, green1 + greenStep * i, blue1 + blueStep * i)
Picture1.Print Mid$(inputText, i + 1, 1);
Next
How to Generate the HTML Code for Waving
text
Just like the title says. Put
this code in a button:
Dim
i As Long, tagIndex As Integer, strWave As String
Dim
inputText As String
ReDim
waveHTML(1 To 4) As String ' array that holds html tags
inputText
= "This is my input text!"
waveHTML(1)
= "<sup>"
waveHTML(2)
= "</sup>"
waveHTML(3)
= "<sub>"
waveHTML(4)
= "</sub>"
'
Loop though the text one letter at a time
For
i = 1 To Len(inputText)
tagIndex = tagIndex + 1
If tagIndex > 4 Then tagIndex = 1
strWave = strWave & waveHTML(tagIndex)
& Mid$(inputText, i, 1)
Next
'
Make sure a closing tag is added
If
Len(inputText) Mod 2 = 1 Then
strWave = strWave & waveHTML(tagIndex +
1)
End
If
MsgBox
strWave
How to Put an Icon in the System
Tray
This code did not work when
tested in Windows XP. It was written for Windows 95/98.
This shows you how to put an
icon in the system tray. It uses an icon stored in Picture1.picture as the
icon. Put this in your *.bas file:
Declare
Function Shell_NotifyIcon Lib "shell32.dll" Alias
"Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As
NOTIFYICONDATA) As Long
Public
Const WM_MOUSEMOVE = &H200
Public
Const NIM_ADD = &H0
Public
Const NIM_DELETE = &H2
Public
Const NIF_ICON = &H2
Public
Const NIF_MESSAGE = &H1
Public
Const NIF_TIP = &H4
Type
NOTIFYICONDATA
cbSize As Long
hwnd As Long
uID As Long
uFlags As Long
uCallbackMessage As Long
hIcon As Long
szTip As String * 64
End
Type
Then put something like this in
a button to add the icon to the tray:
Dim
IconInfo As NOTIFYICONDATA
IconInfo.cbSize
= Len(IconInfo)
IconInfo.hwnd
= Me.hwnd
IconInfo.hIcon
= Picture1.Picture
IconInfo.uFlags
= NIF_ICON Or NIF_MESSAGE Or NIF_TIP
IconInfo.uCallbackMessage
= WM_MOUSEMOVE
IconInfo.szTip
= "Mouseover Text" + Chr$(0)
Call
Shell_NotifyIcon(NIM_ADD, IconInfo)
Put something like this in a
button to remove the icon:
Dim
IconInfo As NOTIFYICONDATA
IconInfo.cbSize
= Len(IconInfo)
IconInfo.hwnd
= Me.hwnd
Call
Shell_NotifyIcon(NIM_DELETE, IconInfo)
Kill the Duplicates in a Listbox
This code loops though a list
(List1) checking each item with every other item, then when it finds a
duplicate it removes it. Put this code in a button:
Dim
i As Long, X As Long, Y As Long
For
i = 0 To List1.ListCount - 1
For X = 0 To List1.ListCount - 1
If X <> i Then
If List1.List(i) = List1.List(X)
Then
List1.RemoveItem X
X = X - 1
End If
End If
Next
Next
Here's another way to do it,
this way is somewhat faster and uses some Windows API functions (sent in by
Sopon). First put this in your *.bas file:
Public
Declare Function SendMessageByString Lib "user32" Alias
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam
As Long, ByVal lParam As String) As Long
Public
Const LB_FINDSTRINGEXACT = &H1A2
Then make this a function in
your *.bas file:
Public
Function LBDupe(lpBox As ListBox) As Integer
Dim nCount As Integer, nPos1 As Integer,
nPos2 As Integer, nDelete As Integer
Dim sText As String
If lpBox.ListCount < 3 Then
LBDupe = 0
Exit Function
End If
For nCount = 0 To lpBox.ListCount - 1
Do
DoEvents
sText = lpBox.List(nCount)
nPos1 =
SendMessageByString(lpBox.hwnd, LB_FINDSTRINGEXACT, nCount, sText)
nPos2 = SendMessageByString(lpBox.hwnd,
LB_FINDSTRINGEXACT, nPos1 + 1, sText)
If nPos2 = -1 Or nPos2 = nPos1
Then Exit Do
lpBox.RemoveItem nPos2
nDelete = nDelete + 1
Loop
Next nCount
LBDupe = nDelete
End
Function
Then put something like this in
a button:
Call
LBDupe(List1)
Opening a File to a Listbox
This code shows you how to open
a file to a listbox. Make sure you have a CommonDialog control added to your
form. Put something like this in a button:
On
Error GoTo handleError
Dim
fileName As String, listItem As String
CommonDialog1.CancelError
= True
CommonDialog1.Filter
= "Text Files (*.txt)|*.txt"
CommonDialog1.FilterIndex
= 0
CommonDialog1.ShowOpen
fileName
= CommonDialog1.fileName
List1.Clear
Open
fileName For Input As #1
Do While Not EOF(1)
Line Input #1, listItem
If Not (listItem = "") Then
List1.AddItem listItem
End If
Loop
Close
#1
handleError:
Exit Sub
Saving the List Inside of a Listbox
This code shows you how to save
the contents of a listbox. Make sure you have a CommonDialog control added to
your form. Put something like this in a button:
On
Error GoTo handleError
Dim
fileName As String, msgResult As VbMsgBoxResult, i As Long
CommonDialog1.CancelError
= True
CommonDialog1.Filter
= "Text Files (*.txt)|*.txt"
CommonDialog1.FilterIndex
= 0
CommonDialog1.ShowSave
fileName
= CommonDialog1.fileName
If
Len(Dir(fileName)) <> 0 Then
msgResult = MsgBox("This file already
exists: """ + fileName + """, do you wish replace
it?", vbYesNo, "Error")
If msgResult = vbNo Then Exit Sub
End
If
Open
fileName For Output As #1
For i = 0 To List1.ListCount - 1
Print #1, List1.List(i) + Chr(13)
Next
Close
#1
handleError:
Exit Sub
Macro Font Draw
AOL Macro Fonts allowed you to
type in large ASCII art text, like you see below.
|\¯¯¯-¯)::)¯¯,¯\_':|¯¯¯¯¯¯¯||
:\|__|¯|°:/__/'\__\:|¯¯|__|¯¯|
::|__|¯::|__:|/\|__|':¯¯|__|¯¯
This code example shows you how
to create a macro font feature for a Macro Shop / ASCII Art Shop program. It
makes it so you can select a (*.pmf) file load it into a 2D array, and then
have the output display when the user types text in an input textbox. You will
need the following for this example to work:
txtInput - An input textbox named
"txtInput". This is where the user types their input.
txtOutput - An output textbox named "txtOutput". This is where the
output is displayed. This textbox should have it's multiline property set to
true and it's font type set to "Arial" and point size set to 10.
CommonDialog1 - A common dialog control should be added to the project.
Put something like this in your
*.bas file:
Global
macroFontName As String
Global
fontAuthor As String
Global
macroFontSize As Integer
Global
macroFont(1 To 27, 1 To 20) As String
Put something like this in the
load a font button:
On
Error GoTo handleError
Dim
textInput As String, i As Integer, i2 As Integer
CommonDialog1.CancelError
= True
CommonDialog1.Filter
= "Macro Fonts (*.pmf)|*.pmf"
CommonDialog1.ShowOpen
macroFontName
= CommonDialog1.fileName
Open
macroFontName For Input As #1
Line Input #1, textInput
macroFontSize = Val(Mid$(textInput, 19))
If macroFontSize < 1 Then Exit Sub
Line Input #1, textInput
fontAuthor = Mid$(textInput, 21)
For i = 1 To 26
For i2 = 1 To macroFontSize
Line Input #1, textInput
macroFont(i, i2) = textInput
Next
Next
For i = 1 To macroFontSize
macroFont(27, i) = " " &
" " & " " & " " & " "
Next
Close
#1
handleError:
Exit Sub
And then put something like this
in the Change event of txtInput:
Dim
i As Integer, i2 As Integer
Dim
alphabet As String, pos As Integer, outputText As String
alphabet
= "ABCDEFGHIJKLMNOPQRSTUVWXYZ "
For
i2 = 1 To macroFontSize
For i = 1 To Len(txtInput.text)
pos = InStr(alphabet,
UCase(Mid$(txtInput, i, 1)))
If pos <> 0 Then
outputText = outputText +
macroFont(pos, i2)
End If
Next
outputText = outputText + Chr(13) + Chr(10)
Next
txtOutput.text
= outputText
Open Up a Default Browser
This shows you how to open your
default browser. Put this function in your *.bas file:
Public
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
Then put something like this in
a button:
Dim
ret As Long, theWebSite As String
theWebSite
= "http://teamerror.org/"
ret
= ShellExecute(Me.hwnd, "open", theWebSite, vbNullString,
vbNullString, 3)
If
ret < 32 Then MsgBox "There was an error when trying to open a default
browser", vbCritical, "Error"
Picturebox Fade
This code will fade one color
into another color in a picturebox. It's a nice tid-bit to keep in mind if you
want to make your own title bar for a form. Put this in a button:
Dim
xPos As Double, xLength As Double, yLength As Integer, i As Integer
Dim
red1 As Integer, green1 As Integer, blue1 As Integer
Dim
red2 As Integer, green2 As Integer, blue2 As Integer
Dim
step1 As Double, step2 As Double, step3 As Double
Dim
redVal As Double, greenVal As Double, blueVal As Double
Dim
fadeLength As Integer
fadeLength
= 100
'
find the length of the picturebox and cut it into 100 pieces
xLength
= Picture1.ScaleWidth / fadeLength
yLength
= Picture1.ScaleHeight
'
setting how much red, green, and blue goes into each of the two colors
red1
= 255
green1
= 0
blue1
= 0
red2
= 0
green2
= 0
blue2
= 255
'
cut the difference between the two colors into 100 pieces
step1
= (red2 - red1) / (fadeLength - 1)
step2
= (green2 - green1) / (fadeLength - 1)
step3
= (blue2 - blue1) / (fadeLength - 1)
'
set the c variables at the starting colors
redVal
= red1
greenVal
= green1
blueVal
= blue1
'
draw 100 different lines on the picturebox
For
i% = 1 To fadeLength
Picture1.Line (xPos, 0)-(xPos + xLength,
yLength), RGB(redVal, greenVal, blueVal), BF
xPos = xPos + xLength ' draw the next line
one step up from the old step
' make the color value variable equal to
it's next step
redVal = redVal + step1
greenVal = greenVal + step2
blueVal = blueVal + step3
Next
Play a Midi
File
Copy this function into your
*.bas file:
Declare
Function mciSendString Lib "winmm.dll" Alias "mciSendStringA"
(ByVal lpstrCommand As String, ByVal lpstrReturnString As Any, ByVal
uReturnLength As Long, ByVal hwndCallback As Long) As Long
The following code can go in
buttons to play/stop/pause/etc:
'
Open a midi file
'
IMPORTANT NOTE: Before a file can be played, it must be opened via
'
the "open" command
Dim
ret As Long
ret
= mciSendString("open C:\Dancing_Queen.Mid type sequencer", 0&,
0, 0)
'
Play a midi file
Dim
ret As Long
ret
= mciSendString("play C:\Dancing_Queen.Mid", 0&, 0, 0)
'
Stop a midi file
Dim
ret As Long
ret
= mciSendString("stop C:\Dancing_Queen.Mid", 0&, 0, 0)
'
Pause a midi file
Dim
ret As Long
ret
= mciSendString("pause C:\Dancing_Queen.Mid", 0&, 0, 0)
'
Resume playing a midi file
Dim
ret As Long
ret
= mciSendString("resume C:\Dancing_Queen.Mid", 0&, 0, 0)
'
Seek to a certain position within the file
'
"start" and "end" can be used as keywords for positions to
seek to
Dim
ret As Long
ret
= mciSendString("seek C:\Dancing_Queen.Mid to 500", 0&, 0, 0)
ret
= mciSendString("play C:\Dancing_Queen.Mid", 0&, 0, 0)
'
Get the length of the file in milliseconds
Dim
numMSecs As String * 128
Dim
ret As Long
ret
= mciSendString("set C:\Dancing_Queen.Mid time format ms", 0&, 0,
0)
ret
= mciSendString("status C:\Dancing_Queen.Mid length", numMSecs, Len(numMSecs),
0)
MsgBox
"There are " & str(numMSecs) & " milliseconds"
'
Get the length of the file in bytes
'
This can compliment the seek command
Dim
numBytes As String * 128
Dim
ret As Long
ret
= mciSendString("set C:\Dancing_Queen.Mid time format bytes", 0&,
0, 0)
ret
= mciSendString("status C:\Dancing_Queen.Mid length", numBytes,
Len(numBytes), 0)
MsgBox
"There are " & str(numBytes) & " bytes"
'
Alias
'
IMPORTANT: This can make your life so much
easier. Creating an
'
alias will allow you to not have to remember the file name when using commands
other than "Open".
'
Example:
Dim
ret As Long
ret
= mciSendString("open C:\Dancing_Queen.Mid type sequencer alias
theFile", 0&, 0, 0)
ret
= mciSendString("play theFile", 0&, 0, 0)
'
Always remember to CLOSE your midi file after you're done using it!!
'
Otherwise you could give Windows memory problems
Dim
ret As Long
ret
= mciSendString("close C:\Dancing_Queen.Mid", 0&, 0, 0)
'
Side note: I'm not really that big a fan of Abba, they're decent though. I
picked dancing queen
'
as the sample song because it was the first midi I found when I did a google
for midis.
Play a Wav
This code will be the same as
described in playing a midi file with
one key difference. When opening a file, use "waveaudio" as the type.
Example:
Dim
ret As Long
ret
= mciSendString("open C:\parent-teachernite.wav type waveaudio alias
theFile", 0&, 0, 0)
Random Number Generater
This code lets you generate a
random integer within a given range. Copy this function and paste it in your
*.bas file:
Public
Function RandomNumber(startNum As Integer, endNum As Integer) As Integer
Randomize
RandomNumber = Int(((endNum - startNum + 1)
* Rnd) + startNum)
End
Function
Example on how to use:
Dim
x As Integer
x
= RandomNumber(10, 20)
MsgBox
x
"x" will be equal to a
random integer in the range: [10, 20] (ie, between 10 and 20, including 10 and
20)
Replacing Text in a String
This small example on how to use
the "Replace" function in Visual Basic 6.0. Originally this code used
the Mid and Instr string functions, but since VB 6.0 you can simply use
"Replace".
Dim
text As String
text
= "text text text, all you write is text"
text
= Replace(text, "text", "pizza")
MsgBox
text
How to use (put in button):
Text1.text = RemoveSpaces(Text1)
Resizing a Form (an easy way)
This code lets you resize your
forms with a neat stretch effect. Copy and paste the code as directed by the
comments:
'-----------------------------------------------------
'
Put this code in the public area of your form (ie, the top most part)
'-----------------------------------------------------
Private
Type ScaleStruct
Top As Integer
Left As Integer
Width As Integer
Height As Integer
ParentHeight As Integer
ParentWidth As Integer
FontSize As Integer
End
Type
Dim
Ctrl() As ScaleStruct
Dim
minWidth As Integer
Dim
minHeight As Integer
Dim
maxWidth As Integer
Dim
maxHeight As Integer
'-----------------------------------------------------
'
Put this code in the Form_Load event
'-----------------------------------------------------
On
Error Resume Next
Dim
i As Integer
ReDim
Ctrl(0 To Me.Controls.Count - 1)
Me.ScaleMode
= 3
For
i = 0 To Me.Controls.Count - 1
Ctrl(i).Top = Me.Controls(i).Top
Ctrl(i).Left = Me.Controls(i).Left
Ctrl(i).Width = Me.Controls(i).Width
Ctrl(i).Height = Me.Controls(i).Height
Ctrl(i).ParentHeight =
Me.Controls(i).Parent.ScaleHeight
Ctrl(i).ParentWidth =
Me.Controls(i).Parent.ScaleWidth
Ctrl(i).FontSize = Me.Controls(i).FontSize
Next
'
THESE VALUES ARE ARBITRARY
'
Change them to best suit your program
'
One tip would be to have a min size, but not a real
'
max size (ie, make the maxes larger than what the
'
screen size will ever be
minWidth
= 400
minHeight
= 400
maxWidth
= 800
maxHeight
= 800
'-----------------------------------------------------
'
Put this code in the Form_Resize event
'-----------------------------------------------------
On
Error Resume Next
Dim
i As Integer
Dim
ParentSH As Integer, ParentSW As Integer
ParentSH
= Me.Controls(i).Parent.ScaleHeight
ParentSW
= Me.Controls(i).Parent.ScaleWidth
For
i = 0 To Me.Controls.Count - 1
If Me.ScaleHeight >= minHeight And
Me.ScaleHeight <= maxHeight Then
Me.Controls(i).Top = Ctrl(i).Top *
(ParentSH / Ctrl(i).ParentHeight)
Me.Controls(i).Height = Ctrl(i).Height
* (ParentSH / Ctrl(i).ParentHeight)
Me.Controls(i).FontSize =
Ctrl(i).FontSize * (ParentSH / Ctrl(i).ParentHeight)
If Me.Controls(i).FontSize < 8 Then
Me.Controls(i).FontSize = 8
If Me.Controls(i).FontSize > 12 Then
Me.Controls(i).FontSize = 12
End If
If Me.ScaleWidth >= minWidth And
Me.ScaleWidth <= maxWidth Then
Me.Controls(i).Left = Ctrl(i).Left *
(ParentSW / Ctrl(i).ParentWidth)
Me.Controls(i).Width = Ctrl(i).Width *
(ParentSW / Ctrl(i).ParentWidth)
End If
Next
Scramble a Series of Words
Here are a neat series of
functions that will allow you to scramble each word in a sentence. This code
would word well for a scrambler program. Put these functions your *.bas file:
'
generates a random number in a given range
Public
Function RandomNumber(startNum As Integer, endNum As Integer) As Integer
Randomize
RandomNumber = Int(((endNum - startNum + 1)
* Rnd) + startNum)
End
Function
'
swaps two characters in a string
Public
Function swap(text As String, pos1 As Integer, pos2 As Integer)
Dim temp As String
temp = Mid(text, pos1, 1)
text = Mid(text, 1, pos1 - 1) + Mid(text,
pos2, 1) + Mid(text, pos1 + 1)
text = Mid(text, 1, pos2 - 1) + temp +
Mid(text, pos2 + 1)
swap = text
End
Function
'
scrambles a word
Public
Function scrambleWord(ByVal text As String)
Dim scrambleStrength As Integer, pos1 As
Integer, pos2 As Integer
Dim i As Integer
' probably doesn't need to be higher than this
scrambleStrength = (Len(text) - 1) * 2
For i = 0 To scrambleStrength
pos1 = RandomNumber(1, Len(text))
pos2 = RandomNumber(1, Len(text))
text = swap(text, pos1, pos2)
Next
scrambleWord = text
End
Function
Public
Function scrambleInput(text As String)
Dim words() As String, i As Integer
words = Split(text, " ") ' split
is a VB function for breaking a string into an array of strings
For i = 0 To UBound(words)
' scramble each word
words(i) = scrambleWord(words(i))
Next
' output a string of the scrambled text
scrambleInput = Join(words, " ")
End
Function
Example on how to use these
functions to scramble the words in a sentence:
Text1
= scrambleInput(Text1)
Screen Saver Creation
Here's what you do to make a
screen saver: Start a new project. Set the windowstate property of the form to
"2 - Maximized", and the border style of the form to zero. In the
"KeyDown" event of the form put the "End" statement. Then
in the mouse move event of the form put something like this:
Static
ScreenSaverVar As Integer
ScreenSaverVar
= ScreenSaverVar + 1
If
ScreenSaverVar > 2 Then End
Now select "Make
some_project_name.exe" in the file menu. When it asks you what you want to
name the exe, add a "*.scr" extension to the end of the name
(example: Blah.src). Then select the directory "c:\windows\system\"
as the place to make this program. And there you go, you've made a screensaver
which you can use on your desktop (note: you'll probably want to jazz up the
form a little bit first).
Additional Info: (Provided by
Mike Clem)
Try adding "SCRNSAVE:
" in front of the name of your screen saver when compiling if you cannot
get Windows to recognize that your creation is a screen saver. Example: "SCRNSAVE:
Blah.SCR"
Problem of Windows not
recognizing the Screen Saver occured in WFW 3.11 using VB 3.0.
Score Keeper
This is a KeepScore function.
It's for keeping score is games like Scrambler where points are usually kept in
a listbox with people's names. Code written by deep arctic.
Public
Sub ScramblerKeepScore(ByRef lstList As ListBox, strPerson As String, intPoints
As Integer)
' Written by deep arctic
Dim strLastScore As String,
strPreviousPerson As String
Dim intIndex As Integer, strCount As String
Dim intCount As Integer
For intCount = 0 To lstList.ListCount - 1
strCount = lstList.List(intCount)
strPreviousPerson = Left(strCount,
InStr(strCount, "-") - 2)
If LCase(strPreviousPerson) =
LCase(strPerson) Then
intIndex = intCount
strLastScore = Right(strCount,
Len(strCount) - InStr(strCount, "-") - 1)
strLastScore = Val(strLastScore) +
intPoints
lstList.List(intIndex) = strPerson
& " - " & strLastScore
Exit Sub
End If
Next intCount
lstList.AddItem (strPerson & " -
" & intPoints)
End
Sub
Here is an example on how you
can try this function out:
'
List1 = the list you are keeping scores in
'
txtName = a textbox containing the name of the person whose score you want to
update
'
txtPoints = a textbox containing the number of points you want to award this
person
Call
ScramblerKeepScore(List1, txtName.text, CInt(txtPoints.text))
'
An helpful tip: In the properties window, set your score keeping listbox's
"Sorted" property to "true"
Select All the List Items
This is an example that shows
you how to select all of the list items in a listbox. This should work for any
listbox window. Just make sure the listbox's multiselect property is set to
"1 - Simple" in the properties window. Put something like this in
your *.bas file:
Public
Declare Function SendMessage Lib "user32" Alias
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam
As Long, lParam As Any) As Long
Public
Declare Function SendMessageLong& Lib "user32" Alias
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam
As Long, ByVal lParam As Long)
Public
Const LB_GETCOUNT = &H18B
Public
Const LB_SETSEL = &H185
Then put something like this in
a button:
Dim
listItems As Long
listItems
= SendMessage(List1.hwnd, LB_GETCOUNT, 0&, vbNullString) - 1
Call
SendMessageLong(List1.hwnd, LB_SETSEL, listItems, True)
Set the Picture For You Windows Wall
Paper
This code shows you how to set
the wall paper for windows, put something like this in you *.bas file:
Declare
Function SystemParametersInfo Lib "user32" Alias
"SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long,
ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long
Public
Const SPI_SETDESKWALLPAPER = 20
Public
Const SPIF_UPDATEINIFILE = &H1
Then put something like this in
a button or in the form_load:
'
The final parameter "SPIF_UPDATEINIFILE" tells us to save the changes
(so our new wallpaper is sill with us on restart).
'
Setting this parameter to 0 will cause us not to update the registery and wont
save the wallpaper.
Dim
thePic As String
thePic
= "C:\some_image.bmp"
Call
SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, thePic, SPIF_UPDATEINIFILE)
Spell Checker
Ever wanted a spell checker feature
in one of your programs? Check this out, it calls up the MSWord's spell checker
so you are able to spell check your documents! You need MSWord95 or better for
this code to work. This example spell checks the text in a textbox named
"Text1". Put this in a button:
On
Error Resume Next
Dim
WordSC As Object, pos As Integer
Set
WordSC = CreateObject("Word.Basic")
WordSC.AppMinimize
WordSC.FileNewDefault
WordSC.EditSelectAll
WordSC.EditCut
WordSC.Insert
Text1.text
WordSC.StartOfDocument
WordSC.ToolsSpelling
WordSC.EditSelectAll
Text1.text
= WordSC.Selection
WordSC.FileCloseAll
2
WordSC.AppClose
Set
WordSC = Nothing
If
Mid(Text1.text, Len(Text1.text), 1) = Chr(13) Then
Text1.text = Mid(Text1.text, 1,
Len(Text1.text) - 1)
End
If
pos
= InStr(Text1.text, Chr(13))
Do
While pos <> 0
If Mid(Text1.text, pos + 1, 1) <>
Chr(10) Then
Text1.text = Mid(Text1.text, 1, pos) +
Chr(10) + Mid(Text1.text, pos + 1)
End If
pos = InStr(pos + 1, Text1.text, Chr(13))
Loop
MsgBox
"Spell Check Complete", vbInformation, "Spell Check"
Stay on Top Code
This makes a form stay on top of
all other applications running in Windows. Put this code in your *.bas file:
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
Public
Const SWP_NOMOVE = 2
Public
Const SWP_NOSIZE = 1
Public
Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Public
Const HWND_TOPMOST = -1
Public
Const HWND_NOTOPMOST = -2
Public
Sub stayOnTop(frm As Form)
Call SetWindowPos(frm.hwnd, HWND_TOPMOST,
0, 0, 0, 0, FLAGS)
End
Sub
Public
Sub removeFromTop(frm As Form)
Call SetWindowPos(frm.hwnd, HWND_NOTOPMOST,
0, 0, 0, 0, FLAGS)
End
Sub
Example on how to use (put this
in the form's load event):
stayOnTop
Me
Example on how to remove a form
from being the top most window:
removeFromTop
Me
Tile a Picture in the Background
This example shows you how to
tile a picture in the background of a form. Put something like this in the
form's load event:
Dim
i As Integer, j As Integer
Me.AutoRedraw
= True
Picture1.AutoSize
= True
Picture1.BorderStyle
= 0
Picture1.Visible
= False ' we probably don't want this visible, right?
On
Error Resume Next
For
i = 0 To Me.ScaleWidth Step Picture1.ScaleWidth
For j = 0 To Me.ScaleHeight Step
Picture1.ScaleHeight
Me.PaintPicture Picture1.Picture, i, j
Next
Next
Timeout Code
This sub lets up create a pause
in your programming code for whatever amount of seconds you tell it to pause
for: (copy & paste is sub in your *.bas file)
Public
Sub Timeout(duration As Double)
Dim starttime As Double, x As Integer
starttime = Timer
Do While Timer - starttime < duration
x = DoEvents()
Loop
End
Sub
Example on how to use (pause for
one second):
Call
Timeout(1)
Here's another way to do it,
this way uses the Windows API (sent in by Sopon). First put this in your *.bas
file:
Public
Declare Function GetTickCount Lib "kernel32" () As Long
Then make this a sub in your
bas:
Sub
Pause(hInterval As Long)
Dim hCurrent As Long
hInterval = hInterval * 1000
hCurrent = GetTickCount
Do While GetTickCount - hCurrent <
Val(hInterval)
DoEvents
Loop
End
Sub
Example on how to use (pause for
one second):
Call
Pause(1)
VB3 Interface for VB5 and VB6
Here's how to give VB5/6 the VB3
interface: Select "Tools">"Options" from the menu. Then
when the "Options" form pops up select the "Advanced" tab.
Make sure the "SDI Development Environment" checkbox is checked, and
click "OK". When you restart VB5/6, you should have the same kind of
interface that you had with VB3.
