Praktyczne zastosowanie
monitorowania zdarzeń systemowych. (vbs)
  strona główna:
A po co ten Excel ;-)
 
 
 
Nie tak dawno.. (Bo klika godzin temu :-) ) pisałem:  
"... powiedzmy że w określonej lokalizacji pojawia się co jakiś czas plik z danymi.  Dane te trzeba zaimportować do   Monitorowanie zdarzeń systemowych. (vbs)
bazy a sam plik usunąć. Jak monitorowanie lokalizacji "uzbroimy" w ADO to całość może wykonywać automat :-)  
Ten pomysł chyba sprawdzę w praktyce… i nie omieszkam Wam pokazać jak to działa!! :-)  
 
    No i spać bym nie mógł gdybym nie sprawdził czy to naprawdę działa :-) No i…  JASNE że działa :-) I wyszło z tego całkiem  
fajne narzędzie.  
 
    Pomysł był taki:  
 - pewna aplikacja, oczywiście u mnie Excel, tworzy co pewien czas plik tekstowy zapisując go w określonej lokalizacji  
 - tę lokalizację monitoruje skrypt "przyglądający się" zdarzeniom classy CIM_DataFile  
 - jak pojawi się w tej lokalizacji plik skrypt odczyta jego zawartość, zapisze te dane do bazy mdb a sam pierwotny plik z danymi   
   usunie.  
 
Za aplikację zapisująca co pewien czas plik txt w określonej lokalizacji będzie nam służył oczywiście Excel.   
Dane wyglądają tak:  
Zakres ten nazwałem [dane]. A procedura tworząca plik txt:  
 
Sub Start()  
    Static i As Integer: i = i + 1  
    TBL2TXT_VBA [dane], ThisWorkbook.Path & "\test\dane" & Format(i, "000") & ".txt"  
End Sub  
 
Sub TBL2TXT_VBA(vDane As Variant, _  
                strTXTFileFullName As String)  
      
    'Zapis tablicy do pliku txt  
    'http://www.apocotenexcel.pl/tbl2txt_open.htm  
    Dim nr As Integer  
    Dim tbl As Variant, iX As Long, iY As Integer  
    Dim strLine As String  
              
    Const strSep As String = ","  
              
    tbl = vDane  
    nr = VBA.FreeFile  
    Open strTXTFileFullName For Output As #nr  
        For iX = 1 To UBound(tbl, 1)  
            For iY = 1 To UBound(tbl, 2)  
                strLine = strLine & tbl(iX, iY) & strSep  
            Next  
            strLine = Left(strLine, Len(strLine) - Len(strSep))  
            Print #nr, strLine  
            strLine = vbNullString  
        Next  
    Close #nr  
End Sub  
 
Tego nie omawiam. Czemu?   
1 - to wcale nie musi być Excel. Ważny jest efekt pracy tej procedury a nie sama procedura.  
2 - procedura, ze tak powiem, do trudnych nie należy :-) zainteresowanym wy komentowana linka wskaże drogę…  
 
My przechodzimy dalej. :-) Do skryptu.. skryptADO.vbs  
skrypt ten umieściłem w katalogu obok folderu \test gdzie nasza   
"aplikacja" zapisuje pliki txt z danymi:  
Układ plików/ folderów jak na obrazku.  
W Folderze z plikami z danymi znajduje się wcześniej stworzona  
baza mdb z tabelą do której mają trafiać dane.  
 
W "widoku projektu" taka tabela
 
 
 
 
 
 
 
 
 
 
 
 
 
No i cały mechanizm realizujący  
zadanie:  
 
 
    Dim arrDane 'Publiczne  
    Dim sFileName  
 
    Const adOpenStatic = 1  
    Const adUseClient = 3  
    Const adStateOpen = 1  
    Const adEditNone = 0  
    Const adModeWrite = 2  
    Const adOpenKeyset = 1  
    Const adLockOptimistic = 3  
    Const adCmdTable = 2  
 
    sComputer = "."  
 
    sDrive = Split(WScript.ScriptFullName, ":")(0) & ":"  
    sFolder = Split(WScript.ScriptFullName, ":")(1)  
    sFolder = Replace(Left(sFolder, InStrRev(sFolder, "\")), "\", "\\") & "test\\"  
 
    strSQL = "SELECT * " & _  
             "FROM __InstanceOperationEvent WITHIN 1 " & _  
             "WHERE TargetInstance ISA 'CIM_DataFile' AND " & _  
                   "TargetInstance.Drive='" & sDrive & "' AND " & _  
                   "TargetInstance.Path='" & sFolder & "' AND " & _  
                   "TargetInstance.Extension='txt'"  
 
    Set objWMIService = GetObject("winmgmts:\\" & sComputer & "\root\cimv2")  
    Set colMonitoredEvents = objWMIService.ExecNotificationQuery(strSQL)  
 
    MsgBox "Start"  
 
    On Error Resume Next  
      
    '-----------------------zdarzenia plików-------------------------  
    Do  
        Set objLatestEvent = colMonitoredEvents.NextEvent  
      
        With objLatestEvent  
            If .Path_.Class = "__InstanceCreationEvent" Then  
            With .TargetInstance  
                If (.Filename & "." & .Extension) Like "*.txt" Then  
            
                    sFileName = .Filename & "." & .Extension  
                    sFolderName = sDrive & .Path  
                      
                      
                    Dim arrShemaInfo(3)  
                    arrShemaInfo(0) = "Format = Delimited(,)"  
                    arrShemaInfo(1) = "DecimalSymbol = ."  
                    arrShemaInfo(2) = "CharacterSet = 1250"  
                    arrShemaInfo(3) = "ColNameHeader = True"  
          
                    ImportZTXT_ADO sFolderName, _  
                                   sFileName, _  
                                   "SELECT * FROM " & sFileName & ";", _  
                                   arrShemaInfo  
                      
                    VBS2MDB_ADO arrDane  
          
                    Kill sFolderName & sFileName  
          
                    k = k + 1  
   
               End If  
            End With  
        End If  
        End With  
              
        If k > 1 Then  
            WScript.Echo "Koniec zabawy :-)"  
            Exit Do  
        End If  
    Loop  
 
    Set objWMIService = Nothing  
    Set colMonitoredEvents = Nothing  
    Set objLatestEvent = Nothing  
 
 
Sub ImportZTXT_ADO(strTXTFilePath, strTXTFileName, strSQL, vShemaInfo())  
    On Error Resume Next  
              
    '----------------utworzenie schema.ini-------------------------  
    Dim objFSO, objStream  
    Const ForWriting = 2  
    strSchemaIniFilePath = strTXTFilePath & "\schema.ini"  
          
    Set objFSO = CreateObject("Scripting.FileSystemObject")  
    Set objStream = objFSO.OpenTextFile(strSchemaIniFilePath, ForWriting, True)  
      
    With objStream  
        .WriteLine "[" & strTXTFileName & "]"  
        For i = LBound(vShemaInfo) To UBound(vShemaInfo)  
            .WriteLine vShemaInfo(i)  
        Next  
        .Close  
    End With  
              
    Set objStream = Nothing  
    Set objFSO = Nothing  
 
    '------------pobieranie danych ADO----------------------------  
    Dim objRecordset  
      
    strConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _  
                          "Data Source=" & strTXTFilePath & ";" & _  
                          "Extended Properties=""text"""  
       
    Set objRecordset = CreateObject("ADODB.Recordset")  
    With objRecordset  
        .Open strSQL, strConnectionString, adOpenStatic  
        If Not (.BOF And .EOF) Then arrDane = .GetRows  
    End With  
                              
    CloseRSObject objRecordset  
 
    If Err.Number <> 0 Then  
         MsgBox "Byk nr: - " & Err.Number & vbCrLf & vbCrLf & _  
                Err.Description, vbExclamation, "VBAProject - ImpZTXTADO"  
    End If  
 
    '----------------usunięcie schema.ini-------------------------  
 
    Kill strSchemaIniFilePath  
 
    '-------------------------------------------------------------  
End Sub  
 
Sub VBS2MDB_ADO(arrDane)  
    On Error Resume Next  
              
    Dim objConnection, objRecordset  
                  
    dazaMDB = sFolderName & "test.mdb"  
    strTblName = "TabelaTest1"  
                  
    Set objConnection = CreateObject("ADODB.Connection")  
    With objConnection  
        .CursorLocation = adUseClient  
        .Mode = adModeWrite  
        .Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dazaMDB & ";"  
        .BeginTrans  
    End With  
              
    Set objRecordset = CreateObject("ADODB.Recordset")  
    objRecordset.Open strTblName, objConnection, adOpenKeyset, adLockOptimistic, adCmdTable  
 
    With objRecordset  
        For iArr = LBound(arrDane, 2) To UBound(arrDane, 2)  
                      
           .AddNew  
           .Fields("Lp") = arrDane(0, iArr)  
           .Fields("Nazwa") = arrDane(1, iArr)  
           .Fields("Liczba") = arrDane(2, iArr)  
           .Fields("Data") = arrDane(3, iArr)  
           .Fields("NazwaPliku") = sFileName  
           .Fields("DataImportu") = Now()  
              
           .Update  
          
        Next  
    End With  
 
    If Err.Number = 0 Then  
        objConnection.CommitTrans  
        MsgBox "Import do mdb przeszedł poprawnie :-)"  
    Else  
        objConnection.RollbackTrans  
        MsgBox Err.Number & " " & Err.Description  
    End If  
                      
    CloseRSObject objRecordset  
    CloseConObject objConnection  
              
End Sub  
 
Sub CloseConObject(objConnection)  
    If Not (objConnection Is Nothing) Then  
        If objConnection.State = adStateOpen Then objConnection.Close  
        Set objConnection = Nothing  
    End If  
End Sub  
          
Sub CloseRSObject(objRecordset)  
    If Not (objRecordset Is Nothing) Then  
        With objRecordset  
            If CBool(.State And adStateOpen) Then  
                If .EditMode <> adEditNone Then .CancelUpdate  
                .Close  
            End If  
        End With  
        Set objRecordset = Nothing  
    End If  
End Sub  
 
Sub Kill(strFilePath)  
    Set objFSO = CreateObject("Scripting.FileSystemObject")  
    With objFSO  
       If .FileExists(strFilePath) Then  
       objFSO.DeleteFile strFilePath  
       End If  
    End With  
    Set objFSO = Nothing  
End Sub  
 
"Malenstwo"?? :-)  
Co najważniejsze:  
 
    sDrive = Split(WScript.ScriptFullName, ":")(0) & ":"  
    sFolder = Split(WScript.ScriptFullName, ":")(1)  
    sFolder = Replace(Left(sFolder, InStrRev(sFolder, "\")), "\", "\\") & "test\\"  
 
określają miejsce folderu z plikami względem skryptu. Mi tak było wygodnie żeby całość działała po przeniesieniu na inną lokalizację  
ale każdy może tu wpisać choćby zwykłą stałą ścieżkę.  
 
    strSQL = "SELECT * " & _  
             "FROM __InstanceOperationEvent WITHIN 1 " & _  
             "WHERE TargetInstance ISA 'CIM_DataFile' AND " & _  
                   "TargetInstance.Drive='" & sDrive & "' AND " & _  
                   "TargetInstance.Path='" & sFolder & "' AND " & _  
                   "TargetInstance.Extension='txt'"  
 
Będę monitorował zdarzenia plików w folderze sFolder (na dysku sDrive) plików z rozszerzeniem txt. Co 1s!!  
Tu ograniczenie :-| Jeżeli pliki txt będą się pojawiały częściej ok. ( w teorii kolejne zdarzenie będzie wywołane po imporcie, w   
praktyce nie testowałem) Jeżeli jednak czas pomiędzy utworzeniem pliku a jego np.: ręcznym usunięciem będzie <1s to tego  
pliku program może nie zauważyć!  
 
    Do  
        Set objLatestEvent = colMonitoredEvents.NextEvent  
      
        With objLatestEvent  
            If .Path_.Class = "__InstanceCreationEvent" Then  
            With .TargetInstance  
                If (.Filename & "." & .Extension) Like "*.txt" Then  
            
                    sFileName = .Filename & "." & .Extension  
                    sFolderName = sDrive & .Path  
 
Monitorujemy zdarzenia. Jeżeli nastąpi "__InstanceCreationEvent" - utworzenie pliku.. Odczytujemy jego nazwę i położenie.  
Niby folder już mieliśmy na początku ale był on zamieniony (Relace) na format z podwójnym \\ w ścieżce. Tu nam się taki nie  
przyda.  
 
                    Dim arrShemaInfo(3)  
                    arrShemaInfo(0) = "Format = Delimited(,)"  
                    arrShemaInfo(1) = "DecimalSymbol = ."  
                    arrShemaInfo(2) = "CharacterSet = 1250"  
                    arrShemaInfo(3) = "ColNameHeader = True"  
          
                    ImportZTXT_ADO sFolderName, _  
                                   sFileName, _  
                                   "SELECT * FROM " & sFileName & ";", _  
                                   arrShemaInfo  
 
Importujemy dane z pliku txt do publicznej tablicy arrDane. Dokonuje tego procedurka z mojego działu ADO poprawiona do celów  
wykorzystania w skrypcie.   Import danych z pliku TXT ADO
    Do najistotniejszych zmian należą:  
 - inna obsługa błędów  
 - Tworzenie pliku schema.ini i jego usunięcie za pomocą metod Scripting.FileSystemObject  
 
                    VBS2MDB_ADO arrDane  
 
Dane z tablicy arrDane zapisujemy do naszej bazy mdb.   ADOX i MDB
Sub Excel2MDBADODB()
To też przeróbka mojej "starej" procedury z tego samego działu. Linki obok.   
 
                    Kill sFolderName & sFileName  
 
Usunięcie pliku txt z danymi po imporcie do mdb.  
 
i działa :-) Nasza pracę wykonuje automat, a My… (oby nie do zwolnienia ;-) )  
 
Ps:
 
dla "szczęśliwych" posiadaczy systemów 64bit'owych  
 
Odpalenie skryptu poprzez prosty dwuklik na ikonę powoduje   
błąd z obrazka.  
Jak udało mi się ustalić (mkkk23 dzięki za pomoc :-) )  
rozwiązaniem jest odpalenie skryptu w 32bitowej wersji  
cscript.exe.  
Jak to zrobić: wierszem poleceń lub choćby:  
 
Sub StartVBS()  
    'Jeżeli masz 64bit system to skrypt odpalasz tak...   Pliki z przykładu:
    Dim oWs As Object   skryptADO.vbs
    Set oWs = CreateObject("WScript.Shell")   ŹródłoPlików.xlsm
  test\test.mdb
    oWs.Run "C:\Windows\SysWow64\WScript.exe " & ThisWorkbook.Path & "\skryptADO.vbs "   spakowane Zip'em
    Set oWs = Nothing  
 
End Sub  
 
Enjoi :-)