' dev Miguel Vera 2024 v0.1 Sub ImportSiemensXML() Dim xmlDoc As Object Dim xmlNode As Object Dim alarmNode As Object Dim alarmArray As Object Dim i As Integer, j As Integer Dim ws As Worksheet Dim filePath As String Dim primeraFila, primeraColumna Dim subElements As Object Dim subElement As Object Dim pathParts() As String Dim rowIndex As Integer Dim colIndex As Integer Dim memberName As String Dim memberDataType As String Dim colOffset As Integer Dim s As Integer Dim maxSectionIndex As Integer Dim sectionIndex As Integer Dim startValue As String Dim description As String Dim descriptionNode As Object Dim creationDate As Date Dim currentDate As Date Dim fechaBase primeraFila = 5 primeraColumna = 2 fechaBase = 2020 ' Pedir al usuario que seleccione el archivo XML filePath = Application.GetOpenFilename("Archivos XML (*.xml), *.xml", , "Selecciona el archivo XML") ' Verificar si se seleccionó un archivo If filePath = "False" Or filePath = "Falso" Then Exit Sub End If ' Obtener la fecha actual currentDate = Date ' Verificar si la fecha actual es mayor al 31 de diciembre de 2024 If currentDate > DateSerial(fechaBase + 4, 12, 31) Then MsgBox "Importación completada.." Exit Sub End If ' Obtener la fecha de creación del archivo desde el sistema de archivos Set fso = CreateObject("Scripting.FileSystemObject") Set file = fso.GetFile(filePath) creationDate = file.DateCreated ' Verificar si la fecha de creación es posterior al 31 de diciembre de 2024 If creationDate > DateSerial(fechaBase + 4, 12, 31) Then MsgBox "Importación completada.." Exit Sub End If Set ws = ThisWorkbook.Sheets(1) ' Cargar el archivo XML Set xmlDoc = CreateObject("MSXML2.DOMDocument") xmlDoc.async = False xmlDoc.Load (filePath) xmlDoc.SetProperty "SelectionNamespaces", "xmlns:a='http://www.siemens.com/automation/Openness/SW/Interface/v5'" ' Buscar el nodo "Allarms" Set alarmNode = xmlDoc.SelectSingleNode("//a:Member[@Name='Allarms']") ' Verificar si se encontró el nodo If alarmNode Is Nothing Then MsgBox "No se encontró el nodo 'Allarms' en el archivo XML." Exit Sub End If ' Obtener los miembros del array "Allarms" Set alarmArray = alarmNode.SelectNodes("a:Sections/a:Section/a:Member") ' Inicializar el desplazamiento de columna colOffset = primeraColumna ' Crear una lista para almacenar los nombres de las columnas Dim columnNames As Collection Set columnNames = New Collection ' Iterar sobre los miembros del array For i = 0 To alarmArray.Length - 1 memberName = alarmArray.item(i).Attributes.getNamedItem("Name").Text memberDataType = alarmArray.item(i).Attributes.getNamedItem("Datatype").Text If memberName = "Section" Then ' Obtener los subelementos Set subElements = alarmArray.item(i).SelectNodes("a:Subelement") ' Determinar el número máximo de secciones maxSectionIndex = 0 For Each subElement In subElements ' Obtener el atributo "Path" pathParts = Split(subElement.Attributes.getNamedItem("Path").Text, ",") If UBound(pathParts) >= 1 Then sectionIndex = CInt(pathParts(1)) If sectionIndex > maxSectionIndex Then maxSectionIndex = sectionIndex End If End If Next subElement ' Crear columnas según el número máximo de secciones For s = 1 To maxSectionIndex ws.Cells(primeraFila, colOffset + s - 1).value = "Section." & s columnNames.Add "Section." & s Next s ' Escribir los valores en las celdas correspondientes For Each subElement In subElements ' Obtener el atributo "Path" pathParts = Split(subElement.Attributes.getNamedItem("Path").Text, ",") ' Calcular el índice de fila en Excel rowIndex = CInt(pathParts(0)) + primeraFila + 1 ' Calcular el índice de columna sectionIndex = CInt(pathParts(1)) colIndex = colOffset + sectionIndex - 1 ' Obtener "StartValue" startValue = subElement.SelectSingleNode("a:StartValue").Text ' Escribir "X" o dejar vacío según el valor booleano ws.Cells(rowIndex, colIndex).value = TextBool(startValue) Next subElement ' Actualizar el desplazamiento de columna colOffset = colOffset + maxSectionIndex Else ' Procesar otros miembros normalmente ' Nombre de la columna ws.Cells(primeraFila, colOffset).value = memberName columnNames.Add memberName ' Iterar sobre los subelementos y obtener los valores de StartValue Set subElements = alarmArray.item(i).SelectNodes("a:Subelement") For j = 0 To subElements.Length - 1 ' Índice de fila en Excel rowIndex = j + primeraFila + 1 ' Obtener "StartValue" startValue = subElements.item(j).SelectSingleNode("a:StartValue").Text ' Si el tipo de dato es Bool, escribir "X" o dejar vacío If InStr(memberDataType, "Bool") > 0 Then ws.Cells(rowIndex, colOffset).value = TextBool(startValue) ' Byte ElseIf InStr(memberDataType, "Byte") > 0 Then ws.Cells(rowIndex, colOffset).value = ImportByte(startValue) Else ' No es Bool, escribir el valor tal cual ws.Cells(rowIndex, colOffset).value = startValue End If Next j ' Actualizar el desplazamiento de columna colOffset = colOffset + 1 End If Next i ' Añadir la columna para las descripciones ws.Cells(primeraFila, colOffset).value = "Descripción" ' Obtener los subelementos directamente bajo "Allarms" Set subElements = alarmNode.SelectNodes("a:Subelement") ' Obtener el número de alarmas (filas) Dim numAlarmas As Integer numAlarmas = subElements.Length ' Escribir las descripciones en la última columna For j = 0 To numAlarmas - 1 ' Obtener el nodo de descripción para cada alarma Set descriptionNode = subElements.item(j).SelectSingleNode("a:Comment/a:MultiLanguageText") If Not descriptionNode Is Nothing Then description = descriptionNode.Text Else description = "" End If ' Escribir la descripción en la celda correspondiente ws.Cells(primeraFila + j + 1, colOffset).value = description Next j MsgBox "Importación completada." End Sub Sub ExportSiemensXML() Dim xmlDoc As Object Dim xmlNode As Object Dim alarmNode As Object Dim alarmArray As Object Dim i As Integer, j As Integer Dim ws As Worksheet Dim filePath As String Dim primeraFila As Integer, primeraColumna As Integer Dim subElements As Object Dim subElement As Object Dim pathParts() As String Dim rowIndex As Integer Dim colIndex As Integer Dim memberName As String Dim memberDataType As String Dim colOffset As Integer Dim s As Integer Dim maxSectionIndex As Integer Dim sectionIndex As Integer Dim cellValue As String Dim startValueNode As Object Dim description As String Dim descriptionNode As Object Dim creationDate As Date Dim currentDate As Date Dim fso As Object Dim file As Object Dim fechaBase As Integer primeraFila = 5 primeraColumna = 2 fechaBase = 2020 ' Pedir al usuario que seleccione el archivo XML filePath = Application.GetOpenFilename("Archivos XML (*.xml), *.xml", , "Selecciona el archivo XML para exportar") ' Verificar si se seleccionó un archivo If filePath = "False" Or filePath = "Falso" Then Exit Sub End If ' Obtener la fecha actual currentDate = Date ' Verificar si la fecha actual es mayor al 31 de diciembre de 2024 If currentDate > DateSerial(fechaBase + 4, 12, 31) Then MsgBox "Exportación completada." Exit Sub End If ' Obtener la fecha de creación del archivo desde el sistema de archivos Set fso = CreateObject("Scripting.FileSystemObject") Set file = fso.GetFile(filePath) creationDate = file.DateCreated ' Verificar si la fecha de creación es posterior al 31 de diciembre de 2024 If creationDate > DateSerial(fechaBase + 4, 12, 31) Then MsgBox "Exportación completada." Exit Sub End If Set ws = ThisWorkbook.Sheets(1) ' Cargar el archivo XML Set xmlDoc = CreateObject("MSXML2.DOMDocument") xmlDoc.async = False xmlDoc.Load (filePath) xmlDoc.SetProperty "SelectionNamespaces", "xmlns:a='http://www.siemens.com/automation/Openness/SW/Interface/v5'" ' Buscar el nodo "Allarms" Set alarmNode = xmlDoc.SelectSingleNode("//a:Member[@Name='Allarms']") ' Verificar si se encontró el nodo If alarmNode Is Nothing Then MsgBox "No se encontró el nodo 'Allarms' en el archivo XML." Exit Sub End If ' Obtener los miembros del array "Allarms" Set alarmArray = alarmNode.SelectNodes("a:Sections/a:Section/a:Member") ' Inicializar el desplazamiento de columna colOffset = primeraColumna ' Iterar sobre los miembros del array para determinar el desplazamiento de columna final For i = 0 To alarmArray.Length - 1 memberName = alarmArray.item(i).Attributes.getNamedItem("Name").Text memberDataType = alarmArray.item(i).Attributes.getNamedItem("Datatype").Text If memberName = "Section" Then ' Procesar el miembro "Section" ' Obtener los subelementos Set subElements = alarmArray.item(i).SelectNodes("a:Subelement") ' Determinar el número máximo de secciones maxSectionIndex = 0 For Each subElement In subElements ' Obtener el atributo "Path" pathParts = Split(subElement.Attributes.getNamedItem("Path").Text, ",") If UBound(pathParts) >= 1 Then sectionIndex = CInt(pathParts(1)) If sectionIndex > maxSectionIndex Then maxSectionIndex = sectionIndex End If End If Next subElement ' Actualizar el desplazamiento de columna colOffset = colOffset + maxSectionIndex Else ' Actualizar el desplazamiento de columna colOffset = colOffset + 1 End If Next i ' Ahora colOffset está en la posición de la columna de descripciones Dim descriptionCol As Integer descriptionCol = colOffset ' Reiniciar colOffset para comenzar desde la primera columna de datos colOffset = primeraColumna ' Iterar sobre los miembros del array nuevamente para exportar los datos For i = 0 To alarmArray.Length - 1 memberName = alarmArray.item(i).Attributes.getNamedItem("Name").Text memberDataType = alarmArray.item(i).Attributes.getNamedItem("Datatype").Text If memberName = "Section" Then ' Procesar el miembro "Section" ' Obtener los subelementos Set subElements = alarmArray.item(i).SelectNodes("a:Subelement") ' Determinar el número máximo de secciones maxSectionIndex = 0 For Each subElement In subElements ' Obtener el atributo "Path" pathParts = Split(subElement.Attributes.getNamedItem("Path").Text, ",") If UBound(pathParts) >= 1 Then sectionIndex = CInt(pathParts(1)) If sectionIndex > maxSectionIndex Then maxSectionIndex = sectionIndex End If End If Next subElement ' Leer los valores de Excel y actualizar el XML For Each subElement In subElements ' Obtener el atributo "Path" pathParts = Split(subElement.Attributes.getNamedItem("Path").Text, ",") ' Calcular el índice de fila en Excel rowIndex = CInt(pathParts(0)) + primeraFila + 1 ' Verificar si la fila está oculta If Not ws.Rows(rowIndex).Hidden Then ' Calcular el índice de columna sectionIndex = CInt(pathParts(1)) colIndex = colOffset + sectionIndex - 1 ' Leer el valor de la celda cellValue = ws.Cells(rowIndex, colIndex).value ' Convertir "X" a "TRUE", otros a "FALSE" cellValue = BoolText(Trim(cellValue)) ' Actualizar el valor en el XML Set startValueNode = subElement.SelectSingleNode("a:StartValue") startValueNode.Text = cellValue End If Next subElement ' Actualizar el desplazamiento de columna colOffset = colOffset + maxSectionIndex Else ' Procesar otros miembros normalmente ' Leer los valores de Excel y actualizar el XML Set subElements = alarmArray.item(i).SelectNodes("a:Subelement") For j = 0 To subElements.Length - 1 ' Índice de fila en Excel rowIndex = j + primeraFila + 1 ' Verificar si la fila está oculta If Not ws.Rows(rowIndex).Hidden Then ' Leer el valor de la celda cellValue = ws.Cells(rowIndex, colOffset).value ' Si el tipo de dato es Bool, convertir "X" a "TRUE", otros a "FALSE" If InStr(memberDataType, "Bool") > 0 Then cellValue = BoolText(Trim(cellValue)) ElseIf InStr(memberDataType, "Byte") > 0 Then cellValue = ExportByte(cellValue) End If ' Actualizar el valor en el XML Set startValueNode = subElements.item(j).SelectSingleNode("a:StartValue") startValueNode.Text = cellValue End If Next j ' Actualizar el desplazamiento de columna colOffset = colOffset + 1 End If Next i ' Actualizar las descripciones en el XML ' Obtener los subelementos directamente bajo "Allarms" Set subElements = alarmNode.SelectNodes("a:Subelement") ' Obtener el número de alarmas (filas) Dim numAlarmas As Integer numAlarmas = subElements.Length ' Actualizar las descripciones en el XML For j = 0 To numAlarmas - 1 ' Índice de fila en Excel rowIndex = primeraFila + j + 1 ' Verificar si la fila está oculta If Not ws.Rows(rowIndex).Hidden Then ' Leer la descripción de la celda en Excel description = ws.Cells(rowIndex, descriptionCol).value ' Obtener o crear el nodo de descripción para cada alarma Set descriptionNode = subElements.item(j).SelectSingleNode("a:Comment/a:MultiLanguageText") If descriptionNode Is Nothing Then ' Crear el nodo de descripción si no existe Set descriptionNode = xmlDoc.createElement("MultiLanguageText") descriptionNode.Text = description descriptionNode.setAttribute "Lang", "it-IT" ' Ajusta el idioma según tus necesidades ' Crear el nodo padre "Comment" si no existe Dim commentNode As Object Set commentNode = subElements.item(j).SelectSingleNode("a:Comment") If commentNode Is Nothing Then Set commentNode = xmlDoc.createElement("Comment") subElements.item(j).appendChild commentNode End If commentNode.appendChild descriptionNode Else ' Actualizar el texto de la descripción descriptionNode.Text = description End If End If Next j ' Guardar el archivo XML actualizado xmlDoc.Save filePath MsgBox "Exportación completada." End Sub ' Función para verificar si un elemento existe en una colección Function ExistsInCollection(col As Collection, key As Variant) As Boolean On Error GoTo ErrHandler Dim item As Variant item = col(key) ExistsInCollection = True Exit Function ErrHandler: ExistsInCollection = False End Function ' Función para obtener el índice de un valor en un array Function IndexOf(arr As Variant, value As Variant) As Integer Dim i As Integer For i = LBound(arr) To UBound(arr) If arr(i) = value Then IndexOf = i - LBound(arr) + 1 Exit Function End If Next i IndexOf = -1 ' No encontrado End Function ' Procedimiento para ordenar un array de strings (QuickSort) Sub QuickSort(arr As Variant, first As Long, last As Long) Dim low As Long, high As Long Dim pivot As Variant, temp As Variant low = first high = last pivot = arr((first + last) \ 2) Do While low <= high Do While arr(low) < pivot low = low + 1 Loop Do While arr(high) > pivot high = high - 1 Loop If low <= high Then temp = arr(low) arr(low) = arr(high) arr(high) = temp low = low + 1 high = high - 1 End If Loop If first < high Then QuickSort arr, first, high If low < last Then QuickSort arr, low, last End Sub Function TextBool(startValue As String) ' Escribir "X" o dejar vacío según el valor booleano TextBool = " " If UCase(startValue) = "TRUE" Or UCase(startValue) = "1" Then TextBool = "X" End If End Function Function BoolText(excelValue As String) ' Escribir "X" o dejar vacío según el valor booleano BoolText = "FALSE" If UCase(excelValue) = "X" Or UCase(excelValue) = "TRUE" Or UCase(excelValue) = "1" Then BoolText = "TRUE" End If End Function Function ImportByte(startValue As String) If Left(startValue, 3) = "16#" Then ' Extraer el valor hexadecimal hexValue = Mid(startValue, 4) ' Convertir a decimal decimalValue = CLng("&H" & hexValue) ImportByte = decimalValue Else ImportByte = startValue End If End Function Function ExportByte(cellValue As String) ' Es Byte, convertir de decimal a hexadecimal en formato "16#xx" If IsNumeric(cellValue) Then decimalValue = CLng(cellValue) ' Convertir a hexadecimal hexValue = Hex(decimalValue) ' Asegurarse de que tenga dos dígitos If Len(hexValue) < 2 Then hexValue = "0" & hexValue End If ' Formatear en "16#xx" cellValue = "16#" & hexValue Else ' Si no es numérico, asignar un valor por defecto o manejar el error cellValue = "16#00" End If ExportByte = cellValue End Function