Know When A Group of Functions Are Done

[kd13]

Hello,

Is there a way to determine when multiple function calls are done?
For example, I have a function myFunc(). Regardless of whether I call it one time, 10 times or 50 times, when it is done I get an alert saying that all one, 10, or 50 function calls are done.

Thank you

[Krool]

You could creater a helper function with an argument of how often myFunc should be called (Count As Long)
Then in an For i...Next you call myFunc and at the end of the helper function you bring your alert.

[Dragokas]

Place inside that function Static var, increase it +1 on each call and check its value.

sub main()
  for i = 1 to 100
    foo()
  next
end fub

function foo()
  static c as long
  c = c +1
  if (c = 50) msgbox "alert"
end function

[DataMiser]

I'm not sure what the OP is asking looking for. VB Functions are blocking the function is done when it returns and moves to the next line of code. As for knowing when several calls are done that all depends on how and when you are calling the function but the simple answer is the same. It is done when it returns since the programmer is determining where and how many times to call the function then programmer would determine where to put the signal that it is complete. If it is being called in a loop then after the loop exits all the calls are done. if it is being called from multiple places at multiple times then you may need to use a increment counter and check when its value meets your requirement.

Now this is of course assuming you are talking about native VB functions. If you are talking API that or other that runs as async then the code does not wait for it to complete and you have a different situation.

[LaVolpe]

@DataMiser, the OP posted another thread regarding async callbacks and I think this thread is related to it... execute async function n times and inform app when all n occurrences have been called backed to the app via a callback routine. If I'm on the right track, think of sending out n URL requests and wanting to know when all n pages have been loaded.

[kd13]

@DataMiser, the OP posted another thread regarding async callbacks and I think this thread is related to it... execute async function n times and inform app when all n occurrences have been called backed to the app via a callback routine. If I'm on the right track, think of sending out n URL requests and wanting to know when all n pages have been loaded.

Yup, the two are indeed related. Because VBA doesn't have a way to anticipate the async callback, I want to populate a dictionary with all the results of the asynchronous calls. What I want to do is then call a function to parse that data out once the dictionary is populated by the async calls.

The current iteration I have now parses the data out while some async calls are still being made. It's hectic and causes my excel to crash. What I'm trying to do is separate the process in hopes it will be more manageable.

[westconn1]

i have a sample, written by someone else, using async pings,

i believe the code does what you are asking
it has some limit on the number of async operations at one time, and tracks which are still active
i will see if i can find it again

[kd13]

i have a sample, written by someone else, using async pings,

i believe the code does what you are asking
it has some limit on the number of async operations at one time, and tracks which are still active
i will see if i can find it again

Really hope you can. That would be great!

[westconn1]

ok, i will look tonight, i remember now it uses waitforsingleobject, to know when each task is done

[westconn1]

a class module

Option Explicit



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

Private Type ip_option_information
    ttl             As Byte 'Byte     'Time To Live
    Tos             As Byte     'Type Of Service
    Flags           As Byte     'IP header flags
    OptionsSize     As Byte     'Size in bytes of options data
    OptionsData     As Long     'Pointer to options data
End Type

Private Type ICMP_ECHO_REPLY
    Address         As Long
    Status          As Long
    RoundTripTime   As Long
    datasize        As Long 'formerly integer
   'Reserved        As Integer
    DataPointer     As Long
    Options         As ip_option_information
    Data            As String * 250
End Type

Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
Private Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal IcmpHandle As Long) As Long
Private Declare Function inet_addr Lib "wsock32" (ByVal s As String) As Long

Private Declare Function IcmpSendEcho2 Lib "icmp.dll" (ByVal IcmpHandle As Long, ByVal hEvent As Long, ByVal ApcRoutine As Any, ByVal ApcContext As Long, ByVal DestinationAddress As Long, ByVal RequestData As String, ByVal RequestSize As Long, ByVal RequestOptions As Long, ByVal ReplyBuffer As Long, ByVal ReplySize As Long, ByVal TimeOut As Long) As Long

Private Declare Function CreateEvent Lib "kernel32" Alias "CreateEventA" (lpEventAttributes As SECURITY_ATTRIBUTES, ByVal bManualReset As Long, ByVal bInitialState As Long, ByVal lpName As String) As Long
'Private Declare Function WaitForMultipleObjects Lib "kernel32" (ByVal nCount As Long, lpHandles As Long, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long) As Long
'Private Declare Function WaitForMultipleObjectsArray Lib "kernel32" Alias "WaitForMultipleObjects" (ByVal nCount As Long, lpHandles() As Long, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long


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


Private Const WAIT_OBJECT_0 As Long = 0
Private Const WAIT_TIMEOUT As Long = &H102
Private Const WAIT_ABANDONED = &H80
Private Const WAIT_FAILED = -1&
Private Declare Function GetTickCount Lib "kernel32" () As Long

Public Event PingSuccess(sIPAdress As String, lNewStatus As Long, ArrayIndex As Long)
Public Event PingFail(sIPAdress As String, lNewStatus As Long, ArrayIndex As Long)

Private mvarNumParalellActions As Long
Private mvarListPingRunning As Boolean

Public Property Let NumParalellActions(ByVal NewData As Long)
    mvarNumParalellActions = NewData
End Property
Public Property Get NumParalellActions() As Long
    NumParalellActions = mvarNumParalellActions
End Property

Public Property Get ListPingRunning() As Boolean
    ListPingRunning = mvarListPingRunning
End Property

Public Function PingHostSingle(sHostIP As String, TimeOut As Long) As Long
Const sSendData As String = "TESTMESSAGE"
Dim Buffer As ICMP_ECHO_REPLY
Dim lhwndPort As Long
Dim hEvent As Long
Dim sd As SECURITY_ATTRIBUTES
Dim WaitRes As Long
Dim tm1 As Long, tm2 As Long

    '//needed for Create Event
    With sd
        .nLength = Len(sd) 'we pass the length of sd
        .lpSecurityDescriptor = 0
        .bInheritHandle = 0
    End With

    '//We create an Event-ID to be registered with IcmpSendEcho2 and WaitForMultipleObjects to wait for
    hEvent = CreateEvent(sd, True, False, "PINGV2")

    lhwndPort = IcmpCreateFile()    '//Standard for ICMP, create a handle
    
    Call IcmpSendEcho2(lhwndPort, hEvent, Nothing, 0, inet_addr(sHostIP), sSendData, Len(sSendData), 0, VarPtr(Buffer), Len(Buffer), 1000)

    '//Gere we start to wait
    tm1 = GetTickCount()
    Do
        WaitRes = WaitForSingleObject(hEvent, 5) ' WaitForMultipleObjects(1, hEvent, 1, 10)
        tm2 = GetTickCount
        DoEvents
        If (tm2 - tm1) < 1000 Then
            Select Case WaitRes
                Case WAIT_ABANDONED, WAIT_FAILED
                    DoEvents
                    PingHostSingle = -2
                    Exit Do
                Case WAIT_OBJECT_0
                    If Buffer.Status = 0 Then
                        PingHostSingle = Buffer.RoundTripTime
                    Else
                        PingHostSingle = -1
                    End If
                    Exit Do
'//Cause were in a loop, this message will not work for us
'                Case WAIT_TIMEOUT
            End Select
            DoEvents
        Else
            DoEvents
            PingHostSingle = -1
            Exit Do
        End If
    Loop While (1)
    '//And clear all created things
    ResetEvent hEvent
    IcmpCloseHandle lhwndPort
End Function


Public Function PingHostList(saIpAdresses() As String, TimeOutHost As Long, TimeOutAll As Long) As Boolean
Dim NumAdresses As Long
Dim laHandlesICMP() As Long
Dim laEvents() As Long
Dim laTimerStart() As Long
Dim laTimerSop() As Long
Dim laWaitResults() As Long
Dim bUseResult() As Boolean
Dim baEchoSend() As Boolean
Dim aBuffers() As ICMP_ECHO_REPLY
Dim bProcessed() As Integer
Dim nProcessed As Long
Dim nLoop As Long
Dim baInitiated() As Boolean
Dim TimerStart As Long
Dim Timerstop As Long

Dim Buffer As ICMP_ECHO_REPLY
Dim sd As SECURITY_ATTRIBUTES
Const sSendData As String = "PINGDATAMESSAGE"
Dim WaitRes As Long

Dim nStart As Long, nEnd As Long, BoundCtr As Long

    '//Prevent from reentry
    If mvarListPingRunning = True Then
        PingHostList = False
        Exit Function
    End If
    mvarListPingRunning = True
    NumAdresses = UBound(saIpAdresses)
'//init the needed arrays
    ReDim laHandlesICMP(NumAdresses)
    ReDim laEvents(NumAdresses)
    ReDim laTimerStart(NumAdresses)
    ReDim laTimerSop(NumAdresses)
    ReDim laWaitResults(NumAdresses)
    ReDim baEchoSend(NumAdresses)
    ReDim aBuffers(NumAdresses)
    ReDim bProcessed(NumAdresses)
    
    '//needed for Create Event
    With sd
        .nLength = Len(sd) 'we pass the length of sd
        .lpSecurityDescriptor = 0
        .bInheritHandle = 0
    End With
    
    For nLoop = 0 To NumAdresses - 1
        '//We create an Event for WaitForMultipleObjects to wait for
        laEvents(nLoop) = CreateEvent(sd, True, False, "PINGV2C" & nLoop)
        laHandlesICMP(nLoop) = IcmpCreateFile()    '//Standard for ICMP
    Next
    TimerStart = GetTickCount
    nProcessed = 0  '//Reset Counter for processed hosts
    nStart = 0
    If NumAdresses > mvarNumParalellActions Then
        nEnd = mvarNumParalellActions
    Else
        nEnd = NumAdresses - 1
    End If
    BoundCtr = 0
    Do
        For nLoop = nStart To nEnd
            '//Did we already request an echo
            If baEchoSend(nLoop) = False Then
                baEchoSend(nLoop) = True    '//Lock this adress, so we don't create a second Ping
                Call IcmpSendEcho2(laHandlesICMP(nLoop), laEvents(nLoop), Nothing, 0, inet_addr(saIpAdresses(nLoop)), sSendData, Len(sSendData), 0, VarPtr(aBuffers(nLoop)), Len(aBuffers(nLoop)), TimeOutHost)
            End If
            If bProcessed(nLoop) = False Then
                laWaitResults(nLoop) = WaitForSingleObject(laEvents(nLoop), 5) '//We wait only for 5 Millisecs, to give all the other IPs Time to answer
                Select Case laWaitResults(nLoop)
                    Case WAIT_ABANDONED, WAIT_FAILED
                        DoEvents
                        bProcessed(nLoop) = -1
                        nProcessed = nProcessed + 1
                        BoundCtr = BoundCtr + 1
                    Case WAIT_OBJECT_0
                        bProcessed(nLoop) = 1
                        nProcessed = nProcessed + 1
                        BoundCtr = BoundCtr + 1
                        If aBuffers(nLoop).Status = 0 Then
                            '//Valid Info : So Host is reachable
                            RaiseEvent PingSuccess(saIpAdresses(nLoop), aBuffers(nLoop).RoundTripTime, nLoop)
                        Else
                            RaiseEvent PingFail(saIpAdresses(nLoop), -1, nLoop)
                        End If
    '//Cause were in a loop, this message will not work for us
'                    Case WAIT_TIMEOUT
                        'bProcessed(nLoop) = -1
                End Select
                End If
                DoEvents
            Next
        Timerstop = GetTickCount
        If (Timerstop - TimerStart) < TimeOutAll Then
            '
        Else
            DoEvents
            Debug.Print "TIMED OUT"
            Exit Do
        End If
        '//All done, no more Action needed
        If nProcessed >= NumAdresses - 1 Then
            Exit Do
        End If
        If nEnd < NumAdresses And BoundCtr >= mvarNumParalellActions Then
            nStart = nEnd + 1
            nEnd = nEnd + mvarNumParalellActions
            If nEnd > NumAdresses - 1 Then nEnd = NumAdresses - 1
            BoundCtr = 0
            Debug.Print "New bounds :"; nStart, nEnd, Time
        End If
    Loop While (1)
        
'//IMPORTANT : UNregister all messages/Evemnts and open ICMP-handles
    For nLoop = 0 To NumAdresses - 1
        ResetEvent laEvents(nLoop)
        IcmpCloseHandle (laHandlesICMP(nLoop))
        If bProcessed(nLoop) <= 0 Then
            '//notify caller with the rest of the host, that we haven't hit
            RaiseEvent PingFail(saIpAdresses(nLoop), -1, nLoop)
        End If
    Next
'//And we free up some memory
    Erase laHandlesICMP
    Erase laEvents
    Erase laTimerStart
    Erase laTimerSop
    Erase laWaitResults
    Erase baEchoSend
    Erase aBuffers
    Erase bProcessed
    mvarListPingRunning = False
End Function


Private Sub Class_Initialize()
    mvarNumParalellActions = 500
End Sub

the calling form (results went to a list box)

Private WithEvents m_clsPingBase As ClassPingBase
Private m_bFirstRun As Boolean

Private Sub btnPingAsync_Click()
Dim saAdresses() As String, n As Integer
Dim tm1 As Long, tm2 As Long, mystr As String
    
    btnPingAsync.Enabled = False
    ReDim saAdresses(LV_IPs.ListItems.Count)
    For n = 1 To LV_IPs.ListItems.Count
        '//Store value
        If LV_IPs.ListItems(n).SubItems(1) = "---" Then
            LV_IPs.ListItems(n).ListSubItems(1).Tag = -1
        Else
            If Len(LV_IPs.ListItems(n).SubItems(1)) Then
                LV_IPs.ListItems(n).ListSubItems(1).Tag = LV_IPs.ListItems(n).ListSubItems(1).Text
            End If
        End If
        LV_IPs.ListItems(n).SubItems(1) = ""
        saAdresses(n - 1) = LV_IPs.ListItems(n).Text
    Next
    tm1 = GetTickCount()
    m_clsPingBase.NumParalellActions = 1000
    m_clsPingBase.PingHostList saAdresses, 100, (LV_IPs.ListItems.Count * 100) / 2
    btnPingAsync.Enabled = True
    tm2 = GetTickCount()
    m_bFirstRun = True
    Dim w, ns
    Set w = CreateObject("wscript.shell")
    For n = 1 To LV_IPs.ListItems.Count
    
    If Not LV_IPs.ListItems(n).SubItems(1) = "---" Then
        Set ns = w.exec("nslookup " & LV_IPs.ListItems(n))
        
        mystr = mystr & LV_IPs.ListItems(n) & vbTab & Replace(ns.stdout.readall, vbNewLine, vbTab) & vbNewLine
    End If
    Next
    
    Open App.Path & "\pinged.txt" For Output As 1
    Print #1, mystr
    Close 1
'    MsgBox Format((tm2 - tm1) / 1000, "0.00") & " secs", , "Time needed"
End Sub

Private Sub m_clsPingBase_PingFail(sIPAdress As String, lNewStatus As Long, ArrayIndex As Long)
    LV_IPs.ListItems(ArrayIndex + 1).SubItems(1) = "---"
    LV_IPs.ListItems.Item(ArrayIndex + 1).SmallIcon = 2
    If m_bFirstRun Then
        If LV_IPs.ListItems(ArrayIndex + 1).ListSubItems(1).Tag <> -1 Then
            '//Notify state change
            LV_IPs.ListItems(ArrayIndex + 1).ListSubItems(1).ReportIcon = 4
        End If
    End If
End Sub

Private Sub m_clsPingBase_PingSuccess(sIPAdress As String, lNewStatus As Long, ArrayIndex As Long)
    LV_IPs.ListItems(ArrayIndex + 1).SubItems(1) = lNewStatus
    LV_IPs.ListItems(ArrayIndex + 1).EnsureVisible
    LV_IPs.ListItems.Item(ArrayIndex + 1).SmallIcon = 1
    If m_bFirstRun Then
        If LV_IPs.ListItems(ArrayIndex + 1).ListSubItems(1).Tag = -1 Then
            '//Notify state change
            LV_IPs.ListItems(ArrayIndex + 1).ListSubItems(1).ReportIcon = 3
        End If
    
    End If
End Sub

i hope you can figure something out from this, i have played with it and tested a bit, but i am certainly no expert with the code here, does appear to work correctly though