Batch XML Importer - Import von Dateien mittels Batch und xml-File

Option Explicit


'Konfiguration  
Const strSourceFolder = "C:\Scans\Auftraege"  
Const strDestFolder   = "W:\Auftraege"  


'Deklaration der globalen Variablen  
Dim objFSO, objXMLDoc, objFile
Dim strFilePath, strFileName, strPageCount, strJobNum, strYear


'Objekte erzeugen  
Set objFSO    = CreateObject("Scripting.FileSystemObject")  
Set objXMLDoc = CreateObject("MSXML2.DOMDocument.6.0")  


'Hauptprogramm  
For Each objFile In objFSO.GetFolder(strSourceFolder).Files
  If StrComp(objFSO.GetExtensionName(objFile.Path), "xml", vbTextCompare) = 0 Then  
    If LoadXMLFile(objFile.Path) Then
      Call ParseXMLFile
      If ProcessTask Then Call DeleteFile(objFile.Path)
    Else
      WScript.Echo "Fehler beim Laden der Datei" & vbCrLf & _  
                   objFile.Path & vbCrLf & _
                   objXMLDoc.parseError.reason
    End If
  End If
Next



'******************** Unterprogramme *******************  

Function LoadXMLFile(strFilePath)
  objXMLDoc.async            = False
  objXMLDoc.validateOnParse  = False
  objXMLDoc.resolveExternals = False

  Call objXMLDoc.load(strFilePath)

  LoadXMLFile = (objXMLDoc.parseError.errorCode = 0)
End Function


Sub ParseXMLFile
  Dim objScanIndex, objImgProps, objFieldsInfo, objFieldInfo
  Dim strFieldName
  
  'XML-Knoten ScanIndex einlesen und Attribute auswerten  
  Set objScanIndex  = objXMLDoc.documentElement.selectSingleNode("//ScanIndex")  
  strFileName       = objScanIndex.getAttribute("FileName")  
  strPageCount      = objScanIndex.getAttribute("Seitengespeichert")  
                    
  'XML-Knoten ImagePropertys einlesen und Attribute auswerten  
  Set objImgProps   = objXMLDoc.documentElement.selectSingleNode("//ImagePropertys")  
  strFilePath       = objImgProps.getAttribute("Path")  

  'XML-Knoten FieldsInfo einlesen...  
  Set objFieldsInfo = objXMLDoc.documentElement.selectSingleNode("//FieldsInfo")  

  '...und Attribute auswerten  
  For Each objFieldInfo In objFieldsInfo.childNodes
    strFieldName = objFieldInfo.getAttribute("Feldname")  
    
    If     strFieldName = "Jahr" Then  
      strYear   = objFieldInfo.getAttribute("Wert")  
    ElseIf strFieldName = "Auftrags-Nr." Then  
      strJobNum = objFieldInfo.getAttribute("Wert")  
    End If
  Next
End Sub


Function ProcessTask
  On Error Resume Next
  
  Dim intCnt, intFileCnt
  Dim strSrcFileName, strSrcFilePath, strDstFileName, strDstFilePath
  Dim arrFiles
  
  intFileCnt = CInt(strPageCount)
  arrFiles   = Array()
  
  For intCnt = 1 To intFileCnt
    If intFileCnt = 1 Then
      strSrcFilePath = objFSO.BuildPath(strFilePath, strFileName)
      strDstFileName = objFSO.GetBaseName(strFileName) & "_" & strJobNum & "." & objFSO.GetExtensionName(strFileName)  
      strDstFilePath = objFSO.BuildPath(strDestFolder, strYear & "\" & strJobNum & "\" & strDstFileName)  
    Else
      strSrcFileName = objFSO.GetBaseName(strFileName) & "_" & Right("00" & CStr(intCnt), 3) & "." & objFSO.GetExtensionName(strFileName)  
      strSrcFilePath = objFSO.BuildPath(strFilePath, strSrcFileName)
      strDstFileName = objFSO.GetBaseName(strSrcFileName) & "_" & strJobNum & "." & objFSO.GetExtensionName(strSrcFileName)  
      strDstFilePath = objFSO.BuildPath(strDestFolder, strYear & "\" & strJobNum & "\" & strDstFileName)  
    End If
    
    ProcessTask = CopyFile(strSrcFilePath, strDstFilePath)
    If Not ProcessTask Then Exit For
    
    ReDim Preserve arrFiles(UBound(arrFiles) + 1)
    arrFiles(UBound(arrFiles)) = strSrcFilePath
  Next
  
  If ProcessTask Then Call DeleteImageFiles(arrFiles)
End Function


Function CopyFile(strSrcFilePath, strDstFilePath)
  On Error Resume Next
  
  Dim objShell, strDstPath
  
  strDstPath = objFSO.GetParentFolderName(strDstFilePath)
  
  If Not objFSO.FolderExists(strDstPath) Then
    Set objShell = CreateObject("WScript.Shell")  
    Call objShell.Run("cmd /c mkdir """ & strDstPath & """", 0, True)  
  End If
  
  Call objFSO.CopyFile(strSrcFilePath, strDstFilePath, False)
  CopyFile = (Err.Number = 0)

  Call TestError("Fehler beim Kopieren der Datei", strSrcFilePath)  
End Function


Sub DeleteImageFiles(ByRef arrFiles)
  On Error Resume Next
  
  Dim intCnt
  
  For intCnt = 0 To UBound(arrFiles)
    Call DeleteFile(arrFiles(intCnt))
  Next
End Sub


Sub DeleteFile(strFilePath)
  On Error Resume Next
  
  Call objFSO.DeleteFile(strFilePath, True)
  Call TestError("Fehler beim Löschen der Datei", strFilePath)  
End Sub


Sub TestError(strMessage, strFilePath)
  If Err.Number <> 0 Then
    WScript.Echo strMessage & vbCrLf & _
                 strFilePath & vbCrLf & _
                 Err.Description
    Err.Clear
  End If
End Sub