Visual Basic Coding Tips and Tricks

How to convert a long number to double and vice versa

2010-03-01T02:30:00.001-08:00

The function that you could use to convert a long number to double is :
cDbl

Example source code:

Dim dblMyNumber As Double
Dim lngMyNumber As Long

lngMyNumber = 1002992

dblMyNumber = CDbl(lngMyNumber)

Thus lngMyNumber was converted to a double using CDbl. The output double variable is dblMyNumber.

Now, to convert a Double to a long, you need cLng function.
cLng (Convert to Long) is used like in the following example:

Example source code:

Dim dblMyNumber As Double
Dim lngMyNumber As Long

dblMyNumber = 1002992

lngMyNumber = CLng(dblMyNumber)

So dblMyNumber was converted to a Long using CLng. The output double variable is lngMyNumber.

NOTICE:
The Long data type is a 32-bit number
It ranges from -2,147,483,648 to 2,147,483,647.
Long variables can only contain non-fractional integer values.

The Double data type is a 64-bit floating point number used when high accuracy is needed.
These variables can range from -1.79769313486232e308 to -4.94065645841247e-324 for negative values and from 4.94065645841247e-324 to 1.79769313486232e308 for positive values.

This means that you might face overflow issues because Double has the double size than Long datatype.

Take a look at the following code:

Dim dblMyNumber As Double
Dim lngMyNumber As Long

dblMyNumber = 3147483647#

lngMyNumber = CLng(dblMyNumber)

How to change time zone information by using Visual Basic

2007-12-07T01:20:00.000-08:00

The way to implement this effect is as follows:

1.	Determine which time zone you would like to change to.
2.	Find the key in the registry that contains the information needed to fill the TIME_ZONE_INFORMATION structure.
3.	Read in that information and load the values into a variable of type TIME_ZONE_INFORMATION.
4.	Call the SetTimeZoneInformation API, passing it the TIME_ZONE_INFORMATION struct variable.

The location in the registry that contains time zone information differs between Windows 9x and Windows NT/Windows 2000.

For Windows NT and Windows 2000, it is located at:

HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Time Zones

For Windows 9x, it is located at:

HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Time Zones

The Time Zone key names differ between Windows NT, Windows 2000, and Windows 9x as well because Windows NT and Windows 2000 append the string "Standard Time" to the different keys whereas Windows 9x does not.

For example:

In Windows NT and Windows 2000, you would see this key:

Pacific Standard Time

while in Windows 9x, you would see this key:

Pacific

The registry location where the current Date/Time settings can be found is:

HKLM\SYSTEM\CurrentControlSet\Control\TimeZoneInformation

Back to the top

Step-by-step example

The code sample below requires a form with a listbox. The listbox is loaded with the possible time zone values that the user can select with a double-click to change the time zone. It will show a messagebox that, once dismissed, will change the system settings back to their original values.

1.	Create a new Standard EXE project. Form1 is created by default.
2.	Add a Listbox control to Form1.
3.	Add the following code to the General Declarations section of Form1: Option Explicit ' Operating System version information declares Private Const VER_PLATFORM_WIN32_NT = 2 Private Const VER_PLATFORM_WIN32_WINDOWS = 1 Private Type OSVERSIONINFO dwOSVersionInfoSize As Long dwMajorVersion As Long dwMinorVersion As Long dwBuildNumber As Long dwPlatformId As Long szCSDVersion As String * 128 ' Maintenance string End Type Private Declare Function GetVersionEx Lib "kernel32" _ Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long ' Time Zone information declares Private Type SYSTEMTIME wYear As Integer wMonth As Integer wDayOfWeek As Integer wDay As Integer wHour As Integer wMinute As Integer wSecond As Integer wMilliseconds As Integer End Type Private Type REGTIMEZONEINFORMATION Bias As Long StandardBias As Long DaylightBias As Long StandardDate As SYSTEMTIME DaylightDate As SYSTEMTIME End Type Private Type TIME_ZONE_INFORMATION Bias As Long StandardName(0 To 63) As Byte ' used to accommodate Unicode strings StandardDate As SYSTEMTIME StandardBias As Long DaylightName(0 To 63) As Byte ' used to accommodate Unicode strings DaylightDate As SYSTEMTIME DaylightBias As Long End Type Private Const TIME_ZONE_ID_INVALID = &HFFFFFFFF Private Const TIME_ZONE_ID_UNKNOWN = 0 Private Const TIME_ZONE_ID_STANDARD = 1 Private Const TIME_ZONE_ID_DAYLIGHT = 2 Private Declare Function GetTimeZoneInformation Lib "kernel32" _ (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long Private Declare Function SetTimeZoneInformation Lib "kernel32" _ (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long ' Registry information declares Private Const REG_SZ As Long = 1 Private Const REG_BINARY = 3 Private Const REG_DWORD As Long = 4 Private Const HKEY_CLASSES_ROOT = &H80000000 Private Const HKEY_CURRENT_USER = &H80000001 Private Const HKEY_LOCAL_MACHINE = &H80000002 Private Const HKEY_USERS = &H80000003 Private Const ERROR_SUCCESS = 0 Private Const ERROR_BADDB = 1 Private Const ERROR_BADKEY = 2 Private Const ERROR_CANTOPEN = 3 Private Const ERROR_CANTREAD = 4 Private Const ERROR_CANTWRITE = 5 Private Const ERROR_OUTOFMEMORY = 6 Private Const ERROR_ARENA_TRASHED = 7 Private Const ERROR_ACCESS_DENIED = 8 Private Const ERROR_INVALID_PARAMETERS = 87 Private Const ERROR_NO_MORE_ITEMS = 259 Private Const KEY_ALL_ACCESS = &H3F Private Const REG_OPTION_NON_VOLATILE = 0 Private Declare Function RegOpenKeyEx Lib "advapi32.dll" _ Alias "RegOpenKeyExA" ( _ ByVal hKey As Long, _ ByVal lpSubKey As String, _ ByVal ulOptions As Long, _ ByVal samDesired As Long, _ phkResult As Long) _ As Long Private Declare Function RegQueryValueEx Lib "advapi32.dll" _ Alias "RegQueryValueExA" ( _ ByVal hKey As Long, _ ByVal lpszValueName As String, _ ByVal lpdwReserved As Long, _ lpdwType As Long, _ lpData As Any, _ lpcbData As Long) _ As Long Private Declare Function RegQueryValueExString Lib "advapi32.dll" _ Alias "RegQueryValueExA" ( _ ByVal hKey As Long, _ ByVal lpValueName As String, _ ByVal lpReserved As Long, _ lpType As Long, _ ByVal lpData As String, _ lpcbData As Long) _ As Long Private Declare Function RegEnumKey Lib "advapi32.dll" _ Alias "RegEnumKeyA" ( _ ByVal hKey As Long, _ ByVal dwIndex As Long, _ ByVal lpName As String, _ ByVal cbName As Long) _ As Long Private Declare Function RegCloseKey Lib "advapi32.dll" ( _ ByVal hKey As Long) _ As Long ' Registry Constants Const SKEY_NT = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Time Zones" Const SKEY_9X = "SOFTWARE\Microsoft\Windows\CurrentVersion\Time Zones" ' The following declaration is different from the one in the API viewer. ' To disable implicit ANSI<->Unicode conversion, it changes the ' variable types of lpMultiByteStr and lpWideCharStr to Any. ' Private Declare Function MultiByteToWideChar Lib "kernel32" ( _ ByVal CodePage As Long, _ ByVal dwFlags As Long, _ lpMultiByteStr As Any, _ ByVal cchMultiByte As Long, _ lpWideCharStr As Any, _ ByVal cchWideChar As Long) As Long ' The above Declare and the following Constants are used to make ' this sample compatible with Double Byte Character Systems (DBCS). Private Const CP_ACP = 0 Private Const MB_PRECOMPOSED = &H1 Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _ ByRef Destination As Any, _ ByRef Source As Any, _ ByVal numbytes As Long) Dim SubKey As String Private Sub Form_Load() Dim lRetVal As Long, lResult As Long, lCurIdx As Long Dim lDataLen As Long, lValueLen As Long, hKeyResult As Long Dim strvalue As String Dim osV As OSVERSIONINFO ' Win9x and WinNT have a slightly different registry structure. Determine ' the operating system and set a module variable to the correct subkey. osV.dwOSVersionInfoSize = Len(osV) Call GetVersionEx(osV) If osV.dwPlatformId = VER_PLATFORM_WIN32_NT Then SubKey = SKEY_NT Else SubKey = SKEY_9X End If lRetVal = RegOpenKeyEx(HKEY_LOCAL_MACHINE, SubKey, 0, _ KEY_ALL_ACCESS, hKeyResult) If lRetVal = ERROR_SUCCESS Then lCurIdx = 0 lDataLen = 32 lValueLen = 32 Do strvalue = String(lValueLen, 0) lResult = RegEnumKey(hKeyResult, lCurIdx, strvalue, lDataLen) If lResult = ERROR_SUCCESS Then List1.AddItem Left(strvalue, lValueLen) End If lCurIdx = lCurIdx + 1 Loop While lResult = ERROR_SUCCESS RegCloseKey hKeyResult Else List1.AddItem "Could not open registry key" End If End Sub Private Sub List1_DblClick() Dim TZ As TIME_ZONE_INFORMATION, oldTZ As TIME_ZONE_INFORMATION Dim rTZI As REGTIMEZONEINFORMATION Dim bytDLTName(32) As Byte, bytSTDName(32) As Byte Dim cbStr As Long, dwType As Long Dim lRetVal As Long, hKeyResult As Long, lngData As Long lRetVal = RegOpenKeyEx(HKEY_LOCAL_MACHINE, SubKey & "\" & List1.Text, _ 0, KEY_ALL_ACCESS, hKeyResult) If lRetVal = ERROR_SUCCESS Then lRetVal = RegQueryValueEx(hKeyResult, "TZI", 0&, ByVal 0&, _ rTZI, Len(rTZI)) If lRetVal = ERROR_SUCCESS Then TZ.Bias = rTZI.Bias TZ.StandardBias = rTZI.StandardBias TZ.DaylightBias = rTZI.DaylightBias TZ.StandardDate = rTZI.StandardDate TZ.DaylightDate = rTZI.DaylightDate cbStr = 32 dwType = REG_SZ lRetVal = RegQueryValueEx(hKeyResult, "Std", _ 0&, dwType, bytSTDName(0), cbStr) If lRetVal = ERROR_SUCCESS Then Call MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, _ bytSTDName(0), cbStr, TZ.StandardName(0), 32) Else RegCloseKey hKeyResult Exit Sub End If cbStr = 32 dwType = REG_SZ lRetVal = RegQueryValueEx(hKeyResult, "Dlt", _ 0&, dwType, bytDLTName(0), cbStr) If lRetVal = ERROR_SUCCESS Then Call MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, _ bytDLTName(0), cbStr, TZ.DaylightName(0), 32) Else RegCloseKey hKeyResult Exit Sub End If lRetVal = GetTimeZoneInformation(oldTZ) If lRetVal = TIME_ZONE_ID_INVALID Then MsgBox "Error getting original TimeZone Info" RegCloseKey hKeyResult Exit Sub Else If TZ.DaylightDate.wMonth <> 0 And TZ.DaylightBias <> 0 Then lRetVal = SetTimeZoneInformation(TZ) Else Call CopyMemory(TZ.DaylightName(0), TZ.StandardName(0), 64) TZ.DaylightBias = 0 lRetVal = SetTimeZoneInformation(TZ) End If MsgBox "Time Zone Changed, Click OK to restore" lRetVal = SetTimeZoneInformation(oldTZ) End If End If RegCloseKey hKeyResult End If End Sub
4.	Run the program, and note that the listbox displays all of the available time zones.
5.	Select a time zone, and then double-click it. Your system locale is changed to the selected zone. You receive the following message: Time Zone Changed, Click OK to restore
6.	In Control Panel, double-click the Date/Time icon. You can also reach this dialog by double-clicking the clock in the system tray. Click the Time Zone tab and observe that the time zone has been changed.
7.	Close the Date/Time Properties dialog box and click OK on the message box displayed by your application. Repeat the previous step to confirm that the time zone information has been restored. Source: Microsoft

List all running processes in Visual Basic

2007-09-16T03:13:00.000-07:00

1. Create a new Standard Exe project in Visual Basic. Form1 is created by default.
2. Add a CommandButton to Form1.
3. Add a ListBox to Form1.
4. Copy the following code to Form1:

Option Explicit

Private Sub Command1_Click()
List1.Clear
Select Case getVersion()

Case 1 'Windows 95/98

Dim f As Long, sname As String
Dim hSnap As Long, proc As PROCESSENTRY32
hSnap = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0)
If hSnap = hNull Then Exit Sub
proc.dwSize = Len(proc)
' Iterate through the processes
f = Process32First(hSnap, proc)
Do While f
sname = StrZToStr(proc.szExeFile)
List1.AddItem sname
f = Process32Next(hSnap, proc)
Loop

Case 2 'Windows NT

Dim cb As Long
Dim cbNeeded As Long
Dim NumElements As Long
Dim ProcessIDs() As Long
Dim cbNeeded2 As Long
Dim NumElements2 As Long
Dim Modules(1 To 200) As Long
Dim lRet As Long
Dim ModuleName As String
Dim nSize As Long
Dim hProcess As Long
Dim i As Long
'Get the array containing the process id's for each process object
cb = 8
cbNeeded = 96
Do While cb <= cbNeeded
cb = cb * 2
ReDim ProcessIDs(cb / 4) As Long
lRet = EnumProcesses(ProcessIDs(1), cb, cbNeeded)
Loop
NumElements = cbNeeded / 4

For i = 1 To NumElements
'Get a handle to the Process
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION _
Or PROCESS_VM_READ, 0, ProcessIDs(i))
'Got a Process handle
If hProcess <> 0 Then
'Get an array of the module handles for the specified
'process
lRet = EnumProcessModules(hProcess, Modules(1), 200, _
cbNeeded2)
'If the Module Array is retrieved, Get the ModuleFileName
If lRet <> 0 Then
ModuleName = Space(MAX_PATH)
nSize = 500
lRet = GetModuleFileNameExA(hProcess, Modules(1), _
ModuleName, nSize)
List1.AddItem Left(ModuleName, lRet)
End If
End If
'Close the handle to the process
lRet = CloseHandle(hProcess)
Next

End Select
End Sub

5. Add a Standard Module to the Project. Module1 is created.
6. Paste the following code into Module1.

Public Declare Function Process32First Lib "kernel32" ( _
ByVal hSnapshot As Long, lppe As PROCESSENTRY32) As Long

Public Declare Function Process32Next Lib "kernel32" ( _
ByVal hSnapshot As Long, lppe As PROCESSENTRY32) As Long

Public Declare Function CloseHandle Lib "Kernel32.dll" _
(ByVal Handle As Long) As Long

Public Declare Function OpenProcess Lib "Kernel32.dll" _
(ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, _
ByVal dwProcId As Long) As Long

Public Declare Function EnumProcesses Lib "psapi.dll" _
(ByRef lpidProcess As Long, ByVal cb As Long, _
ByRef cbNeeded As Long) As Long

Public Declare Function GetModuleFileNameExA Lib "psapi.dll" _
(ByVal hProcess As Long, ByVal hModule As Long, _
ByVal ModuleName As String, ByVal nSize As Long) As Long

Public Declare Function EnumProcessModules Lib "psapi.dll" _
(ByVal hProcess As Long, ByRef lphModule As Long, _
ByVal cb As Long, ByRef cbNeeded As Long) As Long

Public Declare Function CreateToolhelp32Snapshot Lib "kernel32" ( _
ByVal dwFlags As Long, ByVal th32ProcessID As Long) As Long

Public Declare Function GetVersionExA Lib "kernel32" _
(lpVersionInformation As OSVERSIONINFO) As Integer

Public Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long ' This process
th32DefaultHeapID As Long
th32ModuleID As Long ' Associated exe
cntThreads As Long
th32ParentProcessID As Long ' This process's parent process
pcPriClassBase As Long ' Base priority of process threads
dwFlags As Long
szExeFile As String * 260 ' MAX_PATH
End Type

Public Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long '1 = Windows 95.
'2 = Windows NT

szCSDVersion As String * 128
End Type

Public Const PROCESS_QUERY_INFORMATION = 1024
Public Const PROCESS_VM_READ = 16
Public Const MAX_PATH = 260
Public Const STANDARD_RIGHTS_REQUIRED = &HF0000
Public Const SYNCHRONIZE = &H100000
'STANDARD_RIGHTS_REQUIRED Or SYNCHRONIZE Or &HFFF
Public Const PROCESS_ALL_ACCESS = &H1F0FFF
Public Const TH32CS_SNAPPROCESS = &H2&
Public Const hNull = 0

Function StrZToStr(s As String) As String
StrZToStr = Left$(s, Len(s) - 1)
End Function

Public Function getVersion() As Long
Dim osinfo As OSVERSIONINFO
Dim retvalue As Integer
osinfo.dwOSVersionInfoSize = 148
osinfo.szCSDVersion = Space$(128)
retvalue = GetVersionExA(osinfo)
getVersion = osinfo.dwPlatformId
End Function

7. Run the project and click the Command button on Form1. You should see a listing of the currently running processes.
8. If you are running Windows 95/98, try running the example project on Windows NT or vice versa. The processes should be listed regardless of operating system version.

Source : Microsoft

Undocumented : How to check if a website (or your blog) is alive

2007-07-07T22:30:00.000-07:00

Use this undocumented method IsDestinationReachable located in sensapi.dll to check if your blog or a website in general is alive.

The debug window will display the connection path, the speed and True or False if the site destination is reachable.

Option Explicit

Private Type QOCINFO
dwSize As Long
dwFlags As Long
dwInSpeed As Long
dwOutSpeed As Long
End Type

Public MonInterval As Long

Private Const NETWORK_ALIVE_LAN As Long = &H1 'active LAN cards
Private Const NETWORK_ALIVE_WAN As Long = &H2 'active RAS connections
Private Const NETWORK_ALIVE_AOL As Long = &H4 'connected to AOL (Win95/98 only)

Private Declare Function IsDestinationReachable Lib "sensapi.dll" _
Alias "IsDestinationReachableA" (ByVal lpszDestination As String, _
lpQOCInfo As QOCINFO) As Long
Public Function CheckSite(ByVal strHTTPSite As String) As Boolean
Dim gRes As Long
Dim structqoc As QOCINFO

structqoc.dwSize = Len(structqoc)

gRes = IsDestinationReachable(strHTTPSite, structqoc)

With structqoc
Select Case .dwFlags
Case NETWORK_ALIVE_LAN: Debug.Print "LAN"
Case NETWORK_ALIVE_WAN: Debug.Print "RAS"
Case NETWORK_ALIVE_AOL: Debug.Print "AOL"
Case Else: Debug.Print "Unknown"
End Select

Debug.Print "IN:" & FormatNumber((.dwInSpeed / 1000), 0) & " kbps OUT:" & FormatNumber((.dwOutSpeed / 1000), 0) & " kbps"
End With

CheckSite = CBool(gRes)

End Function

Visual Basic still rocks :)

Easily generating random numbers

2007-03-23T15:00:00.000-07:00

From John Slaughter

If you use random numbers to a large extent, you probably get tired of always having to put in Randomize and then the equation. This simple subroutine handles both chores for you. First, put the following routine in your project's main module.

Public Function GenRndNumber(Upper As Integer, Lower As Integer) As Integer
Randomize
GenRndNumber = Int((Upper - Lower + 1) * Rnd + Lower)
End Function

To get a random number between 99 and -99, just enter:

RandomNumber = GenRndNumber(99, -99)

You can get a random letter between "A" and "M" with this:

RandomLetter = Chr$(GenRndNumber(asc("M"), asc("A")))

You can eliminate the middle of a range by putting the call to GenRndNumber inside a DO Loop. The following will get a random number from 50 to 99 or -50 to -99.

'Initialize the number to be generated within the area you want excluded.
RandomNumber = 0
Do Until Abs(RandomNumber) > 49
RandomNumber = GenRndNumber (99, -99)
Loop

Be sure to declare RandomNumber and RandomLetter as appropriate. This procedure has a minor benefit for anyone who uses a lot of calls to the random number generator. It actually generates slightly less machine code than calls to the RND function. While not generally a concern nowadays, there may be times when a programmer will need to find a way to cut down on the amount of generated machine code.

Simulate multithreading with WaitForMultipleObjects (eg. How ICQ monitors connection state)

2006-08-19T08:24:00.000-07:00

I have used extensivly the event driven mechanism that Windows provide in manydifferent programming aspects(RDO, ADO, ODBC, Windows Sockets, Winlogon, mutexes, semaphores etc) and usedWaitForSingleObject when i was in need of an event monitor API command.

The WaitForSingleObject is located in kernel32.dll and waits until a specific event object gets signaled or when a time limit is reached. It accepts two parameters; a handle to the event object and a time-out interval.

**The main benefit of this function is that it uses no processor time while waiting for the object state

to become signaled or the time-out interval to elapse.

Hereis the declaration :

Public Declare Function WaitForSingleObject Lib "kernel32" Alias "WaitForSingleObject" _(ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long

Let's see an example of this command's usage :

In this example we are going to run the Windows calculator. We will open this shelled process and we will monitor the process handle; if it gets 0 then the process was ended.

Public Const WAIT_FAILED = &HFFFFFFFF 'Our WaitForSingleObject failed to wait and returned -1
Public Const WAIT_OBJECT_0 = &H0& 'The waitable object got signaled
Public Const WAIT_ABANDONED = &H80& 'We got out of the waitable object
Public Const WAIT_TIMEOUT = &H102& 'the interval we used, timed out.
Public Const STANDARD_RIGHTS_ALL = &H1F0000 'No special user rights needed to open this process

Public Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Public Declare Function WaitForSingleObject Lib"kernel32" (ByVal hHandle AsLong, ByVal dwMilliseconds AsLong) As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Public Sub ShelledAPP()
Dim shProcID As Long
Dim hProcess As Long
Dim WaitRet As Long

shProcID = Shell("calc.exe", vbNormalFocus)
hProcess = OpenProcess(STANDARD_RIGHTS_ALL, False, shProcID)

'This is the proper and optimized way to use the WaitForSingleObject function.

'Isaw many programmers use the INFINITE constant as forthe dwMilliseconds field.

'IfdwMilliseconds is INFINITE, the function's time-out interval neverelapses.

'That'swrong 'cause the program won't refresh thus giving the impression that is a hungapplication.

'InWindows XP specially you might see a popup screen informing you about this.

'The problem also appears when you apply WaitForSingleObject with INFINITE in an application that uses windows.

'Always use a reasonable number of milliseconds and always use DoEvents to refresh the program's message queue

Do
WaitRet = WaitForSingleObject(hProcess, 10) 'wait for 10ms to see if the hProcess was signaled
Select Case WaitRet

Case WAIT_TIMEOUT

'The first case must always be WAIT_TIMEOUT 'cause it is the most used option

DoEvents 'until the shelled process terminates

Case WAIT_FAILED or WAIT_ABANDONED
MsgBox "Wait failed or abandoned"
Exit Do

Case WAIT_OBJECT_0 'The object got signaled soinform user and get out of the loop
MsgBox "The shelled application has ended"
Exit Do

End Select
Loop

CallCloseHandle(hProcess)
'Close the process handle

Call CloseHandle(shProcID) 'Close the process id handle

DoEvents 'free any pending messages from the message queue

End Sub

Now what if we had to monitor two or more shelled applications? are we going to use multithreading?

I haven't yet implemented multithreading api in a vb.net project of mine but as you most
know, ultithreading is lethal (basically for those who will implement the CreateThread API function) when used within Visual Basic 6 (or prior).

Crashes, unexpected terminations, exceptions and many other "beautifull" encounters are some of the experiences a programmer can get.

The answer comes from WaitForMultipleObjects API function which is also included in kernel32.dll

Here is the declaration :

Public Declare Function WaitForMultipleObjects Lib "kernel32" Alias "WaitForMultipleObjects"(ByVal nCount As Long, lpHandles As Long, ByVal bWaitAll As Long, ByVal dwMilliseconds AsLong) As Long

it accepts four values :

nCount
as the maximum number of events to monitor,

lpHandles
as the array of different event handles (not multiple copies of the same one),

bWaitAll (True/False) True if it must return when the state of all objects is signaled, False if it must return when the state of any one of these objects gets signaled,

dwMilliseconds
as a maximum time-out interval

Like WaitForSingleObject, WaitForMultipleObjects can accept event handles of any of the following object types in
the lpHandles : Change notification, Console input, Waitable timer,Event, Job, Mutex, Process, Semaphore

and Threads. In the following example we are going to try something else than monitoring multiple shelled apps;

Those of you that have ICQ installed, have noticed that "red flower" icon, placed on the system tray.

When you are not connected on the internet, ICQ makes this icon look like inactive.

Now when you connect, it suddently starts to get one by one of it's leaf green,meaning that it tries to connect
to it's main server and when the connection completes, the flower get's green.

How do they do it? I mean. do they have an IsConnected() function on a timer with some interval?

Definetly no!

What they do is take advantage of WaitForMultipleObjects with another function located in rasapi32.dll; RasConnectionNotification

The RasConnectionNotification function specifies an event object that the system sets to the signaled state when

a RAS connection is created or terminated. The function accepts three values :

hrasconnas the handle to a RAS connection

hEvent as the handle to an event object

dwFlagsas the type of event to receive notifications for (RASCN_Connection or RASCN_Disconnection)

Nowwe are going to use WaitForMultipleObjects to monitor both events

Public Const RASCN_Connection = &H1 'Our two flags
Public Const RASCN_Disconnection = &H2

Public Const WAIT_FAILED = &HFFFFFFFF
Public Const WAIT_OBJECT_0 = &H0&
Public Const WAIT_ABANDONED = &H80&
Public Const WAIT_TIMEOUT = &H102&

Public Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type

Public Declare Function CreateEvent Lib "kernel32" Alias"CreateEventA" (lpEventAttributes AsSECURITY_ATTRIBUTES, ByVal bManualReset AsLong, ByVal bInitialState AsLong, ByVal lpName AsString) As Long
Public Declare Function RasConnectionNotification Lib "rasapi32.dll" Alias "RasConnectionNotificationA" (hRasConn AsLong, ByVal hEvent AsLong, ByVal dwFlags As Long) As Long
Public Declare Function WaitForMultipleObjects Lib "kernel32" (ByVal nCount As Long, lpHandles As Long, ByVal bWaitAll As Long, ByVal dwMilliseconds AsLong) As Long
Public Declare Function ResetEvent Lib "kernel32"(ByVal hEvent As Long) As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Public Sub MonitorRASStatusAsync()

Dim hEvents(1) As Long 'Array of event handles. Since there are two events we'd like to monitor, i have already
dimention it.

Dim RasNotif As Long
Dim WaitRet As Long
Dim sd As SECURITY_ATTRIBUTES
Dim hRasConn As Long

hRasConn = 0

'We are going to create and register two event objects with CreateEvent API function

'There aren't any special treated events that need any kind of security attributes sowe just initialize the structure

With sd
.nLength = Len(sd) 'we pass the length of sd
.lpSecurityDescriptor = 0
.bInheritHandle = 0
End With

'We create the event by passing in CreateEvent any security attributes,

'we want to manually reset the event after it gets signaled,

'we also want it's initial state not signaled assuming that we don't have yet any connection to the internet,

'last but not least we give the event a name (RASStatusNotificationObject1)

hEvents(0) = CreateEvent(sd, True, False, "RASStatusNotificationObject1")
'If the returned value was zero, something went wrong so exit the sub

If hEvents(0) = 0 Then MsgBox "Couldn't assign an event handle": Exit Sub

'If we succesfully created the first event object we pass it toRasConnectionNotification

'with the flag RASCN_Connection so that this event will monitor for internet connection

RasNotif = RasConnectionNotification(ByVal hRasConn, hEvents(0), RASCN_Connection)

If RasNotif <> 0 Then MsgBox "Ras Notification failure": GoTo ras_TerminateEvent
'We create the second event object exactly like the first one

'but we name it RASStatusNotificationObject2

hEvents(1) = CreateEvent(sd,True, False, "RASStatusNotificationObject2")

If hEvents(1) = 0 Then MsgBox "Couldn't assignan event handle": Exit Sub

'If we succesfully created the second event object too, we pass it toRasConnectionNotification

'with the flag RASCN_Disconnection. This event will monitor for disconnection

RasNotif = RasConnectionNotification(ByVal hRasConn, hEvents(1), RASCN_Disconnection)

If RasNotif <> 0 Then MsgBox "Ras Notification failure": GoTo ras_TerminateEvent

'We then issue the loop

'Notice that we have put hEvents array to it's first array item.

'and we used False cause we want to get notifications

'whenany of the two events occur.

Do
WaitRet = WaitForMultipleObjects(2, hEvents(0),False, 20)
Select Case WaitRet
Case WAIT_TIMEOUT
DoEvents

Case WAIT_FAILED Or WAIT_ABANDONEDOr WAIT_ABANDONED + 1
GoTo ras_TerminateEvent

Case WAIT_OBJECT_0
MsgBox "Connected"

ResetEvent hEvents(0) 'Reset the event to avoid a second message box

DoEvents 'Free any pending messages

Case WAIT_OBJECT_0 + 1
MsgBox "Disconnected"
ResetEvent hEvents(1) 'Reset the event to place it in nosignal state (Manual reset, remember?)
DoEvents

End Select

Loop

ras_TerminateEvent:
'Close all event handles

'For more than two events you could apply a For.. Next

CallCloseHandle(hEvents(1))
Call CloseHandle(hEvents(0))

DoEvents 'Free any pending messages from the application message queue

End Sub

Now imagine that you could monitor events from different objects like a file or folder change, along with connection status, shelled applications, multiple printer objects, different processes and threads etc etc etc.

(64 maximum event objects i think)

I twill appear that you program is multithreading but the truth behind that, is that you will be taking advantage of WaitForMultipleObjects internal multithreading mechanism.

DoEvents evolution; the API approach.

2006-08-19T06:50:00.001-07:00

Many of us have used several times DoEvents, to supply a bit of air to our App, on heavy-duty times such as loops for updates or inserts on recordsets etc. As we most know, DoEvents processes Windows messages currently in the message queue. But what if we wanted to execute DoEvents only in times, when we want to allow user (Keyboard and Mouse) input?

If there was such a function to inspect the message queue for user input, we would have a main benefit:

We would speed up our loops ‘cause we would process all the messages in
the queue (with DoEvents) only on user input. It’s faster to check for
a message than to process all messages every time.

API provides us with such a function: It’s called GetInputState and you can locate it in user32 library.

Here is the declaration:

Public Declare Function GetInputState Lib"user32" () As Long

The GetInputState function determines whether there are mouse-button or keyboard messages in the calling thread's message queue. If the queue contains one or more new mouse-button or
keyboard messages, the return value is nonzero else if there are no new mouse-button or keyboard messages in the queue, the return value is zero.

So we can create an improved DoEvents with a Subroutine
like this :

Public Sub newDoEvents()
If GetInputState() <> 0 then DoEvents
End Sub

You can use GetInputState() with many variations for example :

uCancelMode = False

Do until rs.Eof

Rs.AddNew

(..your source here)

Rs.Update

Rs.MoveNext

If GetInputState() <> 0 then

DoEvents

If uCancelMode Then Exit Do

End If

Loop

Msgbox “Finished.”

…or

we could use it in a ScreenSaver e.t.c.

Let’s go a little further now and see what exactly is behind GetInputState().

It is another API function located in User32 as well; GetQueueStatus()
The GetQueueStatus function indicates the type of messages found in the calling thread's message queue. Here are the flags that GetQueueStatus uses :

QS_ALLEVENTS An input, WM_TIMER, WM_PAINT, WM_HOTKEY, or posted message is in the queue.

QS_ALLINPUT Any message is in the queue.

QS_ALLPOSTMESSAGE A posted message (other than those listed here) is in the queue.

QS_HOTKEY A WM_HOTKEY message is in the queue.

QS_INPUT An input message is in the queue.

QS_KEY A WM_KEYUP, WM_KEYDOWN, WM_SYSKEYUP, or WM_SYSKEYDOWN
message is in the queue.

QS_MOUSE A WM_MOUSEMOVE message or mouse-button message (WM_LBUTTONUP, M_RBUTTONDOWN, and so on).

QS_MOUSEBUTTON A mouse-button message (WM_LBUTTONUP, WM_RBUTTONDOWN, and so on).

QS_MOUSEMOVE A WM_MOUSEMOVE message is in the queue.

QS_PAINT A WM_PAINT message is in the queue.

QS_POSTMESSAGE A posted message (other than those listed here) is in the queue.

QS_SENDMESSAGE A message sent by another thread or application is in the queue.

QS_TIMER A WM_TIMER message is in the queue.

(I believe that GetInputState() is a GetQueueStatus(QS_HOTKEY Or QS_KEY Or QS_MOUSEBUTTON))

With these constants you can create your own GetInputState function that fits your needs. For example you can create a custom function that issues DoEvents when it’ll detects not only a Keyboard or Mouse Key input, but also a WM_PAINT signal.
Why’s that? ‘cause in your loop you might need to update the screen so you must let your custom function process the specific signal.

Look at this :

Public Const QS_HOTKEY = &H80
Public Const QS_KEY = &H1
Public Const QS_MOUSEBUTTON = &H4
Public Const QS_MOUSEMOVE = &H2
Public Const QS_PAINT = &H20
Public Const QS_POSTMESSAGE = &H8
Public Const QS_SENDMESSAGE = &H40
Public Const QS_TIMER = &H10
Public Const QS_ALLINPUT = (QS_SENDMESSAGE Or QS_PAINT Or _
QS_TIMER Or QS_POSTMESSAGE Or QS_MOUSEBUTTON Or QS_MOUSEMOVE Or _
QS_HOTKEY Or QS_KEY)
Public Const QS_MOUSE = (QS_MOUSEMOVE Or QS_MOUSEBUTTON)
Public Const QS_INPUT = (QS_MOUSE Or QS_KEY)
Public Const QS_ALLEVENTS = (QS_INPUT Or QS_POSTMESSAGE Or QS_TIMER Or QS_PAINT Or QS_HOTKEY)

Public Declare Function GetQueueStatus Lib "user32" (ByVal qsFlags As Long) As Long

Public Function cGetInputState()

Dim qsRet As Long
qsRet = GetQueueStatus(QS_HOTKEY Or QS_KEY Or QS_MOUSEBUTTON Or QS_PAINT)
cGetInputState = qsRet
End Function

With this function you can trigger the DoEvents to be executed only when the message queue contains Key input, Mouse button or a WM_PAINT signal.

Call it like this….

. . if cGetInputState() <> 0
then DoEvents

Hello to all of you inspired coders.

2006-08-19T06:50:00.000-07:00

You have just landed to planet Visual Basic :-)

This is an attempt for source code tips in Visual Basic, a language most favourite for most of the coders worldwide for it's easy to use and develop concept.

Well, some times it can be rough. Real rough! (e.g. multithreading? windows services? errrr...) but in general, a coder can produce a really nice and easy solution.

My first programming language was BASIC. I remember the early 80's having my first ZX81 by Sinclair with a memory expansion chip that upgraded it's memory to 64k (whoaaaa!!!)
I wrote huge listings of BASIC just to play Centipede or Owlhunter (really cool games at that time). My storage media was a one hour cassette being played at my cassette player (Sinclair released some time later the ZX Spectrum having it's own cassette player) that took half an hour to load a decent game.... What a romantic decade of coding... (Macho finger muscles, i tell you)

Then from Visual Basic 3 ( Windows 3.1), to Visual Basic 5 with component development to Visual Basic 6. Loads of options for the developer but still a huge gap in programming options.

Microsoft did a large step in moving Visual Basic to a java-like form but still has lot to do regarding it's supported platforms, it's compiler and garbage collector etc etc etc....!

Anyway, please welcome this effort and post your thoughts and opinions or your coding tips freely. Help us grow in inspiration :-)