Solved

Need help with a "background" program

Posted on 2006-11-28
16
662 Views
Last Modified: 2009-07-29
OK guys this one has been bugging me for a long time. First let me say I am a database programmer through and through, I work with VB and VBA in Access and SQL and that is it. I don't know from .dlls, threads, compartment threading,etc. and while I would LIKE to, I just don't have the time to learn this stuff. Having said that here is my problem. Also, this is a commercial app. It runs on other peoples networks over which I have no control, and I am not a networking expert either, though I will learn what I need to to support our stuff.

I have a small VB program which runs in the 'background' I use the windows sleep function to suspend the application. Every 5 minutes it 'wakes up', checks for a certain file on the network using 'Dir' and if the file exists begins a shutdown procedure of another app (an access program). If the file doesn't exist it checks to see if any of our programs are still running if they are not the program ends, otherwise it just goes back to sleep. However, I also found that, on some customers networks, even though our program was loaded, and was holding locks on our server files, the local computer seemd to 'drop' the network connection after a certain period of time so the Dir command would fail with a path not found error of some sort. My solution was the code that simply opens and saves, then deletes, a small file to network drive. This code is there solely to hold the net connection open so the Dir command won't fail.

Let me say also, the shutdown procedure works fine, the issue seems to be when it is doing its 5 minute check.

The problem is, when this program is running users complain that "Their printers don't always work right." Other 'anomalies' are reported as well. I have a hunch it has to do with this little program interrupting something else to run its little dir command and goes back to sleep. I tried doing this with a timer directly in our Access application which was the easy way, but that would cause occasional Database corruption.

The ENTIRE module is listed below, there is a form with one button to close it which informs the user of what is happening, but I have left that FORM/code out. There is no real rush on this, I would just like to find a clean way to run a timer and periodically check on things without screwing up anything else.

Any help is appreciated.

Kim


**************  VB MODULE STARTS HERE  ********************

Option Explicit

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function FindWindowEx& Lib "user32" Alias "FindWindowExA" (ByVal hWndParent As Long, ByVal hWndChildAfter As Long, ByVal lpClassName As String, ByVal lpWindowName As String)
Declare Function GetWindowText& Lib "user32" Alias "GetWindowTextA" (ByVal HWnd As Long, ByVal lpString As String, ByVal cch As Long)
Declare Function TerminateProcess& Lib "kernel32" (ByVal HProcess As Long, ByVal uExitCode As Long)
Declare Function SendMessage& Lib "user32" Alias "SendMessageA" (ByVal HWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any)
Declare Function BringWindowToTop& Lib "user32" (ByVal HWnd As Long)
Declare Function PostMessage& Lib "user32" Alias "PostMessageA" (ByVal HWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any)
Const WM_CLOSE As Long = &H10


Declare Function GetWindowThreadProcessId& Lib "user32" (ByVal HWnd As Long, lpdwProcessId As Long)
Declare Function OpenProcess& Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long)
Declare Function WaitForSingleObject& Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long)
Private Declare Function IsWindow Lib "user32" (ByVal HWnd As Long) As Long
Declare Function GetLastError& Lib "kernel32" ()
Declare Function FlashWindow& Lib "user32" (ByVal HWnd As Long, ByVal bInvert As Long)
Declare Function SetFocusAPI& Lib "user32" Alias "SetFocus" (ByVal HWnd As Long)

Const INFINITE = &HFFFFFFFF
'Const SYNCHRONIZE = &H100000
Const PROCESS_ALL_ACCESS = &H1F0FFF

Declare Function GetWindowLong& Lib "user32" Alias "GetWindowLongA" (ByVal HWnd As Long, ByVal nIndex As Long)
Public Const GWL_WNDPROC = (-4)
'3/15/06 - added code to write ti and delete a file to try and hold server connection open



Public Sub CheckForNeedToClose(FileName As String, DummyFile As String)
Dim SleepTime As Long, X As Integer, WTxt As String, HWnd As Long, AccObj As Object, DontCLose As Boolean, HWndTest As Long, HWndSub As Long
Dim ProcessID As Long, HProcess As Long, HProcessSub As Long, HThread As Long, Temp As Long, HadToTerminate As Boolean, FastVersion As Boolean
On Error Resume Next  'this is for safety - as designed it should not throw errors

 'UNREM and set the next THREE lines for THE FAST TEST VERSION
'FastVersion = True
'FileName = "\\Issserver\BigDrive\DataSK\CH\SkClose.txt"
'DummyFile = "\\Issserver\BigDrive\DataSK\CH\Test.txt"


SleepTime = 300000 '300000 is 5 minutes
If FastVersion Then
    SleepTime = 10000 '300000 is 10 seconds
    MsgBox "This is the Test ISS SkCloseApps.exe"
End If
X = 2
Do
    Sleep SleepTime
    'if we get no OMains then no Access session is loaded so we can end
    HWnd = FindWindow("OMain" & vbNullString, vbNullString)
    If HWnd = 0 Then End  'No Access windows open so terminate
    DontCLose = False
    '"OMain" is the main Access window. If the only "OMain" open is rep and comp then we can close this app
    Do
        DoEvents
        WTxt = Space$(50)
        GetWindowText HWnd, WTxt, 50&
        If Left$(WTxt, 39) <> "Repair and Compact ShopKeeper Databases" Then DontCLose = True
        HWnd = FindWindowEx(0, HWnd, "OMain", vbNullString)
    Loop While HWnd <> 0
    If DontCLose = False Then End 'Only thing open is rep and comp
    'End of tests for closing
    DoEvents
    'If the filename is there then we are throwing everyone out. So start giving warnings
    If Dir(FileName) > "" Then

'********* FOR EXPERTS EXCHANGE PURPOSES I BELIEVE THIS CAN BE IGNORED ****************

        If Err.Number > 0 Then '11/2/05 - Added this if.
            If Err.Number <> 52 Then '1/10/06 - Bad file name or number - we get this if we tempoorarily lost the network. Ignore it we may get the net back with no issues.
                MsgBox "An error occurred in SkCloseApps. Please make a note of the error in the next dialog and notify Insite Software Solutions."
                MsgBox Err.Description & vbCrLf & "Error Number: " & Err.Number
            End If
        Else
            SkCloseAppsFrm.Text1.Text = GetFileData(FileName)
            If SkCloseAppsFrm.Text1.Text = "" Then
                SkCloseAppsFrm.Text1.Text = "SHUTDOWN IN " & CStr(X) & " minutes!" & vbCrLf & vbCrLf & "ShopKeeper maintenance is about to be performed. Please close ALL ShopKeeper and Access Applications."
            End If
            If X = 0 Then
                SkCloseAppsFrm.Text1.Text = "SHUTTING DOWN YOUR ACCESS APPLICATIONS NOW!." & vbCrLf & vbCrLf & SkCloseAppsFrm.Text1.Text
            Else
                SkCloseAppsFrm.Text1.Text = "SHUTDOWN IN " & CStr(X) & " minutes!" & vbCrLf & vbCrLf & SkCloseAppsFrm.Text1.Text
            End If
            SkCloseAppsFrm.Show
            Beep
            Beep
            DoEvents
            If X = 0 Then Exit Do
            X = X - 1
            SleepTime = Timer + 60  '60 for 60 seconds
            If FastVersion Then SleepTime = Timer + 10  '10 for 10 seconds
            'we have to switch to our own deal because sleep freezes everything
            Do
                DoEvents
                If Timer < 60 Then Exit Do 'fix up midnight
            Loop While SleepTime > Timer
            SleepTime = 0
        End If

'********* END OF EXPERTS EXCHANGE CODE TO BE IGNORED ****************

    Else 'we might have changed our minds so reset
        SleepTime = 300000  '300000 is 5 minutes
        If FastVersion Then SleepTime = 10000 '300000 is 10 seconds
        X = 2
        '3/14/06 Hold our connection open buy writing and deleting to a dummy file
        If Dir(DummyFile) Then
            Sleep 2000 ' we are on exactly the same schedule as someone else so stagger it by 2 seconds
            Kill DummyFile
        End If
        Open DummyFile For Output As #1
        Print #1, "Delete this file"
        Close #1
        DoEvents
        Kill DummyFile
        Err.Clear
        'end 3/14/06
    End If
    If Err.Number <> 0 Then Err.Clear
Loop

SkCloseAppsFrm.OKBtn.Enabled = False
Sleep 3000  ' if they were in the middle of writes give them a couple of seconds to finish
SkCloseAppsFrm.OKBtn.Enabled = True

Do
    DontCLose = False
    HWnd = FindWindow("OMain" & vbNullString, vbNullString)
    If HWnd = 0 Then Exit Do  'No Access windows open
    DontCLose = False
    Do
        WTxt = Space$(50)
        GetWindowText HWnd, WTxt, 50&
        If Left$(WTxt, 39) <> "Repair and Compact ShopKeeper Databases" Then
            'SkCloseAppsFrm.Hide
            BringWindowToTop HWnd
            HThread = GetWindowThreadProcessId(HWnd, ProcessID) 'takes two lines to get a handle to a process
            HProcess = OpenProcess(PROCESS_ALL_ACCESS, 0&, ProcessID)
            PostMessage& HWnd, WM_CLOSE, 0&, 0&
            Temp = WaitForSingleObject(HProcess, 5000&)  'Wait 5 sec for close
            If IsWindow(HWnd) = 1 Then   'Window still loaded - try sending a space
                HadToTerminate = True
                SendKeys "   " 'try to close with the spacebar
                DoEvents
                Temp = WaitForSingleObject(HProcess, 5000&)  'Wait 5 sec for close
                If IsWindow(HWnd) = 1 Then  'Still didn't close so terminate it
                        HThread = GetWindowThreadProcessId(HWndSub, ProcessID) 'takes two lines to get a handle to a process
                        HProcessSub = OpenProcess(PROCESS_ALL_ACCESS, 0&, ProcessID)
                        Temp = TerminateProcess(HProcessSub, 0&)
                End If
             End If
            DontCLose = True
        End If
        HWnd = FindWindowEx(0, HWnd, "OMain", vbNullString)
        X = X + 1: If X = 50 Then Exit Do  'We'll try 50 times
    Loop While HWnd <> 0
    X = X + 1: If X = 10 Then Exit Do  'We'll try 10 times
Loop While DontCLose = True

'If we had to terminate an app leave a message on the screen
If HadToTerminate Then
    SkCloseAppsFrm.Text1.Text = "ERROR! There was an error closing a ShopKeeper application normally so the program was shut down. This can leave Windows in an unstable state. You should RESTART WINDOWS!" & vbCrLf & vbCrLf & _
    "This is generally the result of a record being left in an unsaved state or a dialog box such as a print dialog being left open." & vbCrLf & _
    "It is good practice to ALWAYS close ShopKeeper applications when not in use, and NEVER leave unsaved changes sitting on the screen. This is good practice with any multiuser application."
    SkCloseAppsFrm.Hide
    SkCloseAppsFrm.Show 1
    End
Else
    End
End If


'SkCloseAppsFrm.Text1.LinkMode = 0
'For X = 1 To 20
'    SkCloseAppsFrm.Text1.LinkTopic = "MSACCESS|SYSTEM"
'    SkCloseAppsFrm.Text1.LinkTopic = "C:\Program Files\ShopKeeper\Sk2002.mde"
'    'SkCloseAppsFrm.Text1.LinkItem = "Topics"
'    'SkCloseAppsFrm.Text1.LinkItem = ""
'    SkCloseAppsFrm.Text1.LinkMode = 2     ' Establish a manual DDE link to Access
'    SkCloseAppsFrm.Text1.LinkRequest
'    MsgBox SkCloseAppsFrm.Text1
'    If InStr(SkCloseAppsFrm.Text1, "\Rep&Comp") = 0 Then
'        SkCloseAppsFrm.Text1.LinkExecute "[Quit]"
'    End If
'    Sleep 2
'    SkCloseAppsFrm.Text1 = ""
'    SkCloseAppsFrm.Text1.LinkMode = 0     ' Terminate the DDE link to Access
'    DoEvents
'    If Err.Number = 0 Then SendKeys "      "
'    Err.Clear
'Next X
'End

End Sub

Sub Main()

If App.PrevInstance Then End

'If Command$ = "" Then msgbox "This program requires a command line agrument consisting of the the path to the shopkeeper data files and End

CheckForNeedToClose App.Path & "\SkClose.txt", App.Path & "\Test.txt"

End Sub

Private Function GetFileData(Fname As String) As String
Dim St As String
On Error Resume Next
    Open Fname For Binary Shared As #1 Len = 1000
    Input #1, St
    GetFileData = RTrim$(St)
    Close #1
    If Err.Number <> 0 Then Err.Clear
End Function

*********** END OF MODULE ********************

0
Comment
Question by:KMosher
  • 7
  • 3
  • 3
  • +2
16 Comments
 
LVL 10

Expert Comment

by:sakuya_su
ID: 18033797
hey I was just wondering while reading you code..

why not just stick all of this into a VB timer? it cleans up the code a little.

as far as I can see there isnt any reason for any strange behaviours, can you please explain a little more about the errors you get with the code?

I use an almost exact method(but with a form timer) with a boss key thing I have (Which terminates a program when a key is pressed)
0
 
LVL 17

Accepted Solution

by:
inthedark earned 250 total points
ID: 18035639
Wow you are going to need a lot of help


1)  For example you should never use the API Sleep for more than a second because you can cause windows to hang if windows sends your app a system message.  There are ways of doing this without any impact on CPU time.

Here is an example long sleep loop:

Conts OneSecond As Double = 1#/(24#*60#*60#)
Conts OneMinute As Double = 1#/(24#*60#)

Dim dtWaitUntil As Date



dtWaitUntil = Now + OneMinute * 5 ' Wait five minutes

Do Until Now>dtWaitTime
    Sleep 1000 ' just sleep for a short while allowing Windows to send your app messages.
    DoEvents
Loop
NowSreachFolder

2) A Dir is a function loop is way too buggy.

You are much better off creating a watch for folder change notification to interrupt you when the file has been created.

Do
    Sleep 1000 ' just sleep for a short while allowing Windows to send your app messages.
    If bChanges Then
         HandleFolderChange
    End If
    If bStopping Then
       Exit Do
    End If  
    DoEvents
Loop
0
 
LVL 17

Expert Comment

by:inthedark
ID: 18035717
So just in case you did not understand the reasone why stanges things are happening iss that when you app is in a sleep state if windows sends it a system message, it will not accept the message until the end of the sleep period.

Also your application is going to take perhaps an extra 5 minutes before any file is found.  I create a simple class that returns the name of a file as soon as it is created.

Dim WFC With Events As zWaitForChange ' in module level

' in startup sub

        Set WFC = New zWaitForChange
        WFC.NotifyAction = wfcReturnFolder ' can return different notify actions
        mbWFCLoaded = True
        OK = WFC.StartWaitingOK(options.MirScanFolder)
        If Not OK Then
            MsgBox "Unable to watch folder: " + options.MirScanFolder + vbCrLf + WFC.ErrD + "(" + CStr(WFC.ErrN) + ")"
            End
        End If

This even works if the folder is located on another server.

I created a handler class module to make it all work.  But I borrowed the concepts from here:

http://www.desaware.com/tech/filemonitoring.aspx


0
 
LVL 17

Expert Comment

by:inthedark
ID: 18035724
And now in english:

So just in case you did not understand the reason why strange things are happening is that when your app is in a sleep state if windows sends it a system message, it will just hand windows so nothing on you server will work.
0
 
LVL 26

Expert Comment

by:EDDYKT
ID: 18036047
you may want to use SetWaitableTimer instead of sleep
0
 
LVL 29

Expert Comment

by:nffvrxqgrcfqvvc
ID: 18042681
Your task is alot simpler than you may think if you make a couple of changes.

 << also found that, on some customers networks, even though our program was loaded, and was holding locks on our server files, the local computer seemd to 'drop' the network connection after a certain period of time so the Dir command would fail with a path not found error of some sort. My solution was the code that simply opens and saves, then deletes, a small file to network drive. >>

FIX: Windows 2000 and Windows XP
You can use WNetRestoreConnection to re-map the network drive if it happens to disconnect.
http://msdn.microsoft.com/library/en-us/wnet/wnet/wnetrestoreconnectionw.asp

<< checks for a certain file on the network using 'Dir' and if the file exists begins a shutdown procedure of another app (an access program). If the file doesn't exist it checks to see if any of our programs are still running if they are not the program ends, otherwise it just goes back to sleep. >>

FIX: You can use what has already been mentioned by *inthedark* and *EDDYKT* use an alternative check routine, your applications doesn't need to Sleep at all because all you really want to do is check every 5 minutes, a timer would work great for this situation to run your block of code to check for the process every 5 minutes. You also have other alternatives, SetTimer,KillTimer API if you dont want to use a timer and might be a little simpler than SetWaitableTimer to implement.

The basic idea is to have 3 routines

1. Check if the network drive is mapped, if it is not use WNetRestoreConnection to restore the connection, at that time it will either restore the connection or prompt the user with a dialog to enter the username and password to restore the connection.

2. Use a timer or SetTimer,KillTimer API to check whether the file exists on the network.

3. Implement your routine that checks for the running processes and take the appropriate actions.
0
 
LVL 29

Expert Comment

by:nffvrxqgrcfqvvc
ID: 18042914
' For the network portion here is a quick example I wrote


' ---- netdrive.bas ----


Option Explicit

Private Declare Function WNetRestoreConnectionW Lib "mpr.dll" (ByVal hwndParent As Long, ByVal lpDevice As Long) As Long
Private Declare Function WNetAddConnection2W Lib "mpr.dll" (ByVal NETRESOURCE As Long, ByVal lpPassword As Long, ByVal lpUserName As Long, ByVal dwFlags As Long) As Long
Private Declare Sub push Lib "kernel32" Alias "RtlMoveMemory" (xDest As Any, xSource As Any, ByVal nBytes As Long)

Public Function restoreDrive(ByVal device As String) As Long
    restoreDrive = WNetRestoreConnectionW(0&, StrPtr(device))
End Function

Public Function connectDrive(ByVal lpUser As String, ByVal lpPass As String, ByVal lpLocal As String, ByVal lpRemote As String)

    Dim NET(31) As Byte ' NETRESOURCE
   
    NET(0) = 2
    NET(4) = 0
    NET(8) = 3
    NET(12) = 1
   
    push NET(16), StrPtr(lpLocal), 4
    push NET(20), StrPtr(lpRemote), 4
   
    connectDrive = WNetAddConnection2W( _
            ByVal VarPtr(NET(0)), _
            StrPtr(lpPass), _
            StrPtr(lpUser), _
            1)
   

End Function



' Use the routine to connect a network resource disk

connectDrive "username", "password", "Z:", "\\192.168.1.107\H$"

' If you dont have a password on the network disk

connectDrive vbNullString, vbNullString, "Z:", "\\192.168.1.107\H$"
0
What Should I Do With This Threat Intelligence?

Are you wondering if you actually need threat intelligence? The answer is yes. We explain the basics for creating useful threat intelligence.

 
LVL 2

Author Comment

by:KMosher
ID: 18043088
First off I want to thank everyone for their help.

everyone: I did not use a do:sleep:doevents:loop in VB because I was very concerned that it would be extremely ineficient. I always assume that if it is VB than there will be a lot of overhead. I thought better to just put my little app to sleep. Does anyone have any thoughts on that? Regarding timers, since everything seems to use a do:doevents:loop anyway what is wrong with just doing the code below and skipping al these calls to windows functions? - the big question, is it more processor intensive???

dim T as Long  'use a long since we dont care about fractions of a second
t=timer+300  '300=5 min.
if t>86400 then t=86399  'takes care of midnight, I don't care if once a day we check more often than every 5 minutes
do
  doevents
loop while timer<t

Also, a clarification the file being looked for is NOT CREATED ON THE LOCAL MACHINE. Therefore things like the windows function FindFirstChangeNotification will not work. I know, I found demo code and tested it.




sakuya_su:
I didn't use a timer becuase I worry about how effecient it is. It is one thing to use it in your own app, another to use it in something that is going to be running, essentially, all day long in the background. As I metioned, I tried doing this from within our app using a timer but we found that it would corrupt our database. Evidently the timer would fire occasionaly in the middle of DB Writes and so they would never finish.

inthedark :
I understand about the system messages. Do you think the printer drivers are sending my app messages and it is failing because of that? It is true when the user shuts down I get an app not responding message for just the reason you describe.
What is zWaitForChange? I looked at the desaware code and found a demo elsewhere that uses FindFirstChangeNotification, I tested it and it seems to work across a network OK. I can create a seperate directory and monitor it for the one file I am interested in. I don't want to monitor the current data directory because it has the DB in it and is constantly changing so FindFirstChangeNotification would be constantly returning.
0
 
LVL 17

Expert Comment

by:inthedark
ID: 18044253
A) Yes you need to create a speperate folder which is known in the biz as a dropfolder. The drop folder should have a Temp folder within.

1)  The data is first saved to the Temp folder.
2) When the data file is complete the file is closed.
3) You action a delay for about .1 seconds (becuase of a bug in windows 2003 server buffer flushing).  
4) You then rename the file so that its new path is within the drop folder.

B) You made a comment:

>I didn't use a timer becuase I worry about how effecient it is. It is one thing to use it in your own app, another to use it in >something that is going to be running, essentially, all day long in the background. As I metioned, I tried doing this from >within our app using a time

Just to put your mind at rest a loop like this:

dtWaitUntil = Now + OneMinute * 5 ' Wait five minutes

Do Until Now>dtWaitTime
    Sleep 1000 ' just sleep for a short while allowing Windows to send your app messages.
    DoEvents
Loop

Will only use about 1 second of CPU time per week.

C) Take on board that at least 2 people have found problems with Dir, it is buggy never use it.

I will post you a better method.

D) also note that if your are deleting files it is better to first add them into a collection., Then when you have completed  processing the folder your are working on, kill the files in the collection.

If you are using Watchfolder stop it while you make changes to the folder.

0
 
LVL 17

Expert Comment

by:inthedark
ID: 18044288
Further when Windows sends system WinProc messages, if the message needs to send any data, the data has to be allocated somewhere in system memory. Windows will send the message into your queue, which it expects you to pickup instantly and then windows deallocates the memory.
0
 
LVL 2

Author Comment

by:KMosher
ID: 18048010
I was wrong. FindFirstChangeNotification does work across the newtwork, my bad.

wouldn't it be cleaner to do something like this?

Hndl = FindFirstChangeNotification ...  'set up the notification

Do
     if WAIT_OBJECT_0 = WaitForSingleObject(Hndl, 1000) Then Exit Do
    DoEvents
Loop
 This way I don't have to wait 5 min. to find out if I have the file I am looking for.

or is WaitForSingleObject less efficient than Sleep?
0
 
LVL 29

Expert Comment

by:nffvrxqgrcfqvvc
ID: 18051339
FindFirstChangeNotification is only going to tell you that a change occured, if you are using WaitForSingleObject than there is no point to use that in a loop since it only going to proceed when the event is changed to a signaled state and this only happens when some type of change has occured. Yes its ok if you are waiting on an event handle to be singaled your application will act exactly like a Sleep call by freezing whatever code you may try to run until that event occurs.
0
 
LVL 2

Author Comment

by:KMosher
ID: 18051639
egl1044 that is what I was thinking. You can actually tell FindFirstChangeNotification what to look for to some degree. I am looking for a particular file so if there is a change I can check for the file and if it isn't there go back to my loop.
0
 
LVL 17

Expert Comment

by:inthedark
ID: 18052684
Here is a class I created for wait for change.  

There are 4 things you need:

Start up - to start the waiting

Control Loop - to see if any changes made

Event Handling (3 types of event notification)

How to shut down.

Examples for above are included in the class declarations.

' Here is the class module
'======================zWaitForChange.cls
Option Explicit

'Created by: Nick Young nyoung@vipintersoft.com
'Date 23-DEC-04
' Please advise of any bugs or improvements


'Monitoring file/folder changes
' borowed concepts from:
' http://www.desaware.com/tech/filemonitoring.aspx

' How to use:
''================================================
'' In module declarations:

'Dim WithEvents WFC As zWaitForChange
'Dim mbScanNow As Boolean
'Dim msWatchFolderName As String


''================================================
'' Start Waiting

'' When you want to start wait for change
'' Set folder name
'msWatchFolderName = "\\myserver\myshare\myfolder\"
' Create watch

'Set WFC = New zWaitForChange


' 3 types of events are provided only one at a time may be used

' To return the name of a folder that has changed
'WFC.NotifyAction = wfcReturnFolder ' set response event type

' To return the file name
'WFC.NotifyAction = wfcReturnFileName

' To return the file content
'WFC.NotifyAction = wfcReturnContent


'mbWFCLoaded = True
'OK = WFC.StartWaitingOK(msWatchFolderName)
'If Not OK Then
'    MsgBox "Unable to watch folder: " + options.MirScanFolder + vbCrLf + WFC.ErrD + "(" + CStr(WFC.ErrN) + ")"
'    End
'End If

''================================================
'' Main Loop
'mdtNextFallbackScan = Now = GF.cSeconds(5 * 60)
'
'Do
'
'   WFC.CheckForChange  ' see if changes to trigger events
'   ' Need something like this if wfcReturnFolder is set
'   If mbScanNow Then
'        mbScanNow = False
'        ScanFolderForFiles msFolderName
'   End If
'
'   ' Need this as sometimes windows forgets notify events
'   ' So need manual check say evey 5 minutes
'   If Now > mdtNextFallbackScan Then
'        WFC.CheckForChange  ' force manual folder check
'        mdtNextFallbackScan = Now = GF.cSeconds(5 * 60)
'   End If
'
'   ' Shut Down App
'   If mbStopRequest Then
'       WFC.StopWaiting
'       Set WFC = Nothing
'       Exit Do
'   End If
'
'   Sleep 1000
'   DoEvents
'Loop
   
   
'=============Event when: NotifyAction = wfcReturnFolder
' Change events dependent on NotifyAction
'Private Sub WFC_FolderChanged(FolderName As String)
' This event triggered when folder change
'mbScanNow = True
'msFolderName = FolderName ' don't really need this
'End Sub

'=============Event when: NotifyAction = wfcReturnFileName
'Private Sub WFC_FileChanged(FileName As String, CancelDelete As Boolean)
' Example move file to diffetent folder
' but if this action fails CancelDelete = True will
' stop WFC auto deleting the file
'
'Dim sData As String
'Dim OK
'sData = GF.ReadFile(msWatchFolderName + sFileName) ' read data
'
'OK = GF.WriteFileOK(msSavePath + sFileName) ' save data
'If Not OK Then
'    CancelDelete = True ' supress file deletions
'End If
'End Sub

'=============Event when: NotifyAction = wfcReturnContent
'Private Sub WFC_FileChangedContent(FileName As String, FileContent As String, CancelDelete As Boolean)
'Dim OK
'OK = DecodeContent(FileContent, FileName)
'If Not OK Then
'    CancelDelete = True
'End If
'End Sub

'============ End of How To Use

Public Event FolderChanged(FolderName As String)
Public Event FileChanged(FileName As String, CancelDelete As Boolean)
Public Event FileChangedContent(FileName As String, FileContent As String, CancelDelete As Boolean)

Dim mdtLastScan As Date


Public ID As Long

Public ErrD As String
Public ErrN As Long
 
Dim FOP As New zFOP
Dim GF As New zGF


Dim mlWaitHandle As Long
Dim msFolderName As String
Dim mbIncludeSubFolders As Boolean
Dim mlInterval As Long
Dim mbOneDone As Boolean
Dim mlNotify As Long
Dim mlNotifyAction As Long


Private Declare Function FindFirstChangeNotification Lib "kernel32" Alias "FindFirstChangeNotificationA" (ByVal lpPathName As String, ByVal bWatchSubtree As Long, _
    ByVal dwNotifyFilter As Long) As Long

Public Enum NotifyOptionsList
    wfcFileNAME = &H1
    wfcDIR_NAME = &H2
    wfcATTRIBUTES = &H4
    wfcSIZE = &H8
    wfcLAST_WRITE = &H10
    wfcLAST_ACCESS = &H20
    wfcCREATION = &H40
    wfcSECURITY = &H100
End Enum

' Event notification methods
Public Enum NotifyActionList
    wfcReturnFolder
    wfcReturnContent
    wfcReturnFileName
End Enum

Private Declare Function FindCloseChangeNotification Lib "kernel32" _
   (ByVal hChangeHandle As Long) As Long
Private Declare Function FindNextChangeNotification Lib "kernel32" _
   (ByVal hChangeHandle As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" _
        (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long

Public Sub CheckForChange()

' run this sub which will wait for Interval milliseconds and then return control to the calling procedure

If mlWaitHandle = 0 Then
    zStartWaiting
End If
If mlWaitHandle <= 0 Then
    Exit Sub
End If

Dim lResult As Long
Do

    lResult = WaitForSingleObject(mlWaitHandle, mlInterval)
    If lResult = 0 Then
        mdtLastScan = Now
       
        lResult = FindNextChangeNotification(mlWaitHandle)
       
       
        ' DO THE THING
        If mlNotifyAction = NotifyActionList.wfcReturnFolder Then
            RaiseEvent FolderChanged(msFolderName)
        Else
            zProcessChange msFolderName
        End If
       
    Else
        ' incase the Windows gets screwed do this every 5 minutes
        If Now - mdtLastScan > GF.cSeconds(0, 5) Then
            mdtLastScan = Now
       
            If mlNotifyAction = NotifyActionList.wfcReturnFolder Then
                RaiseEvent FolderChanged(msFolderName)
            Else
                zProcessChange msFolderName
            End If
        End If
       
        Exit Do
    End If
Loop

End Sub
Public Property Get Interval() As Long
Interval = mlInterval
End Property
Public Property Let Interval(NewValue As Long)
If NewValue >= 10 Then
    mlInterval = NewValue
End If
End Property

Public Property Let NotifyAction(NewValue As NotifyActionList)
mlNotifyAction = NewValue
End Property

Public Property Get NotifyAction() As NotifyActionList
NotifyAction = mlNotifyAction
End Property

Public Property Let NotifyOptions(NewValue As NotifyOptionsList)
mlNotify = NewValue
End Property

Public Property Get NotifyOptions() As NotifyOptionsList
NotifyOptions = mlNotify
End Property

Public Sub zStartWaiting()
' create a start change handle
StopWaiting

mlWaitHandle = FindFirstChangeNotification(msFolderName, _
   mbIncludeSubFolders, mlNotify)
mbOneDone = False
If mlWaitHandle <= 0 Then
   
    ErrN = Err.LastDllError
    ErrD = GF.GetLastErrorMessage(ErrN)

End If
   
End Sub


Private Sub zProcessChange(psFolder As String)

' Pickup all files in the folder

Dim Files
Dim vFile

' get the files in the folder
Set Files = FOP.GetFiles(psFolder + "\*.*", True)
If Files Is Nothing Then Exit Sub

Dim OK
Dim sFullPath As String
Dim bError As Boolean

For Each vFile In Files
    Dim sFile As String
    sFile = vFile
    sFullPath = psFolder + "\" + sFile
   
    ' process a file
    Dim lfn As Long
    On Error Resume Next
    bError = True
    Do
   
        Err.Clear
        lfn = FreeFile
        Open sFullPath For Input As #lfn
        If Err.Number = 0 Then
            bError = False
            Exit Do
        End If

        GF.sleeper 500
    Loop
   
    Dim sFileContent As String
    Dim lLen As Long
    If mlNotifyAction = NotifyActionList.wfcReturnContent Then
        lLen = LOF(lfn)
        sFileContent = Input(lLen, lfn)
    End If
    Close lfn
    GF.sleeper 10
    On Error GoTo 0
   
    Dim bCancel As Boolean
   
    bCancel = False
    If mlNotifyAction = NotifyActionList.wfcReturnFilePath Then
        RaiseEvent FileChanged(sFile, bCancel)
    Else
        RaiseEvent FileChangedContent(sFile, sFileContent, bCancel)
    End If
   
    If Not bCancel Then
        'now kill the file
        OK = GF.KillFileOK(sFullPath)
       
'        If Not OK Then
'           should log an error here
'            MsgBox "Unable to kill " + vFile + " " + GF.ErrD
'        End If
    End If
Next

End Sub


Public Function StartWaitingOK(psFoldername As String, Optional pbIncludeSubFolders As Boolean = False) As Boolean
' start the waiting activity return true if ok
msFolderName = psFoldername

mbIncludeSubFolders = pbIncludeSubFolders
zStartWaiting
StartWaitingOK = mlWaitHandle > 0

End Function
Public Sub StopWaiting()
' Stop the waiting acticity
If mlWaitHandle > 0 Then
    FindCloseChangeNotification mlWaitHandle
    mlWaitHandle = 0
End If
End Sub


Private Sub Class_Initialize()

mlInterval = 50 ' default interval for CheckForChange

' Default what changes to listen for
mlNotify = wfcFileNAME _
    Or wfcDIR_NAME _
    Or wfcATTRIBUTES _
    Or wfcSIZE _
    Or wfcLAST_WRITE _
    Or wfcLAST_ACCESS _
    Or wfcCREATION _
    Or wfcSECURITY

mlNotifyAction = NotifyActionList.wfcReturnContent

End Sub


Private Sub Class_Terminate()
StopWaiting
End Sub


0
 
LVL 17

Expert Comment

by:inthedark
ID: 18052697
If you are monitoring folder changes please note that the class will Raise a folder change event so in your event code epected that there may not be any files.  This is done becodes sometimes windows folder change events get broken.

Also note that class uses a function FOP.GetFiles FOP (Folder/File Operations) is a class I created in order to replace the VB Dir function with one that never fails.
0

Featured Post

Free Trending Threat Insights Every Day

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

Join & Write a Comment

I’ve seen a number of people looking for examples of how to access web services from VB6.  I’ve been using a test harness I built in VB6 (using many resources I found online) that I use for small projects to work out how to communicate with web serv…
When designing a form there are several BorderStyles to choose from, all of which can be classified as either 'Fixed' or 'Sizable' and I'd guess that 'Fixed Single' or one of the other fixed types is the most popular choice. I assume it's the most p…
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

744 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

14 Experts available now in Live!

Get 1:1 Help Now