' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub getDataXML()
Dim objFiles() As Object
Dim strPath As String, strTmp As String, strA As String, strB As String
Dim strF1 As String, strF2 As String
Dim lngI As Long, lngRet As Long, lngR As Long
Dim FF As Integer
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlManual
.DisplayAlerts = False
End With
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "E:\" 'Startverzeichnis - Anpassen!
.Title = "XML Import Ordnerauswahl"
.ButtonName = "Import Starten"
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strPath = .SelectedItems(1)
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
End If
End With
If Len(strPath) Then
lngRet = FileSearchFSO(objFiles, strPath, "*.xml", True)
If lngRet > 0 Then
strF1 = "snapshotStatus>"
strF2 = "status>"
lngR = 2
With Sheets("Tabelle1") 'Ausgabetabelle - Anpassen!
.Range("A2:C" & .Rows.Count).ClearContents
For lngI = 0 To lngRet - 1
strA = "n/a": strB = "n/a"
.Cells(lngR, 1) = objFiles(lngI).Path
FF = FreeFile
Open objFiles(lngI).Path For Input As #FF
Do While Not EOF(FF)
Line Input #FF, strTmp
If InStr(1, strTmp, strF1) > 0 Then
strA = Mid(strTmp, InStr(1, strTmp, strF1) + Len(strF1), InStr(1, strTmp, "</" & strF1) _
- (InStr(1, strTmp, strF1) + Len(strF1)))
End If
If InStr(1, strTmp, strF2) > 0 Then
strB = Mid(strTmp, InStr(1, strTmp, strF2) + Len(strF2), InStr(1, strTmp, "</" & strF2) _
- (InStr(1, strTmp, strF2) + Len(strF2)))
End If
Loop
Close #FF
.Cells(lngR, 2) = strA
.Cells(lngR, 3) = strB
lngR = lngR + 1
Next
End With
End If
End If
ErrExit:
With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'getDataXML'" & vbLf & String(60, "_") & vbLf & vbLf & _
IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & "Fehlernummer:" & vbTab & _
.Number & vbLf & vbLf & "Beschreibung:" & vbTab & .Description & vbLf, vbExclamation + _
vbMsgBoxSetForeground, "VBA - Fehler in Prozedur - getDataXML"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlAutomatic
.DisplayAlerts = True
.StatusBar = False
End With
End Sub
Private Function FileSearchFSO(ByRef Files() As Object, ByVal InitialPath As String, Optional ByVal FileName As String = "*", _
Optional ByVal SubFolders As Boolean = False) As Long
'# PARAMETERINFO:
'# Files: Datenfeld zur Ausgabe der Suchergebnisse
'# InitialPath: String der das zu durchsuchende Verzeichnis angibt
'# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*.*" findet alle Dateien)
'# Beispiele: "*.txt" - Findet alle Textdateien
'# "*name*" - Findet alle Dateien mit "name" im Dateinamen
'# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
'# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard=False)
Dim mobjFSO As Object, mfsoFolder As Object, mfsoSubFolder As Object, mfsoFile As Object
Dim intC As Integer, varFiles As Variant
Set mobjFSO = CreateObject("Scripting.FileSystemObject")
Set mfsoFolder = mobjFSO.GetFolder(InitialPath)
On Error GoTo ErrExit
If InStr(1, FileName, ";") > 0 Then
varFiles = Split(FileName, ";")
Else
Redim varFiles(0)
varFiles(0) = FileName
End If
For Each mfsoFile In mfsoFolder.Files
If Not mfsoFile Is Nothing Then
For intC = 0 To UBound(varFiles)
If LCase(mobjFSO.GetFileName(mfsoFile)) Like LCase(varFiles(intC)) Then
If IsArray(Files) Then
Redim Preserve Files(UBound(Files) + 1)
Else
Redim Files(0)
End If
Set Files(UBound(Files)) = mfsoFile
Exit For
End If
Next
End If
Next
If SubFolders Then
For Each mfsoSubFolder In mfsoFolder.SubFolders
FileSearchFSO Files, mfsoSubFolder, FileName, SubFolders
Next
End If
If IsArray(Files) Then FileSearchFSO = UBound(Files) + 1
ErrExit:
Set mobjFSO = Nothing
Set mfsoFolder = Nothing
End Function
