' 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 Sub GenerateSiemensXML() Dim xmlDoc As Object Dim rootNode As Object Dim documentNode As Object Dim xmlDeclaration As Object Dim alarmNode As Object Dim alarmsSectionsNode As Object Dim alarmsSectionNode As Object Dim newMemberNode As Object Dim subElementNode As Object Dim startValueNode As Object Dim commentNode As Object Dim multiLanguageTextNode As Object Dim attributeListNode As Object Dim nameNode 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 numAlarmas As Integer Dim colOffset As Integer Dim memberName As String Dim memberDataType As String Dim colIndex As Integer Dim rowIndex As Integer Dim cellValue As String Dim description As String Dim decimalValue As Long Dim hexValue As String Dim maxSectionIndex As Integer Dim sectionIndex As Integer primeraFila = 5 primeraColumna = 2 ' Pedir al usuario que seleccione la ubicación para guardar el archivo XML filePath = Application.GetSaveAsFilename("NuevoArchivo.xml", "Archivos XML (*.xml), *.xml", , "Guardar archivo XML") ' Verificar si se seleccionó una ruta If filePath = "False" Or filePath = "Falso" Then Exit Sub End If Set ws = ThisWorkbook.Sheets(1) ' Crear el documento XML Set xmlDoc = CreateObject("MSXML2.DOMDocument") xmlDoc.async = False ' Añadir la declaración XML Set xmlDeclaration = xmlDoc.createProcessingInstruction("xml", "version='1.0' encoding='UTF-8'") xmlDoc.appendChild xmlDeclaration ' Crear el nodo raíz Set rootNode = xmlDoc.createElement("Document") xmlDoc.appendChild rootNode ' Añadir el nodo de información del documento (opcional) Set documentNode = xmlDoc.createElement("DocumentInfo") rootNode.appendChild documentNode ' Aquí puedes añadir más información al DocumentInfo si lo deseas ' Crear el nodo "SW.DT" Set alarmNode = xmlDoc.createElement("SW.DT") alarmNode.setAttribute "ID", "0" rootNode.appendChild alarmNode ' Crear el nodo "AttributeList" dentro de "SW.DT" Set attributeListNode = xmlDoc.createElement("AttributeList") alarmNode.appendChild attributeListNode ' Añadir los atributos necesarios (Nombre, Comentario, etc.) Set nameNode = xmlDoc.createElement("Name") nameNode.Text = "AllarmsDB" attributeListNode.appendChild nameNode ' Añadir más atributos según sea necesario ' Crear el nodo "Sections" dentro de "SW.DT" Set sectionsNode = xmlDoc.createElement("Sections") alarmNode.appendChild sectionsNode ' Crear la sección "Static" Set sectionNode = xmlDoc.createElement("Section") sectionNode.setAttribute "Name", "Static" sectionsNode.appendChild sectionNode ' Crear el miembro "Allarms" Set memberNode = xmlDoc.createElement("Member") memberNode.setAttribute "Name", "Allarms" memberNode.setAttribute "Datatype", "Array" sectionNode.appendChild memberNode ' Crear los nodos necesarios dentro de "Allarms" ' Aquí asumiremos que tienes una estructura similar a la del XML original ' Crear "Sections" dentro de "Allarms" Set alarmsSectionsNode = xmlDoc.createElement("Sections") memberNode.appendChild alarmsSectionsNode ' Crear "Section" dentro de "Sections" de "Allarms" Set alarmsSectionNode = xmlDoc.createElement("Section") alarmsSectionNode.setAttribute "Name", "Member" alarmsSectionsNode.appendChild alarmsSectionNode ' Ahora añadiremos los miembros (campos) de cada alarma ' Primero, obtenemos los nombres de los miembros desde las columnas en Excel Dim columnNames As Collection Set columnNames = New Collection colOffset = primeraColumna Do While ws.Cells(primeraFila, colOffset).value <> "" columnNames.Add ws.Cells(primeraFila, colOffset).value colOffset = colOffset + 1 Loop ' Determinar el número de alarmas (filas) numAlarmas = ws.Cells(ws.Rows.Count, primeraColumna).End(xlUp).Row - (primeraFila + 1) + 1 ' Ahora, creamos los miembros dentro de "Allarms" Dim membersCollection As Collection Set membersCollection = New Collection ' Colección para almacenar los tipos de datos Dim memberDataTypes As Collection Set memberDataTypes = New Collection For i = 1 To columnNames.Count memberName = columnNames(i) ' Determinar el tipo de dato basado en el nombre de la columna o alguna otra lógica ' Aquí asumiremos que tienes una manera de determinar el tipo de dato ' Por simplicidad, asumiremos que todos son Bool excepto "Descripción" y "Section.X" If Left(memberName, 8) = "Section." Then memberDataType = "Bool" ElseIf memberName = "Descripción" Then memberDataType = "String" Else memberDataType = "Bool" End If ' Crear el miembro Set newMemberNode = xmlDoc.createElement("Member") newMemberNode.setAttribute "Name", memberName newMemberNode.setAttribute "Datatype", memberDataType alarmsSectionNode.appendChild newMemberNode ' Añadir a las colecciones membersCollection.Add newMemberNode memberDataTypes.Add memberDataType Next i ' Ahora, añadimos los subelementos (valores) para cada alarma For j = 1 To numAlarmas rowIndex = primeraFila + j ' Verificar si la fila está oculta If Not ws.Rows(rowIndex).Hidden Then For i = 1 To membersCollection.Count memberName = columnNames(i) Set newMemberNode = membersCollection(i) memberDataType = memberDataTypes(i) ' Crear el subelemento Set subElementNode = xmlDoc.createElement("Subelement") subElementNode.setAttribute "Path", CStr(j - 1) newMemberNode.appendChild subElementNode ' Leer el valor de la celda colIndex = primeraColumna + i - 1 cellValue = ws.Cells(rowIndex, colIndex).value ' Crear el nodo "StartValue" Set startValueNode = xmlDoc.createElement("StartValue") ' Manejar los diferentes tipos de datos If Left(memberName, 8) = "Section." Or memberDataType = "Bool" Then ' Convertir "X" a "TRUE", otros a "FALSE" If UCase(Trim(cellValue)) = "X" Then startValueNode.Text = "TRUE" Else startValueNode.Text = "FALSE" End If ElseIf memberDataType = "Byte" Then ' Convertir decimal a "16#xx" If IsNumeric(cellValue) Then decimalValue = CLng(cellValue) hexValue = Hex(decimalValue) If Len(hexValue) < 2 Then hexValue = "0" & hexValue End If startValueNode.Text = "16#" & hexValue Else startValueNode.Text = "16#00" End If Else ' Otros tipos de datos startValueNode.Text = CStr(cellValue) End If subElementNode.appendChild startValueNode ' Si es el campo "Descripción", agregar el nodo de comentario If memberName = "Descripción" Then Set commentNode = xmlDoc.createElement("Comment") Set multiLanguageTextNode = xmlDoc.createElement("MultiLanguageText") multiLanguageTextNode.setAttribute "Lang", "it-IT" ' Ajusta el idioma según sea necesario multiLanguageTextNode.Text = CStr(cellValue) commentNode.appendChild multiLanguageTextNode subElementNode.appendChild commentNode End If Next i End If Next j ' Guardar el archivo XML xmlDoc.Save filePath MsgBox "Archivo XML generado exitosamente." 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