Hallo zusammen.
Kurzes Update:
Das mit dem Handlen per Windows API hat nicht geklappt. Ich werde versuchen nur die Livedaten über die Api abzugreifen. Aber das ist Zukunftsprojekt.
Ich machs jetzt über
Sub Daten()
Dim xmlDoc As Object
Dim xmlNode As Object
Dim filePath As String
Dim currentRow As Long
Dim cell As Range
Dim colIndex As Integer
Dim foundRow As Range
Dim paramIdCol As Integer: paramIdCol = 4
' Bereich der Zellen festlegen, die Dateipfade enthalten
Dim fileCells As Range
Sheets(2).Activate
Set fileCells = ActiveWorkbook.Sheets(2).Range("A10:Z" & ActiveWorkbook.Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row - 1)
' XML-Objekt initialisieren
Set xmlDoc = CreateObject("MSXML2.DOMDocument")
xmlDoc.Async = False
xmlDoc.ValidateOnParse = False
' Neue Tabelle vorbereiten
Sheets(3).Cells.Clear
With Sheets(3)
.Cells(1, 1).Value = "ID"
.Cells(1, 2).Value = "Beschriftung"
.Cells(1, 3).Value = "Code"
.Cells(1, 4).Value = "ID"
.Cells(1, 5).Value = "Wert"
End With
currentRow = 2
colIndex = 6 ' Spalte F für zweite Datei
For Each cell In fileCells
If cell.Value <> "" Then
If cell.Hyperlinks.Count > 0 And cell.Hyperlinks(1).Address <> "" Then
filePath = cell.Hyperlinks(1).Address
If filePath <> "" And LCase(Right(filePath, 5)) = ".xcfg" Then
If Dir(filePath) <> "" Then
If xmlDoc.Load(filePath) Then
' Blattüberschrift mit Dateinamen
Dim fileName As String
fileName = Mid(filePath, InStrRev(filePath, "\") + 1)
fileName = Replace(fileName, ".xcfg", "")
If Len(fileName) > 31 Then fileName = Left(fileName, 31)
Sheets(3).Cells(1, colIndex).Value = fileName
' Daten auslesen und verarbeiten
If colIndex = 6 Then
' Erste Datei vollständig ausgeben
ParseAndWriteFirstFile xmlDoc.DocumentElement, currentRow
Else
' Weitere Dateien vergleichen und Werte eintragen
ParseAndCompareFiles xmlDoc.DocumentElement, colIndex, paramIdCol
End If
colIndex = colIndex + 1
End If
End If
End If
End If
End If
Next cell
MsgBox "Analyse und Vergleich abgeschlossen!"
End Sub
Sub ParseAndWriteFirstFile(node As Object, ByRef rowNum As Long)
Dim childNode As Object
Dim paramCode As String
Dim paramId As String
Dim baseName As String
paramCode = ""
paramId = ""
baseName = node.baseName
If Not node.Attributes Is Nothing Then
If Not node.Attributes.getNamedItem("paramCode") Is Nothing Then
paramCode = node.Attributes.getNamedItem("paramCode").text
End If
If Not node.Attributes.getNamedItem("paramId") Is Nothing Then
paramId = node.Attributes.getNamedItem("paramId").text
End If
End If
If paramId <> "" Then
With Sheets(3)
.Cells(rowNum, 1).Value = rowNum - 1
.Cells(rowNum, 2).Value = baseName
.Cells(rowNum, 3).Value = paramCode
.Cells(rowNum, 4).Value = paramId
.Cells(rowNum, 5).Value = node.text
End With
rowNum = rowNum + 1
End If
If node.ChildNodes.Length > 0 Then
For Each childNode In node.ChildNodes
ParseAndWriteFirstFile childNode, rowNum
Next childNode
End If
End Sub
Sub ParseAndCompareFiles(node As Object, colIndex As Integer, paramIdCol As Integer)
Dim childNode As Object
Dim paramCode As String
Dim paramId As String
Dim baseName As String
Dim foundRow As Range
paramCode = ""
paramId = ""
baseName = node.baseName
If Not node.Attributes Is Nothing Then
If Not node.Attributes.getNamedItem("paramCode") Is Nothing Then
paramCode = node.Attributes.getNamedItem("paramCode").text
End If
If Not node.Attributes.getNamedItem("paramId") Is Nothing Then
paramId = node.Attributes.getNamedItem("paramId").text
End If
End If
If paramId <> "" Then
Set foundRow = Sheets(3).Columns(paramIdCol).Find(paramId, LookIn:=xlValues, LookAt:=xlWhole)
If Not foundRow Is Nothing Then
' Wert in entsprechende Zeile eintragen
Sheets(3).Cells(foundRow.Row, colIndex).Value = node.text
' Unterschied markieren
If Sheets(3).Cells(foundRow.Row, 5).Value <> node.text Then
Sheets(3).Cells(foundRow.Row, colIndex).Interior.Color = RGB(255, 0, 0)
End If
Else
' Neuer Eintrag, wenn paramID nicht gefunden wurde
Dim lastRow As Long
lastRow = Sheets(3).Cells(Rows.Count, 1).End(xlUp).Row + 1
With Sheets(3)
.Cells(lastRow, 1).Value = lastRow
.Cells(lastRow, 2).Value = baseName
.Cells(lastRow, 3).Value = paramCode
.Cells(lastRow, 4).Value = paramId
.Cells(lastRow, colIndex).Value = node.text
End With
End If
End If
If node.ChildNodes.Length > 0 Then
For Each childNode In node.ChildNodes
ParseAndCompareFiles childNode, colIndex, paramIdCol
Next childNode
End If
End Sub
damit lässt sich zugreifen, mit einem weiteren script schreibe ich die änderungen in die Datei zurück. dabei gibt es noch Probleme, denn viele Werte werden nicht gefunden und nicht somit nicht übertragen und dann ist datei korrupt. ( Grund warum ich
Vielen Dank für eure Bemühungen.
|