Alpha - Visual Basic Source Codes

'Place this code in the declarations section of your form:

Option Explicit
Declare Function ReleaseCapture Lib "user32" () As Long
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 HTCAPTION = 2
Public Const WM_NCLBUTTONDOWN = &HA1

'Now, to move the form, you must place the following in the mousedown of a control. Of course 'you will want to place it in the FORM_keydown. OR if you have a control designated for this 'purpose, like a picturebox, place it there! Use this:

ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&

'That's it, now just run your project, grab hold of that FORM/CONTROL, and give it a move!

Home | Contents | Contact Us

'Place this code into a Module.

Option Explicit
Private Const SPI_GETWORKAREA = 48
Private Declare Function SystemParametersInfo& Lib "User32" Alias _
"SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As _
Long, lpvParam As Any, ByVal fuWinIni As Long)

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Public Function CenterForm32(frm As Form)
Dim ScreenWidth&, ScreenHeight&, ScreenLeft&, ScreenTop&
Dim DeskTopArea As RECT
Call SystemParametersInfo(SPI_GETWORKAREA, 0, DeskTopArea, 0)
ScreenHeight = (DeskTopArea.Bottom - DeskTopArea.Top) * Screen.TwipsPerPixelY
ScreenWidth = (DeskTopArea.Right - DeskTopArea.Left) * Screen.TwipsPerPixelX
ScreenLeft = DeskTopArea.Left * Screen.TwipsPerPixelX
ScreenTop = DeskTopArea.Top * Screen.TwipsPerPixelY
frm.Move (ScreenWidth - frm.Width) \ 2 + ScreenLeft, (ScreenHeight - _
frm.Height) \ 2 + ScreenTop
End Function

'That's it! Now, to center a form, just use this call:

CenterForm32 Me

Home | Contents | Contact Us

'Place this code in a Module:

Option Explicit
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (lpString1 As _
Any, lpString2 As Any) As Long
Const CCHDEVICENAME = 32
Const CCHFORMNAME = 32
Private Type DEVMODE
dmDeviceName As String * CCHDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCHFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type
Private Declare Function ChangeDisplaySettings Lib "User32" Alias _
"ChangeDisplaySettingsA" (ByVal lsDevMode As Long, ByVal dwFlags _
As Long) As Long

'Here is the function that sets the display mode. Width is the
'width of the screen. Height is the height of the screen. Color
'is the number of bits per pixel. Set the color value to -1 if
'you only want to change the screen Resolution. This function will
'Return 0 if successful!
Public Function SetDisplayMode(Width As Integer, Height As Integer, _
Color As Integer) As Long

Const DM_PELSWIDTH = &H80000
Const DM_PELSHEIGHT = &H100000
Const DM_BITSPERPEL = &H40000
Dim NewDevMode As DEVMODE
Dim pDevMode As Long
With NewDevMode
.dmSize = 122
If Color = -1 Then
.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
Else
.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL
End If
.dmPelsWidth = Width
.dmPelsHeight = Height
If Color <>-1 Then
.dmBitsPerPel = Color
End If
End With
pDevMode = lstrcpy(NewDevMode, NewDevMode)
SetDisplayMode = ChangeDisplaySettings(pDevMode, 0)
End Function

'Now, to change the Settings, use the following code. The first Argument is the Horizontal 'Width (640) of the screen. The second is the Verticle Height (480) of the screen, and the 'third is the color depth (24 bit).

i = SetDisplayMode(640, 480, 24)

Home | Contents | Contact Us

'Ever wanted to get the users attention without one of those annoying BEEPs, or just have a 'little fun? Here is a good way to do it. Flash the caption of your Form. That should get 'their attention!

'Place this code into a Module:

Option Explicit
Declare Function FlashWindow Lib "user32" (ByVal hwnd As Long, ByVal binvert As Long) As Long

Public Sub Flash(hFlash As Long, iTimes As Integer, sInterval As Single)
Dim I As Integer
For I = 0 To iTimes
'iTimes sets the number of flashes!
Call FlashWindow(hFlash, True)
Dim Start As Single
Start = Timer 'set the start time
Do While Timer < Start + sInterval
DoEvents
Loop
Next I
Call FlashWindow(hFlash, False)
End Sub

'Thats it! Now, to flash a caption, just use this call. The arguments are the number of 'flashes (20) and the interval for the flash (.5):

Flash Me.hwnd, 20, 0.5

Home | Contents | Contact Us

'Place this into your Module:

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

Global Const SWP_NOMOVE = 2
Global Const SWP_NOSIZE = 1
Global Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Global Const HWND_TOPMOST = -1
Global Const HWND_NOTOPMOST = -2

Sub OnTopYes(WinHandle As Long)
'This sub causes the window to stay OnTop
'WinHandle = the window handle
lResult = SetWindowPos(WinHandle, HWND_TOPMOST, 0, 0, 0, 0, FLAGS)
End Sub

Sub OnTopNo(WinHandle As Long)
'This sub prevents the window from staying OnTop
'WinHandle = the window handle
lResult = SetWindowPos(WinHandle, HWND_NOTOPMOST, 0, 0, 0, 0, FLAGS)
End Sub

'Now, when you want to make a window stay on top, just use the following code snippet:

Call OnTopYes(me.hwnd)

'This will force the calling window to stay above all other windows on your desktop!
'When you are finished with the window and don't want it above the other windows, just use 'this:

Call OnTopNo(me.hwnd)

'This will revert the window back to normal and it will act like a normal window.

Home | Contents | Contact Us

'Just place this in a Module and you can call it from anywhere in your program!

Sub SetLog(Message As String)
'This Sub writes to a LOG file.
Dim theFile As String, theMessage As String
theFile = App.Path & "\PRGMLOG.TXT"
theMessage = Message & vbCrLf
Open theFile For Append As #1
Print #1, theMessage
Close #1
End Sub

'To use the above function, just call SetLog("The message to write in the log").

'Considering that it is a log file, you may want to replace the log each time... To do this, 'just call the next function. It will delete the existing Log (if it does exist).

Sub KillLog()
'This sub deletes the old LOG file
On Error Resume Next 'err check on
Kill App.Path & "\PRGMLOG.TXT" 'Delete log
On Error GoTo 0 'err check off
End Sub

'To use the above function, just call KillLog.

Home | Contents | Contact Us

'First, create a menu using menueditor. Add all of your menu items as if you were just making 'a regular menu. Now set the VISIBLE property of the main menu item to false (see below, set 'the MNUEDIT item's VISIBLE to false). Like this:

'mnuEdit
'---mnuUndo
'---mnuRedo
'---mnuSep1
'---mnuCopy
'---mnuPaste

'Now just place this code snippet anywhere you want the Right Click Menu to appear:

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then
PopupMenu NameofMenu 'mnuEdit for the above example menu
End If
End Sub

'Now when you right click your menu should appear at the tip of your mouse pointer!

Home | Contents | Contact Us

'Place the following code in a form:

Sub setStatus(Message As String, Optional PanelNum As Integer = 1)
'This Sub changes the phrase in the Status panel to 'Message'
'PanelNum is the Index of the panel, default is 1
Dim thePanel As Panel
Set thePanel = NetAud.StatusBar1.Panels(PanelNum)
thePanel.Text = Message
End Sub

'To call the above Sub, just use this snippet of code:

Call setStatus("The message you want in the panel")

Home | Contents | Contact Us

'First, place these API calls in the declarations of a Module:

Private Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal _
lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
Private Declare Function WaveOutGetNumDevs Lib "winmm.dll" () As Long

'Now that the APIs are in place, you only need the functions! I suggest you place these in 'the same Module as the above API calls. If you place them in a module, you should be able to 'call them from any form in your program without duplicating the same code over and over 'again!

'This first function will determine if the computer can play WAV files at all! It returns a 'Boolean value, TRUE meaning that the machine is capable of playing WAV files!

Public Function CanPlayWAVs() As Boolean
'This function determines if the machine can play WAV files
CanPlayWAVs = WaveOutGetNumDevs()
End Function

'To use this function, just use the following snippet of code:

Dim canPlay as Boolean
canPlay = CanPlayWAVs

'Now on to the good stuff. This function will do the actual playing of the WAV file. Just 'call this function and supply a FileName for the WAV file, that's it! Notice the 'Optional 'Async as Boolean'! If you do not supply a TRUE value, your system will pause as the sound is 'being played. To prevent this pause, use a TRUE value and the sound will play Asynchronously 'and your system will not pause. This is good for Video Games!

Public Function PlayWAVFile(StrFileName As String, Optional blnAsync As _
Boolean) As Boolean
'This function plays a wav file
Dim lngFlags
'Flag Values for Parameter
Const SND_SYNC = &H0
Const SND_ASYNC = &H1
Const SND_NODEFAULT = &H2
Const SND_FILENAME = &H20000
'Set the flags for PlaySound
lngFlags = SND_NODEFAULT Or SND_FILENAME Or SND_SYNC
If blnAsync Then lngFlags = lngFlags Or SND_ASYNC
'Play the WAV file
PlayWAVFile = PlaySound(StrFileName, 0&, lngFlags)
End Function

'To call the above function, just use this code snippet:

Dim playWAV as Boolean, WAVFile as String
WAVFile = "test.wav" 'Full path of WAV file
playWAV = PlayWAVFile(WAVFile, TRUE)

'Now, you know that one time or another, you will have a WAV file playing, and you want to 'stop it. Well, don't worry, we've got you covered. Try this function:

Public Function StopPlayingWAV() As Boolean
'This function stops a playing WAV file
Const SND_PURGE = &H40
PlaySound vbNullString, 0&, SND_PURGE
End Function

'To call the above function, use this code snippet:

Dim stopWAV as Boolean
stopWAV = StopPlayingWAV

Home | Contents | Contact Us

'Place this code in the declorations part of the Code.

Private Declare Function LoadCursorFromFile Lib "user32" _
Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long
Private Declare Function SetClassLong Lib "user32" _
Alias "SetClassLongA" (ByVal hwnd As Long, ByVal nIndex As _
Long, ByVal dwNewLong As Long) As Long
Private Const GCL_HCURSOR = (-12)

'Now Place this Code where you want to start the cursor.

hCursor = LoadCursorFromFile("Busy.ani")

'Busy.ani can be changed to your cursor and must be in the same file.
'hWnd determines where the cursor will be displayed

hOldCursor = SetClassLong(AniCursor.hwnd, GCL_HCURSOR, hCursor)

'Place this code if you wish to return the cursor to its normal state.

lReturn = SetClassLong(AniCursor.hwnd, GCL_HCURSOR, hOldCursor)

'Now Put this code in the form unload Sub.

lReturn = SetClassLong(AniCursor.hwnd, GCL_HCURSOR, hOldCursor)

'And thats it! You now have an animated cursor!!

Home | Contents | Contact Us

'Here's how to open your CD door!
'Put this in the Declarations part of your Code.

Private Declare Function mciSendString Lib "winmm.dll" _
Alias "mciSendStringA" (ByVal lpstrCommand As String, _
ByVal lpstrReturnString As String, ByVal uReturnLength _
As Long, ByVal hwndCallback As Long) As Long

'Put this where you wish to open the door.

retvalue = mciSendString("set CDAudio door open", _
returnstring, 127, 0)

'And place this where you wish to close it.

retvalue = mciSendString("set CDAudio door closed", _
returnstring, 127, 0)

Home | Contents | Contact Us

'This will show you how to make the dither effect... that is when you choose shut down from 'the start menu and the screen is shaded.
'Enter this code in the declerations section of you code.

Private Declare Function GetDC& Lib "User32" (ByVal hWnd&)
Private Declare Function ReleaseDC& Lib "User32" _
(ByVal hWnd&, ByVal hDC&)
Private Declare Function DeleteObject& Lib "GDI32" (ByVal hObject&)
Private Declare Function SelectObject& Lib "GDI32" _
(ByVal hDC&, ByVal hObject&)
Private Declare Function CreatePatternBrush& Lib _
"GDI32" (ByVal hBitmap&)
Private Declare Function PatBlt& Lib "GDI32" _
(ByVal hDC&, ByVal X&, ByVal Y&, ByVal nWidth&, _
ByVal nHeight&, ByVal dwRop&)

'Now make a command buton. Index ranges from 0 to 2.
'Remember, Command1 is a control array.

Private Sub Command1_Click(Index%)
Dither (Index)
End Sub

Private Sub Dither(Index)
picBrush(Index).ScaleMode = 3 ' Pixel
picBrush(Index).ScaleHeight = 8
picBrush(Index).ScaleWidth = 8
hBrush = CreatePatternBrush(picBrush(Index).Image)

ROP = &HA000C9

DC = GetDC(0)
res = SelectObject(DC, hBrush)
res = PatBlt(DC, 0, 0, Screen.Width, Screen.Height, ROP)

res = DeleteObject(hBrush)
res = ReleaseDC(0, DC)
End Sub

Home | Contents | Contact Us

'For this code we use Label1 as an example...
'you can replace it with whatever obect you need.

Private Sub Label1_MouseMove(button As Integer, shift As _
Integer, x As Single, y As Single)
Label1.ForeColor = vbBlue
End Sub

Private Sub Form_MouseMove(button As Integer, shift As _
Integer, x As Single, y As Single)
Label1.ForeColor = vbBlack
End Sub

'You can put whatever you want in the code.

Home | Contents | Contact Us

Put this in a Module:

Declare Function mciExecute Lib "winmm.dll" _
(ByVal lpstrCommand As String) As Long

'And this in the form code.
'To play a sound use this.

mciExecute "Play " + Text1.Text

'Where Text1.Text is the file name.
'And use this to Stop it.

mciExecute "Stop " + Text1.Text

'Where Text1.Text is the File Name.
'And thats all their is to it!

Home | Contents | Contact Us

'
' Declarations
'
Public Const SWP_HIDEWINDOW = &H80
Public Const SWP_SHOWWINDOW = &H40

Public Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

Public 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 Sub DisplayTaskBar(ByVal bVal As Boolean)
Dim lTaskBarHWND As Long
Dim lRet As Long
Dim lFlags As Long
On Error GoTo vbErrorHandler
lFlags = IIf(bVal, SWP_SHOWWINDOW, SWP_HIDEWINDOW)
lTaskBarHWND = FindWindow("Shell_traywnd", "")
lRet = SetWindowPos(lTaskBarHWND, 0, 0, 0, 0, 0, lFlags)
If lRet < 0 Then
' Handle error from api
End If
End Sub
vbErrorHandler:
' Handle Errors here
End Sub

Home | Contents | Contact Us

' Declarations

Public 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

' Sets a form Topmost

Public Sub SetTopMost(ByVal lHwnd As Long, ByVal bTopMost As Boolean)

' Set the hwnd of the window topmost or not topmost

Home | Contents | Contact Us

Pause Application
Submitted by: Alpha Productions

' Declarations

Option Explicit

Private Declare Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As Long)

' Code:

Public Sub Wait(Seconds As Single)

Dim lMilliSeconds As Long
lMilliSeconds = Seconds * 1000
Sleep lMilliSeconds

End Sub

Open a Web Page Using the Default Browser
Submitted by: Alpha Productions

'Declarations:

Const SW_SHOWMAXIMIZED = 3
Const SW_SHOWMINIMIZED = 2
Const SW_SHOWDEFAULT = 10
Const SW_SHOWMINNOACTIVE = 7
Const SW_SHOWNORMAL = 1

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

'Code:
'PURPOSE: Opens default browser to display URL

'RETURNS: module handle to executed application or
'Error Code ( < 32) if there is an error

'can also be used to open any document associated with
'an application on the system (e.g., passing the name
'of a file with a .doc extension will open that file in Word)

Private Function OpenLocation(URL As String, _
WindowState As Long) As Long

Dim lHWnd As Long
Dim lAns As Long

lAns = ShellExecute(hWnd, "open", URL, vbNullString, _
vbNullString, WindowState)

OpenLocation = lAns

'ALTERNATIVE: if not interested in module handle or error
'code change return value to boolean; then the above line
'becomes:

'OpenLocation = (lAns < 32)

End Function

Open Default E-mail program to send E-mail
Submitted by: Alpha Productions

'Declarations:
Option Explicit

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

'Code:
Public Function OpenEmail(EmailAddress As String) As Boolean
Dim lWindow As Long

ShellExecute lWindow, "open", EmailAddress, _
vbNullString, vbNullString, SW_SHOW
OpenEmail = Err.LastDllError < 32

End Function

'Code:

Public Function PopulateListControlWithFonts(ListControl As _
Object) As Boolean
On Error GoTo errHandler:
Dim l As Long
Dim lCount As Long
ListControl.Clear
lCount = Screen.FontCount
For l = 0 To lCount - 1
ListControl.AddItem Screen.Fonts(l)
Next
PopulateListControlWithFonts = True
Exit Function
errHandler:
PopulateListControlWithFonts = False
Exit Function
End Function

'Function: Completes a word by searching through a specified listbox
'will skip as many matches as the number you type in for Skip
Public Function AutoComplete(Word as String, List as ListBox, Skip as Integer) as String
Dim I as Integer
Dim J as Integer
Dim SkipAmount as Integer
SkipAmount = Skip

For I = 1 to Len(Word)
    For J = 0 to List.ListCount - 1
      If UCase(Left(Word,1) = UCase(List.List(J)) Then
        If SkipAmount > 0 then
          SkipAmount = SkipAmount - 1
        Else
          AutoComplete = List.List(I)
          Exit Function
        End if
      End If
    Next
Next
End Function

Submit a Code!

Type in your full name, email address and code. Click submit at the bottom to send us your creation. If you do not put an email address or name, we cannot put your code on this page. Thanks - The Alpha Team.