Need to create a 30 second delay in Visual Basic 6 - vb6

How can I create a 30 second delay in visual basic 6? I simply want VB6 to wait 30 seconds before moving on to the next line of code!!

The best approach that I know of to accomplish this in VB6 is to include a call to WaitForSingleObject or some other similar Wait API function in your loop. A good example of this approach is the MsgWaitObj function written by Sergey Merzlikin (source article):
Option Explicit
'********************************************
'* (c) 1999-2000 Sergey Merzlikin *
'********************************************
Private Const STATUS_TIMEOUT = &H102&
Private Const INFINITE = -1& ' Infinite interval
Private Const QS_KEY = &H1&
Private Const QS_MOUSEMOVE = &H2&
Private Const QS_MOUSEBUTTON = &H4&
Private Const QS_POSTMESSAGE = &H8&
Private Const QS_TIMER = &H10&
Private Const QS_PAINT = &H20&
Private Const QS_SENDMESSAGE = &H40&
Private Const QS_HOTKEY = &H80&
Private 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)
Private Declare Function MsgWaitForMultipleObjects Lib "user32" _
(ByVal nCount As Long, pHandles As Long, _
ByVal fWaitAll As Long, ByVal dwMilliseconds _
As Long, ByVal dwWakeMask As Long) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
' The MsgWaitObj function replaces Sleep,
' WaitForSingleObject, WaitForMultipleObjects functions.
' Unlike these functions, it
' doesn't block thread messages processing.
' Using instead Sleep:
' MsgWaitObj dwMilliseconds
' Using instead WaitForSingleObject:
' retval = MsgWaitObj(dwMilliseconds, hObj, 1&)
' Using instead WaitForMultipleObjects:
' retval = MsgWaitObj(dwMilliseconds, hObj(0&), n),
' where n - wait objects quantity,
' hObj() - their handles array.
Public Function MsgWaitObj(Interval As Long, _
Optional hObj As Long = 0&, _
Optional nObj As Long = 0&) As Long
Dim T As Long, T1 As Long
If Interval <> INFINITE Then
T = GetTickCount()
On Error Resume Next
T = T + Interval
' Overflow prevention
If Err <> 0& Then
If T > 0& Then
T = ((T + &H80000000) _
+ Interval) + &H80000000
Else
T = ((T - &H80000000) _
+ Interval) - &H80000000
End If
End If
On Error GoTo 0
' T contains now absolute time of the end of interval
Else
T1 = INFINITE
End If
Do
If Interval <> INFINITE Then
T1 = GetTickCount()
On Error Resume Next
T1 = T - T1
' Overflow prevention
If Err <> 0& Then
If T > 0& Then
T1 = ((T + &H80000000) _
- (T1 - &H80000000))
Else
T1 = ((T - &H80000000) _
- (T1 + &H80000000))
End If
End If
On Error GoTo 0
' T1 contains now the remaining interval part
If IIf((T1 Xor Interval) > 0&, _
T1 > Interval, T1 < 0&) Then
' Interval expired
' during DoEvents
MsgWaitObj = STATUS_TIMEOUT
Exit Function
End If
End If
' Wait for event, interval expiration
' or message appearance in thread queue
MsgWaitObj = MsgWaitForMultipleObjects(nObj, _
hObj, 0&, T1, QS_ALLINPUT)
' Let's message be processed
DoEvents
If MsgWaitObj <> nObj Then Exit Function
' It was message - continue to wait
Loop
End Function

Keep in mind that the Sleep solution in #sanderd's answer will actually lock the application. In other words, all the UI pieces will be unresponsive.
If your aim is to simply prevent the control from moving on to the next line while allowing the UI to be responsive, there are other choices.
One is to loop for 30 seconds in the following manner:
' Module Level
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
' Inside a method
Dim dt as Date
dt = Now
Do While DateDiff("s", dt, now) < 30
DoEvents
Sleep 50 ' put your app to sleep in small increments
' to avoid having CPU go to 100%
Loop
This is not the most elegant way to achieve what you want but it gets the job done.

System.Threading.Thread.Sleep(30*1000) (#Moox my bad ;))
Note that calling this method in your UI-thread will hang the entire application while waiting for 30 seconds. A better alternative would be spawning a new thread for the code you want to execute.
edit:
Since your other questions are about VB6, here's a link that provides a VB6 Sleep method:
http://www.freevbcode.com/ShowCode.Asp?ID=7556

System.Threading.Thread.Sleep(100)

For the sake of a complete set of solutions:
If you're using vb6 in an application environment (like excel), you can use
Application.OnTime (now + TimeValue("00:00:30")), "ProcedurePart2"
to call a procedure (with no parameters) after 30 seconds without locking up the application or consuming CPU power.
This would, for instance, work in any VBA environment. Depending on the nature of your VB6 app (standalone vs add-on), this option may be available to you.

Put the rest of the code in a sub and then initialize a 30 second timer to call that sub. Naturally deactivate the timer before exiting.

How about this?
Public Sub delay(PauseTime as integer)
Dim start As single
start = Timer
Do While Timer < start + PauseTime
If (Timer < start) Then 'midnight crossover
start = start - (86400 + 1)
End If
DoEvents ' Yield to other processes.
Loop
End Sub

I think Timer is the best solution , but there is a little modification.
The only method to disable the timer is to Raise an event to do this.
Example:
'Global Declaration
Private event TimeReached()
dim counter as integer
Sub Timer_Tick () handles Timer.tick
if counter>1 then
RaiseEvent TimeReached
else
counter+=1
end sub
sub TimeHandler () handles me.TimeReached
Timer.enabled=false
'Code To be Processed Here
end sub

I tried too many different ways to make a delay , and this is the most quickest method i've ever discovered
This is a program to display message after 30 second when you click a button.
sub button1_click () handles button1.click
Dim instance =now
do while now.subtract(instance).seconds<30
loop
msgbox("30 seconds passed")
endsub

Sub delay()
Dim a As Integer = TimeOfDay.Second
Do Until TimeOfDay.Second = a + 30
Loop
End Sub

Related

Visual Basic 6 - Argument not optional

I have this very simple code:
Private Sub Image87_Click()
PrintRTFWithMargins
End Sub
PrintRTFWithMargins is a function, which should "hopefully" print the contents of a RichTextBox. Every time I do run the code though, it gives me "Argument not optional" on PrintRTFWithMargins.
The code inside the function has already Option Explicit at the start, and I've tried to put it at the start of the Image87_Click too, but nothing.
Here's the code of PrintRTFWithMargins:
Option Explicit
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type CHARRANGE
cpMin As Long
cpMax As Long
End Type
Private Type FORMATRANGE
hdc As Long
hdcTarget As Long
rc As Rect
rcPage As Rect
chrg As CHARRANGE
End Type
Private Const WM_USER As Long = &H400
Private Const EM_FORMATRANGE As Long = WM_USER + 57
Private Const EM_SETTARGETDEVICE As Long = WM_USER + 72
Private Const PHYSICALOFFSETX As Long = 112
Private Const PHYSICALOFFSETY As Long = 113
Private Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function SendMessage Lib "USER32" _
Alias "SendMessageA" (ByVal hWnd As Long, ByVal msg As Long, _
ByVal wp As Long, lp As Any) As Long
Public Function PrintRTFWithMargins(RTFControl As Object, _
ByVal LeftMargin As Single, ByVal TopMargin As Single, _
ByVal RightMargin As Single, ByVal BottomMargin As Single) _
As Boolean
'********************************************************8
'PURPOSE: Prints Contents of RTF Control with Margins
'PARAMETERS:
'RTFControl: RichTextBox Control For Printing
'LeftMargin: Left Margin in Inches
'TopMargin: TopMargin in Inches
'RightMargin: RightMargin in Inches
'BottomMargin: BottomMargin in Inches
'***************************************************************
On Error GoTo ErrorHandler
'*************************************************************
'I DO THIS BECAUSE IT IS MY UNDERSTANDING THAT
'WHEN CALLING A SERVER DLL, YOU CAN RUN INTO
'PROBLEMS WHEN USING EARLY BINDING WHEN A PARAMETER
'IS A CONTROL OR A CUSTOM OBJECT. IF YOU JUST PLUG THIS INTO
'A FORM, YOU CAN DECLARE RTFCONTROL AS RICHTEXTBOX
'AND COMMENT OUT THE FOLLOWING LINE
If Not TypeOf RTFControl Is RichTextBox Then Exit Function
'**************************************************************
Dim lngLeftOffset As Long
Dim lngTopOffSet As Long
Dim lngLeftMargin As Long
Dim lngTopMargin As Long
Dim lngRightMargin As Long
Dim lngBottomMargin As Long
Dim typFr As FORMATRANGE
Dim rectPrintTarget As Rect
Dim rectPage As Rect
Dim lngTxtLen As Long
Dim lngPos As Long
Dim lngRet As Long
Dim iTempScaleMode As Integer
iTempScaleMode = Printer.ScaleMode
' needed to get a Printer.hDC
Printer.Print ""
Printer.ScaleMode = vbTwips
' Get the offsets to printable area in twips
lngLeftOffset = Printer.ScaleX(GetDeviceCaps(Printer.hdc, _
PHYSICALOFFSETX), vbPixels, vbTwips)
lngTopOffSet = Printer.ScaleY(GetDeviceCaps(Printer.hdc, _
PHYSICALOFFSETY), vbPixels, vbTwips)
' Get Margins in Twips
lngLeftMargin = InchesToTwips(LeftMargin) - lngLeftOffset
lngTopMargin = InchesToTwips(TopMargin) - lngTopOffSet
lngRightMargin = (Printer.Width - _
InchesToTwips(RightMargin)) - lngLeftOffset
lngBottomMargin = (Printer.Height - _
InchesToTwips(BottomMargin)) - lngTopOffSet
' Set printable area rect
rectPage.Left = 0
rectPage.Top = 0
rectPage.Right = Printer.ScaleWidth
rectPage.Bottom = Printer.ScaleHeight
' Set rect in which to print, based on margins passed in
rectPrintTarget.Left = lngLeftMargin
rectPrintTarget.Top = lngTopMargin
rectPrintTarget.Right = lngRightMargin
rectPrintTarget.Bottom = lngBottomMargin
' Set up the printer for this print job
typFr.hdc = Printer.hdc 'for rendering
typFr.hdcTarget = Printer.hdc 'for formatting
typFr.rc = rectPrintTarget
typFr.rcPage = rectPage
typFr.chrg.cpMin = 0
typFr.chrg.cpMax = -1
' Get length of text in the RichTextBox Control
lngTxtLen = Len(Form1.RichTextBox1.Text)
' print page by page
Do
' Print the page by sending EM_FORMATRANGE message
'Allows you to range of text within a specific device
'here, the device is the printer, which must be specified
'as hdc and hdcTarget of the FORMATRANGE structure
lngPos = SendMessage(Form1.RichTextBox1.hWnd, EM_FORMATRANGE, _
True, typFr)
If lngPos >= lngTxtLen Then Exit Do 'Done
typFr.chrg.cpMin = lngPos ' Starting position next page
Printer.NewPage ' go to next page
Printer.Print "" 'to get hDC again
typFr.hdc = Printer.hdc
typFr.hdcTarget = Printer.hdc
Loop
' Done
Printer.EndDoc
' This frees memory
lngRet = SendMessage(Form1.RichTextBox1.hWnd, EM_FORMATRANGE, _
False, Null)
Printer.ScaleMode = iTempScaleMode
PrintRTFWithMargins = True
Exit Function
ErrorHandler:
Err.Raise Err.Number, , Err.Description
End Function
Private Function InchesToTwips(ByVal Inches As Single) As Single
InchesToTwips = 1440 * Inches
End Function
I really, really don't know what else to put. It's such a simple code, just running a function, and yet "Argument not optional". It's single-hand the most annoying Visual Basic error I've ever experienced, because it's so dumb
'''
Call your function as:
Dim retVal as Boolean
retVal = PrintRTFWithMargins(RichTextBox1, 1.1, 1, 1, 1)

Faster string comparison in vb6

Am trying to make my vb6 app run faster, the reason is that am populating vbaccelerators sgrid with about 10k items all at once (this is a requirement from client).
I had to populate about 20 columns for each of the 10k items, and i have to perform string comparison in about more than half of them, so i wrote a string comparison function and did profiling
Function IsEqual(byval value1 as string, Byval value2 as string) as boolean
' content, various versions are below
End function
currently the items = 5000 and each of the time below shows the time it took and various versions of the function:
LCase$(Value1) = LCase$(value2)
time: 29149 ms
(StrComp(Value1, value2, 1) = 0 )
time: 30836 ms
If StrComp(Value1, value2, 1) = 0 Then
IsEqual = True
Else
IsEqual = False
End If
time 34180 ms
If StrComp(Value1, value2, 1) = 0 Then IsEqual = True
time 28387 ms
Timing is done with:
Declare Function timeBeginPeriod Lib "winmm.dll" (ByVal uPeriod As Long) As Long
Declare Function timeEndPeriod Lib "winmm.dll" (ByVal uPeriod As Long) As Long
Declare Function timeGetTime Lib "winmm.dll" () As Long
which returns the time in milliseconds.
Is there anyway to make the comparison faster?
Things that might improve performance include..
Change your parameters to ByRef
Using ByVal parameters copies the variables onto the stack. While this is a generally a good idea, if your comparison function is well-behaved and doesn't change the variables, making an extra copy of the data is not necessary.
Populate the grid on demand,
Only populate the parts of the grid that are showing on screen - track this with grid movement events. There are even grid controls for VB6 that facilitate this by letting you define "virtual" items and raising events to let you know which ones you need to populate. TList is the one I'm familiar with - I'll temper that suggestion with the caveat that it's licensing model can be a real PITA to work with.
This should be pretty fast.
Option Explicit
Private Declare Sub DerefByte Lib "msvbvm60" Alias "GetMem1" (ByVal Add As Long, ByRef Value As Byte)
Private Declare Sub DerefLong Lib "msvbvm60" Alias "GetMem4" (ByVal Add As Long, ByRef Value As Long)
Private Sub Form_Load()
Debug.Print IsEqual("Hello", "hello")
Debug.Print IsEqualB("Hello", "hello")
End Sub
Public Function IsEqualB(Str1 As String, Str2 As String) As Boolean
Dim lpS1 As Long, lpS2 As Long
Dim t1 As Byte, t2 As Byte
Dim lSz As Long
Dim i As Long
IsEqualB = True
lpS1 = StrPtr(Str1)
lpS2 = StrPtr(Str2)
DerefLong lpS1 - 4, lSz
If lSz = LenB(Str2) Then
For i = 0 To lSz - 1 Step 2
DerefByte lpS1 + i, t1
DerefByte lpS2 + i, t2
If Not (t1 = t2) Then
IsEqualB = False
Exit For
End If
Next
Else
IsEqualB = False
End If
End Function
Public Function IsEqual(Str1 As String, Str2 As String) As Boolean
Dim lpS1 As Long, lpS2 As Long
Dim t1 As Byte, t2 As Byte
Dim lSz As Long
Dim i As Long
IsEqual = True
lpS1 = StrPtr(Str1)
lpS2 = StrPtr(Str2)
DerefLong lpS1 - 4, lSz
If lSz = LenB(Str2) Then
For i = 0 To lSz - 1 Step 2
DerefByte lpS1 + i, t1
DerefByte lpS2 + i, t2
If Not (t1 Or &H20) = (t2 Or &H20) Then
IsEqual = False
Exit For
End If
Next
Else
IsEqual = False
End If
End Function
The basic premise here is to do byte by byte comparison mod 2 over the Unicode strings. One of the above functions is case sensitive, IsEqualB, then other is insensitive IsEqual.
Of course, it uses a couple of undocumented functions in the Visual Basic 6 runtime: but if you want speed, that's what you have to do, unfortunately.
Have you tried:
Function IsEqual(byval value1 as string, Byval value2 as string) as boolean
Return StrComp(LCase$(Value1), LCase$(value2), vbBinaryCompare) = 0
End function
You can probably cut your execution time in half by using "OPTION COMPARE TEXT". Place this line at the top of your code module.
OPTION COMPARE TEXT
This line, when used, will cause string compare within the code module be case insensitive. Because of this, you can simply use:
Function IsEqual(byval value1 as string, Byval value2 as string) as boolean
IsEqual = (Value1 = Value2)
End Function
look at the LockWindowUpdate() WinAPI call. This can really help grids when you are populating them . Make sure you call it once to lock the window and once to unlock it.

Fast way to check if a specific computer exists in my network

Well... I think the title says all. I wanna check if a pc exists on my network, for example "JOAN-PC".
Now I'm doing something like this:
Dim oShell As Object
Set oShell = CreateObject("Shell.Application")
MsgBox Not CBool(oShell.NameSpace(CVar("\\JOAN-PC")) Is Nothing)
Works good, but is slow, and my program have to call it a lot of times.
Some of you know a fast way to do the same thing?
Thanks in advance.
Perhaps you could use NetRemoteTOD or a related simple network API, even a "ping" request.
Here's a small example you might adapt. Give it a try, the timeout for machines that don't respond doesn't seem too long (7 or 8 seconds). For legit uses this probably won't be an issue, but it is long enough to discourage malicious "scanners" trying to sweep whole networks by IP address for victim machines.
Option Explicit
'Fetch and display Net Remote Time Of Day from a
'remote Windows system. Supply a UNC hostname,
'DNS name, or IP address - or empty string for
'the local host's time and date.
'
'Form has 3 controls:
'
' txtServer TextBox
' cmdGetTime CommandButton
' lblTime Label
Private Const NERR_SUCCESS As Long = 0
Private Type TIME_OF_DAY_INFO
tod_elapsedt As Long
tod_msecs As Long
tod_hours As Long
tod_mins As Long
tod_secs As Long
tod_hunds As Long
tod_timezone As Long
tod_tinterval As Long
tod_day As Long
tod_month As Long
tod_year As Long
tod_weekday As Long
End Type
Private Declare Function NetApiBufferFree Lib "netapi32" ( _
ByVal lpBuffer As Long) As Long
Private Declare Function NetRemoteTOD Lib "netapi32" ( _
ByRef UncServerName As Byte, _
ByRef BufferPtr As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
ByRef pTo As Any, _
ByRef uFrom As Any, _
ByVal lSize As Long)
Private Function GetTOD(ByVal Server As String) As Date
Dim bytServer() As Byte
Dim lngBufPtr As Long
Dim todReturned As TIME_OF_DAY_INFO
bytServer = Trim$(Server) & vbNullChar
If NetRemoteTOD(bytServer(0), lngBufPtr) = NERR_SUCCESS Then
CopyMemory todReturned, ByVal lngBufPtr, LenB(todReturned)
NetApiBufferFree lngBufPtr
With todReturned
GetTOD = DateAdd("n", _
-.tod_timezone, _
DateSerial(.tod_year, .tod_month, .tod_day) _
+ TimeSerial(.tod_hours, .tod_mins, .tod_secs))
End With
Else
Err.Raise vbObjectError Or &H2000&, _
"GetTOD", _
"Failed to obtain time from server"
End If
End Function
Private Sub cmdGetTime_Click()
Dim dtServerTime As Date
On Error Resume Next
dtServerTime = GetTOD(txtServer.Text)
If Err.Number <> 0 Then
lblTime.Caption = Err.Description
Else
lblTime.Caption = CStr(dtServerTime)
End If
On Error GoTo 0
txtServer.SetFocus
End Sub

Process monitor / dispatcher in VB6

I need to write a little application in VB6 to run instances of another VB6 application and keep an eye on the running processes, but I don't have any idea how to get process information in VB6. I can see some of what I need with the tasklist utility but I don't really know how create processes (specifying the process or application name if possible) and fetching information about processes from the operating system.
This application is to run on a Windows XP machine.
Does anyone know of a get-you-started tutorial or helpful web page for this sort of thing?
There are numerous Windows API functions you can use to do this. I'd start with looking at EnumProcesses (VB6 example and declaration here) which can be used to gather information about all running processes. You can also use OpenProcess
to start interrogating Windows about a particular process (another VB6 example).
There is also a fairly nice example on MSDN.
And of course, there is CreateProcess (AllApi link) or ShellExecute (AllApi) for spawning processes - the former gives you more control over the creation of the process, while the latter is a much simpler call.
There was another question posted about this a while back with some example code.
Another possible approach would be to use WMI (some useful snippets to adapt).
Finally, here are some tutorials that show you how to do it (I'd recommend trying it yourself first though :):
Getting Process Information using PSAPI
Another EnumProcesses/OpenProcess implementation
WMI-based demonstration
Here are some related questions although you probably already saw them when you searched this site before posting:
Monitoring processes to see if they've crashed in vb6
How can I execute a .bat file but wait until its done running before moving on?
How To Enumerate Processes From VB 6 on Win 2003?
Since you say the other application is ** also VB6**, it would be easier to make the other application into an ActiveX exe. Then you can get references to objects in the other application direct from your first application. COM solves it all for you.
Here's Microsoft's tutorial on the subject - you can download the code too.
Or here's another answer where I've written about this
You don't need to go spelunking for processes just to get a handle to child processes that you spawn. The VB6 Shell() function returns a Process ID you can use to call OpenProcess with. CreateProcess gives you the handle directly.
Ok, here is a super-stripped-down example of a program in VB6 to spawn and monitor programs. The example is coded to start and repeatedly restart 3 copies of the command shell (trivial sample child program). It is also written to kill any running children when it is terminated, and there are better alternatives to use in most cases. See A Safer Alternative to TerminateProcess().
This demo also reports back the exit code of each process that quits. You could enter exit 1234 or somesuch to see this in action.
To create the demo open a new VB6 Project with a Form. Add a multiline TextBox Text1 and a Timer Timer1 (which is used to poll the children for completion). Paste this code into the Form:
Option Explicit
Private Const SYNCHRONIZE = &H100000
Private Const PROCESS_QUERY_INFORMATION = &H400&
Private Const PROCESS_TERMINATE = &H1&
Private Const WAIT_OBJECT_0 = 0
Private Const INVALID_HANDLE = -1
Private Const DEAD_HANDLE = -2
Private Declare Function CloseHandle Lib "kernel32" ( _
ByVal hObject As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" ( _
ByVal hProcess As Long, _
ByRef lpExitCode As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" ( _
ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" ( _
ByVal hProcess As Long, _
ByVal uExitCode As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" ( _
ByVal hHandle As Long, _
ByVal dwMilliseconds As Long) As Long
Private Tasks() As String
Private Handles() As Long
Private Sub Form_Load()
Dim I As Integer
'We'll run 3 copies of the command shell as an example.
ReDim Tasks(2)
ReDim Handles(2)
For I = 0 To 2
Tasks(I) = Environ$("COMSPEC") & " /k ""#ECHO I am #" & CStr(I) & """"
Handles(I) = INVALID_HANDLE
Next
Timer1.Interval = 100
Timer1.Enabled = True
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Dim I As Integer
Timer1.Enabled = False
DoEvents
For I = 0 To UBound(Tasks)
If Handles(I) <> INVALID_HANDLE And Handles(I) <> DEAD_HANDLE Then
TerminateProcess Handles(I), 666
CloseHandle Handles(I)
Handles(I) = DEAD_HANDLE
End If
Next
End Sub
Private Sub Timer1_Timer()
Dim I As Integer
Dim ExitCode As Long
Dim Pid As Long
Timer1.Enabled = False
For I = 0 To UBound(Tasks)
If Handles(I) <> INVALID_HANDLE Then
If WaitForSingleObject(Handles(I), 0) = WAIT_OBJECT_0 Then
If GetExitCodeProcess(Handles(I), ExitCode) <> 0 Then
Text1.SelText = "Task " & CStr(I) & " terminated, " _
& "exit code: " & CStr(ExitCode) _
& ", restarting task." _
& vbNewLine
Else
Text1.SelText = "Task " & CStr(I) & " terminated, " _
& "failed to retrieve exit code, error " _
& CStr(Err.LastDllError) _
& ", restarting task." _
& vbNewLine
End If
CloseHandle Handles(I)
Handles(I) = INVALID_HANDLE
End If
End If
If Handles(I) = INVALID_HANDLE Then
Pid = Shell(Tasks(I), vbNormalFocus)
If Pid <> 0 Then
Handles(I) = OpenProcess(SYNCHRONIZE _
Or PROCESS_QUERY_INFORMATION _
Or PROCESS_TERMINATE, 0, Pid)
If Handles(I) <> 0 Then
Text1.SelText = "Task " & CStr(I) & " started." _
& vbNewLine
Else
Text1.SelText = "Task " & CStr(I) _
& ", failed to open child process." _
& vbNewLine
Handles(I) = DEAD_HANDLE
End If
Else
Text1.SelText = "Task " & CStr(I) _
& ", failed to Shell child process." _
& vbNewLine
Handles(I) = DEAD_HANDLE
End If
End If
Next
Timer1.Enabled = True
End Sub
Hopefully this helps answer the question.
something more simple will use sockets.
Launch you app server and on your client implements the communication against your server. With that you will provide intercommunication.
well i say. because i dont be what you try do
Sorry it only apply if your clients are done in house i you have the option of added changes

App.PrevInstance not refreshing itself

I am trying to check to see whether another instance of the application is already running. If it does, I want to keep on checking for another 15 seconds or so before going on...
if App.PrevInstance then
dim dtStart as date
dtStart = now
do while datediff("s", dtStart, Now) < 15
Sleep 1000 ' sleep for a second
if not App.PrevInstance then exit do
loop
end if
The problem is App.PrevInstance does not seem to refresh itself. it keeps the initial value no matter what.
Is there another way to approach this? Perhaps with API calls. Note that the application may or may not have a window, thus I can't check for an existence of a window with a certain caption.
You might want to give this a look: http://www.codeguru.com/forum/showthread.php?t=293730
I use the following class:
'--------------------------------------------------------------------------------------- ' Module : CApplicationSingleton ' DateTime : 24/03/2006 15:16 ' Author : Fernando ' Purpose : Enforces a single instance of an application. Uses a Mutex ' see http://www.codeguru.com/forum/showthread.php?s=&threadid=293730 ' http://www.codeguru.com/Cpp/W-P/system/processesmodules/article.php/c5745/ ' Copyright © 2001-2007 AGBO Business Architecture S.L. '---------------------------------------------------------------------------------------
Option Explicit
Private Declare Function CreateMutex Lib "kernel32" Alias "CreateMutexA" (lpMutexAttributes As SECURITY_ATTRIBUTES, ByVal bInitialOwner As Long, ByVal lpName As String) As Long Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Const ERROR_ALREADY_EXISTS = 183&
Private m_hMutex As Long Private m_lLastDllError As Long
Private Sub Class_Initialize() '
On Error GoTo errorBlock
'
Dim s As SECURITY_ATTRIBUTES
m_hMutex = CreateMutex(s, 0, rcString(8700)) m_lLastDllError = Err.LastDllError
'
exitBlock:
Exit Sub
errorBlock:
Call GError.handleError(Err.Number, Err.Description, Erl, "CApplicationSingleton", "Class_Initialize", GApp.copyDebugFiles())
Resume exitBlock
' End Sub
Private Sub Class_Terminate() On Error GoTo errorBlock
If m_hMutex > 0 Then
Call CloseHandle(m_hMutex) End If
exitBlock:
Exit Sub
errorBlock:
Call GError.handleError(Err.Number, Err.Description, Erl, "CApplicationSingleton.cls", "Class_Terminate")
Resume exitBlock
End Sub
Public Function IsAnotherInstanceRunning() As Boolean '
On Error GoTo errorBlock
'
IsAnotherInstanceRunning = (m_lLastDllError = ERROR_ALREADY_EXISTS)
'
exitBlock:
Exit Function
errorBlock:
Call GError.handleError(Err.Number, Err.Description, Erl, "CApplicationSingleton", "IsAnotherInstanceRunning", GApp.copyDebugFiles())
Resume exitBlock
' End Function
I used the Mutex class to work out the same issue with starting the same app multiple times. It appeared to be working then stopped working returning a false positive. What I found is that the vb6 IDE was also holding a mutex while the IDE was still open.
You've gotta use the code and compile it. The EXE will work fine after you close the IDE.. Who knew? Drove me crazy(ier) for a few minutes..
I'll post a sample if anyone wants it.

Resources