Wykorzystania monitorowania zdarzeń plików (WMI: CIM_DataFile)
w VBA
  strona główna:
A po co ten Excel ;-)
 
 
 
Problem poruszałem na zlocie ale uważam że warto żeby tu też znalazł miejsce i (mam nadzieję) trafił do szerszego grona zainteresowanych.  
 
Zadanie: W określonej lokalizacji, co pewien czas pojawia się plik txt. Znamy strukturę tego pliku/plików i chcemy pobrać z niego/nich dane.  
            Nie chcemy jednak wykorzystywać pętli która co określony czas sprawdzałaby czy plik już jest, czy nadal go nie ma ;-)  
            Chcemy wykorzystać zdarzenie zaistnienia pliku w określonej lokalizacji. Jak zrealizować takie zadanie??  
 
Rozwiązanie:  
    Całość zadania i jego rozwiązanie jest dwuetapowe. Czemu??  
 1. Potrzebny mi mechanizm który będzie tworzył przykładowe pliki, ale: nie będzie pochodził z VBA!! Będzie to VBS - skrypt, który co  
     określony czas będzie tworzył plik txt i zapisywał go w określonej lokalizacji.  
 2. Utworzenie referencji do obiektu WMI i wykorzystanie zdarzenia w VBA (moduł class WithEvents) do oprogramowania reakcji programu na  
     zaistnienie pliku w monitorowanej lokalizacji.  
 
Procedury są napisane tak żeby folder do którego wypakujecie przykład do pobrania był obojętny. Ważne żeby nie zmieniać lokalizacji plików!  
 
Zadanie 1. Skrypt do tworzenia przykładowych plików txt - TworzPlikiTxt.vbs  
 
    Dim iNr  
    Dim strTxtFile  
    Dim strPath: strPath = Left(WScript.ScriptFullName, _  
                     InStrRev(WScript.ScriptFullName, "\")) & _  
                "test\"  
    Dim f  
    Dim i, dbl  
    Dim arr(4, 4)  
      
    WScript.Sleep 2000  
 
    Randomize  
    For f = 1 To WScript.Arguments.Item(0)   Working with Command-Line Arguments
      
        For i = 0 To 4   wykorzystałem do określenia ile plików ma stworzyć skrypt
            arr(i, 0) = i + 1  
            arr(i, 1) = Now()  
            dbl = Rnd() * 1000  
            arr(i, 2) = Round(dbl, 2)  
            arr(i, 3) = "opis: " & dbl  
        arr(i, 4) = "plik" & f & ".txt"  
        Next  
          
        Tbl2TXT_FSO arr, strPath & "plik" & f & ".txt"  
 
    WScript.Sleep 1500  
 
    Next  
    MsgBox "koniec"  
          
  przeróbka pod VBS procedury
Sub Tbl2TXT_FSO(vDane, strTXTFileFullName)   Zapis tablicy do pliku txt
      
    Dim objFSO ' Scripting.FileSystemObject  
    Dim objStream ' Scripting.TextStream  
    Const ForWriting = 2  
              
    Dim tbl  
    Dim i, j  
    Dim strLine  
    Const strSep = ";"  
      
    tbl = vDane  
      
    Set objFSO = CreateObject("Scripting.FileSystemObject")  
    Set objStream = objFSO.OpenTextFile(strTXTFileFullName, ForWriting, True)  
    With objStream  
        For i = LBound(tbl, 1) To UBound(tbl, 1)  
            For j = LBound(tbl, 2) To UBound(tbl, 2)  
                strLine = strLine & tbl(i, j) & strSep  
            Next  
            strLine = Left(strLine, Len(strLine) - Len(strSep))  
            .WriteLine strLine  
            strLine = ""
 
        Next  
        .Close  
    End With  
              
    Set objStream = Nothing  
    Set objFSO = Nothing  
End Sub  
 
W efekcie działania skryptu powstają pliki o, dla  
przykładu, takiej strukturze..  
 
Zadanie 2. Przechwycenie w VBA zdarzenia zaistnienia   
               pliku w monitorowanej lokalizacji.  
 
VBE / Tools / References…  
należy dodać referencję do:  
                 Microsoft WMI Scripting V1.2 Library  
 
następnie dodajemy moduł class i nadajemy mu nazwę:  
                                   clsWMIevents  
 
a w nim:  
 
Dim WithEvents sink As SWbemSink  
 
Private Sub Class_Initialize()  
 
    Dim services As SWbemServices  
    Dim strQuery As String  
    Dim cntxt As SWbemNamedValueSet  
    Set sink = New SWbemSink  
    Set services = GetObject("winmgmts:{impersonationLevel=impersonate,(security)}")  
      
    Dim sDrive As String: sDrive = Split(ThisWorkbook.Path, ":")(0) & ":" '"C:"  
    Dim sPaths As String: sPaths = Replace(Split(ThisWorkbook.Path, ":")(1), "\", "\\") & "\\test\\"  
      
    strSQL = "SELECT * " & _  
         "FROM __InstanceOperationEvent WITHIN 1 " & _  
         "WHERE TargetInstance ISA 'CIM_DataFile' AND " & _  
               "TargetInstance.Drive='" & sDrive & "' AND " & _  
               "TargetInstance.Path='" & sPaths & "'" _  
      
    Set cntxt = New SWbemNamedValueSet  
    cntxt.Add "sinkname", "ExecNoteAsync"  
    services.Security_.Privileges.Add (wbemPrivilegeSecurity)  
    services.ExecNotificationQueryAsync sink, strSQL, , , , cntxt  
    MsgBox "Start"  
          
End Sub  
 
Private Sub Class_Terminate()  
    MsgBox "Koniec"  
End Sub  
 
Private Sub sink_OnObjectReady(ByVal objWbemObject As WbemScripting.ISWbemObject, _  
                               ByVal objWbemAsyncContext As WbemScripting.ISWbemNamedValueSet)  
  On Error GoTo ErrorHandler  
    Dim cntxt_item As WbemScripting.SWbemNamedValue  
    Set cntxt_item = objWbemAsyncContext.Item("sinkname")  
    If cntxt_item.Value = "ExecNoteAsync" Then  
          
        '-------------------------------------------------------  
        '---------- TRUE - monitorowanie zdarzeń z MsgBox'em (po zabawie usunąć pliki txt)  
        '---------- FALSE - import danych  
        If False Then '<-------------  
        '-------------------------------------------------------  
            With objWbemObject  
                strText = Now & vbTab & .Path_.Class & Chr(10)  
                strText = strText & "Filename: " & .TargetInstance.Filename & Chr(10)  
                strText = strText & "Extension: " & .TargetInstance.Extension & Chr(10)  
                strText = strText & "LastModified: " & .TargetInstance.LastModified  
            End With  
 
            MsgBox "Zdarzenie: " & objWbemObject.TargetInstance.Description & Chr(10) & _  
                                   strText  
            strText = vbNullString  
        Else  
            With objWbemObject  
                If .Path_.Class = "__InstanceCreationEvent" And _  
                   .TargetInstance.Extension = "txt" Then 'tworze tu jeszcze schema.ini  
                                  '__InstanceDeletionEvent  
                                  '__InstanceModificationEvent  
                  
                    Dim sParh As String: sPath = .TargetInstance.Description  
                    Dim sFile As String: sFile = .TargetInstance.Filename & "." & _  
                                                 .TargetInstance.Extension & ""  
                      
                    ImportZTXT_ADO Arkusz1.Range("A" & Last(Arkusz1.[A:A]) + 1), _  
                                ThisWorkbook.Path & "\test", _  
                                sFile, _  
                                "SELECT * FROM " & sFile, _  
                                "Format = Delimited(;)", "DecimalSymbol = ,", _  
                                "CharacterSet = 1250", "ColNameHeader = False"  
                      
                    VBA.Kill objWbemObject.TargetInstance.Description  
                      
                End If  
            End With  
        End If  
    End If  
 
    Set objWbemObject = Nothing  
    Exit Sub  
 
ErrorHandler:  
    MsgBox "Error number: " & Str(Err.Number) & vbNewLine & "Description: " & Err.Description, vbCritical  
End Sub  
            
 
To co istotne do dostosowania do własnych potrzeb:  
w:  Class_Initialize()  
 
    Dim sDrive As String: sDrive = Split(ThisWorkbook.Path, ":")(0) & ":" '"C:"  
    Dim sPaths As String: sPaths = Replace(Split(ThisWorkbook.Path, ":")(1), "\", "\\") & "\\test\\"   Wyjaśnienia treści zapytania  proszę szukać w poprzednim temacie
      
    strSQL = "SELECT * " & _  
         "FROM __InstanceOperationEvent WITHIN 1 " & _   Monitorowanie zdarzeń systemowych. (vbs)
         "WHERE TargetInstance ISA 'CIM_DataFile' AND " & _  
               "TargetInstance.Drive='" & sDrive & "' AND " & _  
               "TargetInstance.Path='" & sPaths & "'" _  
 
To jedyne co napisałem sam. Resztę podpowiedział Google choc nie zapisałem pochodzenia - sorka :-|  
 
zdarzenie: sink_OnObjectReady()  
To właśnie zdarzenie "odpali" jak w lokalizacji określonej zapytaniem SQL w Class_Initialize() zostanie utworzony plik. To zdarzenie musimy  
oprogramować dla własnych potrzeb.  
 
moje (oprócz testów) jest:  
 
            With objWbemObject  
                If .Path_.Class = "__InstanceCreationEvent" And _  
                   .TargetInstance.Extension = "txt" Then 'tworze tu jeszcze schema.ini  
                                  '__InstanceDeletionEvent  
                                  '__InstanceModificationEvent  
                  
                    Dim sParh As String: sPath = .TargetInstance.Description  
                    Dim sFile As String: sFile = .TargetInstance.Filename & "." & _  
                                                 .TargetInstance.Extension & ""  
                      
                    ImportZTXT_ADO Arkusz1.Range("A" & Last(Arkusz1.[A:A]) + 1), _  
                                ThisWorkbook.Path & "\test", _  
                                sFile, _  
                                "SELECT * FROM " & sFile, _  
                                "Format = Delimited(;)", "DecimalSymbol = ,", _  
                                "CharacterSet = 1250", "ColNameHeader = False"  
                      
                    VBA.Kill objWbemObject.TargetInstance.Description  
                      
                End If  
            End With  
 
a więc:  
                If .Path_.Class = "__InstanceCreationEvent" And _  
jeżeli zaistniało zdarzenie *CreationEvent".. - bo może zaistnieć też modyfikacji lub usunięcia.  
 
                   .TargetInstance.Extension = "txt" Then  
i jeżeli rozszerzenie utworzonego pliku to txt. W tej lokalizacji będzie twotzony też plik shema.ini na potrzeby importu danych.  
 
                    Dim sParh As String: sPath = .TargetInstance.Description  
                    Dim sFile As String: sFile = .TargetInstance.Filename & "." & _  
                                                 .TargetInstance.Extension & ""  
                      
                    ImportZTXT_ADO Arkusz1.Range("A" & Last(Arkusz1.[A:A]) + 1), _   Import danych z pliku TXT ADO
                                ThisWorkbook.Path & "\test", _  
                                sFile, _  
                                "SELECT * FROM " & sFile, _  
                                "Format = Delimited(;)", "DecimalSymbol = ,", _  
                                "CharacterSet = 1250", "ColNameHeader = False"  
Do Arkusz1!A:A mają być zaimportowane dane z utworzonego pliku txt poprzez ADO  
 
                    VBA.Kill objWbemObject.TargetInstance.Description  
a sam plik ma być usunięty. :-)  
 
 
Pod przyciskami w pliku WMI Class.xlsm  
 
 
Option Explicit  
 
Public sinker As clsWMIevents  
   
Sub Start()  
    Set sinker = New clsWMIevents  
End Sub  
 
Sub koniec()  
    Set sinker = Nothing  
End Sub  
 
Sub StartVBS()  
      
    Dim oWs As Object  
    Set oWs = CreateObject("WScript.Shell")  
    #If Win64 Then  
        'Jeżeli masz 64bit system to skrypt odpalasz tak...  
        oWs.Run """C:\Windows\SysWow64\WScript.exe"" """ & ThisWorkbook.Path & "\TworzPlikiTxt.vbs"" " & Arkusz1.[O3]  
    #Else  
        oWs.Run """C:\Windows\System32\WScript.exe"" """ & ThisWorkbook.Path & "\TworzPlikiTxt.vbs"" " & Arkusz1.[O3]  
    #End If  
    Set oWs = Nothing  
      
End Sub  
  Przykład do pobrania:
do testów: Najpierw Start, później - Start Skryptu - 2sek oczekiwania - co 1,5sek import z plików których ilość określa kom.O3   importdoxls.zip