[VB6] creare una pausa

[fosforo]

Ciao
Ho scritto un programmino che mi visualizza il contenuto di una cartella.
Questo programma mi avverte quando all'interno della cartella viene messo un determinato file, mettiamo "PIPPO.TXT"
Ora vorrei che mi uscisse una MSG ma con X secondi di ritardo ma senza fermare il controllo della cartella.
Mi spiego:
creare una pausa in una sub ma senza fermare il resto del programma.

Grazie

[Grumpy]

Puoi usare un Timer. Oppure se nella tua Sub c'è già un'iterazione abbastanza lunga puoi verificare se sono trascorsi gli X secondi.
Se non posti il tuo codice non si può essere più precisi.

[fosforo]

Postare il codice sarebbe inutile, almeno in questo caso visto che è una cosa semplice.
Ma la soluzione poi si potrebbe applicare a tutti quelli che hanno la necessità di creare una pausa senza fermare il programma.
In rete ho trovato questo;

Private Function Pausa(ByVal Intervallo As Long)
Dim TempoPartenza As Long
TempoPartenza = Int(Timer)
Do
DoEvents
Loop Until Int(Timer) >= TempoPartenza + Intervallo
End Function

ma non vorrei che mandasse la CPU a manetta.
Cosa ne pensi?

[Grumpy]

Cosa ne pensi?

Penso che non è quello che hai detto di voler fare. Quella routine ovviamente arresta l'esecuzione del programma fino a che non è terminata.
Ti avevo suggerito di postare il codice perché, oltre ad essere una buona regola generale più e più volte ripetuta, avrebbe permesso di capire quale delle due soluzioni che avevo ipotizzato era più adatta. Ma se credi che sia inutile... pazienza.

[oregon]

Originariamente inviato da fosforo
Postare il codice sarebbe inutile, almeno in questo caso visto che è una cosa semplice.

Se e' semplice perche' non l'hai scritta da solo?

Scusa, ma non capisco ... se chi ti risponde e si occupa del TUO problema ti chiede di postare il codice, cosa ti costa farlo?

In ogni caso, personalmente non ho capito A FONDO quello che vuoi fare ... dato che "creare una pausa ma senza fermare il programma" e' un controsenso, e dato che il VB6 e' singlethreaded, dovresti spiegare meglio per capire e vedere il codice sarebbe stato utile per capire ...

[icecube_HT]

Originariamente inviato da fosforo
Postare il codice sarebbe inutile, almeno in questo caso visto che è una cosa semplice.
Ma la soluzione poi si potrebbe applicare a tutti quelli che hanno la necessità di creare una pausa senza fermare il programma.
In rete ho trovato questo;

Private Function Pausa(ByVal Intervallo As Long)
Dim TempoPartenza As Long
TempoPartenza = Int(Timer)
Do
DoEvents
Loop Until Int(Timer) >= TempoPartenza + Intervallo
End Function

ma non vorrei che mandasse la CPU a manetta.
Cosa ne pensi?

Io uso questa:

Sub Pause(ByVal sec As Single)
   Dim t As Single
   t = Timer + sec
   If t >= 86400 Then t = 0   'evita il midnight-bug
   Do
        DoEvents        'permette di agire sui controlli
        Sleep 50
    Loop While Timer < t
End Sub

...non impegna la CPU (grazie alla Sleep), e inoltre non blocca i controlli utente (con il DoEvents).

P.S.: come routine di pausa in sé, ma le obiezioni precedenti, ovviamente, sono piu' che VALIDE !

[gianpythebest]

INTERESSANTE il problema!

Anche ha me servirebbe ,più in là fare una cosa del genere, ma ora come ora devo imparare!

Sono alle primissime armi col visual basic e già ho il mio primo incasinamento : non riesco a creare un exe con il mio IDE che sarebbe Visual Basic 2005 Express Edition.
Perfavore aiuto!vI CHEDO DI DARE UN OCCHIATA AL MIO POST!

grazie milee

[fosforo]

Ciao
Non volevo scatenare la furia di Oregon.
Con "semplice" intendevo il mio programma, non la soluzione al mio quesito.
Spero di non fa arrabiare nessuno chiedendo aiuto su un forum.
Magari scrivo delle banalità, ma se fossi preparato e capace non dovrei scrivere su un forum tecnico.
Comunque chiedo ancora scusa a Oregon.

Grazie Ice, userò sicuramente il tuo script, lo trovo utilissimo e geniale.

[oregon]

Ma non scherziamo ... ovviamente non mi sono "arrabbiato" (non mi "arrabbio" mai per una domanda su un forum ...).

E non ho detto assolutamente che scrivi delle banalità ma giudicare da solo che "il codice non e' necessario perche' la questione e' banale" significa decidere di non volere risposte ...

[fosforo]

Per correttezza posto il mio codice come suggerito da Oregon:


Private Type FILE_NOTIFY_INFORMATION
NextEntryOffset As Long
Action As Long
FileNameLength As Long
FileName(1 To 255) As Byte
End Type
Private Const FILE_NOTIFY_CHANGE_FILE_NAME = &H1&
Private Const FILE_NOTIFY_CHANGE_DIR_NAME = &H2&
Private Const FILE_NOTIFY_CHANGE_ATTRIBUTES = &H4&
Private Const FILE_NOTIFY_CHANGE_SIZE = &H8&
Private Const FILE_NOTIFY_CHANGE_LAST_WRITE = &H10&
Private Const FILE_NOTIFY_CHANGE_LAST_ACCESS = &H20&
Private Const FILE_NOTIFY_CHANGE_CREATION = &H40&
Private Const FILE_NOTIFY_CHANGE_SECURITY = &H100&
Private Const FILE_ACTION_ADDED = &H1&
Private Const FILE_ACTION_REMOVED = &H2&
Private Const FILE_ACTION_MODIFIED = &H3&
Private Const FILE_ACTION_RENAMED_OLD_NAME = &H4&
Private Const FILE_ACTION_RENAMED_NEW_NAME = &H5&
Private Const MAX_DIRS = 10 '//Only handle maximum upto 10 dir watch
Private Const MAX_BUFFER = 4096
Private Const MAX_PATH = 256 '//Your code will not work if Less than 256 (Yeppppp)
Private Type OVERLAPPED
Internal As Long
InternalHigh As Long
offset As Long
OffsetHigh As Long
hEvent As Long
End Type

Private Type DIRECTORY_INFO
hDir As Long
lpszDirName As String * MAX_PATH
lpBuffer(MAX_BUFFER) As Byte
dwBufLength As Long
oOverLapped As OVERLAPPED
lComplKey As Long
End Type

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

Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" ( _
ByVal lpFileName As String, _
ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, _
lpSecurityAttributes As SECURITY_ATTRIBUTES, _
ByVal dwCreationDisposition As Long, _
ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long) As Long

Private Declare Function ReadDirectoryChangesW Lib "kernel32" ( _
ByVal hDirectory As Long, _
lpBuffer As Any, _
ByVal nBufferLength As Long, _
ByVal bWatchSubtree As Long, _
ByVal dwNotifyFilter As Long, _
lpBytesReturned As Long, _
lpOverlapped As Any, _
lpCompletionRoutine As Any) As Long

Private Declare Function CreateIoCompletionPort Lib "kernel32" ( _
ByVal FileHandle As Long, _
ByVal ExistingCompletionPort As Long, _
ByVal CompletionKey As Long, _
ByVal NumberOfConcurrentThreads As Long) As Long

Private Declare Function CloseHandle Lib "kernel32" ( _
ByVal hObject As Long) As Long

Private Declare Function PostQueuedCompletionStatus Lib "kernel32" ( _
ByVal CompletionPort As Long, _
lpNumberOfBytesTransferred As Long, _
lpCompletionKey As Long, _
lpOverlapped As Long) As Long

Private Declare Function GetQueuedCompletionStatus Lib "kernel32" ( _
ByVal CompletionPort As Long, _
lpNumberOfBytesTransferred As Long, _
lpCompletionKey As Long, _
lpOverlapped As OVERLAPPED, _
ByVal dwMilliseconds As Long) As Long

Private Const FILE_LIST_DIRECTORY = &H1
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_DELETE = &H4
Private Const FILE_SHARE_WRITE = &H2

Private Const FILE_FLAG_BACKUP_SEMANTICS = &H2000000
Private Const FILE_FLAG_OVERLAPPED = &H40000000
Private Const OPEN_EXISTING = 3

Private Const INVALID_HANDLE_VALUE = -1
Private Const INFINITE = &HFFFF

Private hDir As Long
Private lpSecurityAttributes As SECURITY_ATTRIBUTES

'Private hEvent As Long
Private hIOCompPort As Long
Private oOverLapped As OVERLAPPED
Private InfoBuffer(MAX_BUFFER) As Byte
Private lpBytesReturned As Long

Private Type FileChange
NextPos As Long
Name As String
Type As Long
End Type

Private hThread As Long, lngTid As Long
Private DirInfo(MAX_DIRS) As DIRECTORY_INFO
Private numDirs As Integer
Private ret As Long, lngFilter As Long, bWatchSubDir As Boolean

Private Function WatchDirectoryOrFilename(colDirPaths As Collection) As Boolean
Dim i As Integer

If colDirPaths.Count <= 0 Then Exit Function
numDirs = colDirPaths.Count

lpSecurityAttributes.nLength = Len(lpSecurityAttributes)

For i = 1 To colDirPaths.Count
'//[Step 1] Obtain each dir handle which you want to monitor
DirInfo(i - 1).hDir = CreateFile(colDirPaths(i), _
FILE_LIST_DIRECTORY, _
FILE_SHARE_READ Or FILE_SHARE_WRITE Or FILE_SHARE_DELETE, _
lpSecurityAttributes, _
OPEN_EXISTING, _
FILE_FLAG_BACKUP_SEMANTICS Or FILE_FLAG_OVERLAPPED, _
0)

DirInfo(i - 1).lpszDirName = colDirPaths(i)


DirInfo(i - 1).lComplKey = VarPtr(DirInfo(i - 1))

hIOCompPort = CreateIoCompletionPort(DirInfo(i - 1).hDir, hIOCompPort, DirInfo(i - 1).lComplKey, 0)



ret = ReadDirectoryChangesW(DirInfo(i - 1).hDir, _
DirInfo(i - 1).lpBuffer(0), _
MAX_BUFFER, _
bWatchSubDir, _
lngFilter, _
lpBytesReturned, _
DirInfo(i - 1).oOverLapped, _
ByVal 0&)
Next

If ret <> 0 Then WatchDirectoryOrFilename = True
End Function

Private Sub HandleDirectoryChanges()
On Error Resume Next

Dim fContinue As Boolean
Dim lPointer As Long, iPos As Integer
Dim lngCompKey As Long
Dim lpOverlapped As OVERLAPPED
Dim fni As FILE_NOTIFY_INFORMATION
Dim DI As DIRECTORY_INFO
Dim FileInfo As FileChange


ret = GetQueuedCompletionStatus(hIOCompPort, _
lpBytesReturned, _
lngCompKey, _
oOverLapped, _
100)
If (ret <> 0) Then
lPointer = 0

For iPos = 0 To numDirs - 1
If DirInfo(iPos).lComplKey = lngCompKey Then Exit For
Next

Do
FileInfo = GetFileName(DirInfo(iPos).lpBuffer, lPointer)

strPath = Trim(DirInfo(iPos).lpszDirName) & "\" & FileInfo.Name
Select Case FileInfo.Type

Case FILE_ACTION_ADDED
strmsg = "[" & strPath & "] was added to the directory."
Case FILE_ACTION_REMOVED
strmsg = "[" & strPath & "] was removed from the directory."
Case FILE_ACTION_MODIFIED
strmsg = "[" & strPath & "] was modified. (i.e. timestamp/attributes chage)."
Case FILE_ACTION_RENAMED_OLD_NAME
strmsg = "[" & strPath & "] was renamed and this is the old name."
Case FILE_ACTION_RENAMED_NEW_NAME
strmsg = "[" & strPath & "] was renamed and this is the new name."
End Select

List2.AddItem strmsg

lPointer = FileInfo.NextPos
Loop While (lPointer > 0)

ret = ReadDirectoryChangesW(DirInfo(iPos).hDir, _
DirInfo(iPos).lpBuffer(0), _
MAX_BUFFER, _
bWatchSubDir, _
lngFilter, _
lpBytesReturned, _
DirInfo(iPos).oOverLapped, _
ByVal 0&)
End If

End Sub

Private Function GetLongFromBuf(Buf() As Byte, lPos As Long) As Long
On Error Resume Next

Dim lTemp As Long
Dim lResult As Long
lResult = Buf(lPos)
lTemp = Buf(lPos + 1): lResult = lResult + lTemp * 256
lTemp = Buf(lPos + 2): lResult = lResult + lTemp * 65536
lTemp = Buf(lPos + 3): lResult = lResult + lTemp * 65536 * 256
GetLongFromBuf = lResult
End Function

Private Function GetFileName(Buf() As Byte, lPointer As Long) As FileChange
On Error Resume Next

Dim lNextOffset As Long
Dim lFileSize As Long
Dim sTemp As String
Dim bTemp() As Byte
Dim i As Long

lNextOffset = GetLongFromBuf(Buf, lPointer)
GetFileName.Type = GetLongFromBuf(Buf, lPointer + 4)
lFileSize = GetLongFromBuf(Buf, lPointer + 8)

If lFileSize = 0 Then
GetFileName.NextPos = 0
Exit Function
End If
ReDim bTemp(1 To lFileSize)

For i = 1 To lFileSize
bTemp(i) = Buf(lPointer + 11 + i)
Next i

GetFileName.Name = bTemp

If lNextOffset = 0 Then
GetFileName.NextPos = 0
Else
GetFileName.NextPos = lNextOffset + lPointer
End If
End Function

Sub CleanUp()
On Error Resume Next

Call PostQueuedCompletionStatus(hIOCompPort, 0, 0, ByVal 0&)

For i = 0 To numDirs - 1
CloseHandle (DirInfo(i).hDir)
DirInfo(i).hDir = 0
Next

CloseHandle (hIOCompPort)
hIOCompPort = 0
End Sub

Private Sub Check1_Click()
bWatchSubDir = Check1.Value
End Sub

Private Sub Command1_Click()
On Error Resume Next
If List1.ListCount >= MAX_DIRS Then
MsgBox "Maximum " & MAX_DIRS & " directories can be monitored."
Exit Sub
End If


Dim colDirPaths As New Collection

List1.AddItem Text1

For i = 0 To List1.ListCount - 1
colDirPaths.Add List1.List(i)
Next

Call CleanUp
Timer1.Enabled = WatchDirectoryOrFilename(colDirPaths)
End Sub

Private Sub Form_Load()
On Error Resume Next


Dim colDirPaths As New Collection

Command1.Caption = "<< Add"
Check1.Caption = "Monitor All Sub Directories"
Check1.Value = 1

MkDir "C:\temp1"
MkDir "C:\temp2"


'colDirPaths.Add "D:\Fabio"


' List1.AddItem "D:\Fabio"



lngFilter = FILE_NOTIFY_CHANGE_FILE_NAME _
Or FILE_NOTIFY_CHANGE_SIZE _
Or FILE_NOTIFY_CHANGE_ATTRIBUTES _
Or FILE_NOTIFY_CHANGE_DIR_NAME _
Or FILE_NOTIFY_CHANGE_FILE_NAME _
Or FILE_NOTIFY_CHANGE_LAST_ACCESS _
Or FILE_NOTIFY_CHANGE_LAST_WRITE _
Or FILE_NOTIFY_CHANGE_SECURITY


bWatchSubDir = Check1.Value

Timer1.Enabled = False
Timer1.Interval = 100 '//Check for Queued Changes every 100 ms
Timer1.Enabled = WatchDirectoryOrFilename(colDirPaths)
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Call CleanUp
End Sub

Private Sub Timer1_Timer()
Me.Caption = "Monitoring ..."
Call HandleDirectoryChanges
End Sub

Sub Pause(ByVal sec As Single)
Dim t As Single
t = Timer + sec
If t >= 86400 Then t = 0 'evita il midnight-bug
Do
DoEvents 'permette di agire sui controlli
Sleep 50
Loop While Timer < t
End Sub