Attribute VB_Name = "Funciones" ' dev Miguel Vera 2024 v0.3 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 As Long, primeraColumna As Long 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 Dim crearTitulos As Boolean Dim lastRow As Long Dim newRowIndex As Long Dim path As String primeraFila = 5 primeraColumna = 2 fechaBase = 2020 crearTitulos = False ' 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 GetTranslatedMessage("IMPORT_COMPLETE"), vbInformation 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 GetTranslatedMessage("IMPORT_COMPLETE"), vbInformation Exit Sub End If Set ws = ActiveSheet ' Mostrar todas las filas antes de comenzar la importación ws.Rows.Hidden = False ' Obtener la última fila con datos en la hoja lastRow = ws.Cells(ws.Rows.Count, primeraColumna).End(xlUp).row ' 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 "Alarms" Set alarmNode = xmlDoc.SelectSingleNode("//a:Member[@Name='Alarms']") ' Verificar si se encontró el nodo If alarmNode Is Nothing Then MsgBox GetTranslatedMessage("ALARM_NODE_NOT_FOUND"), vbExclamation Exit Sub End If ' Obtener los miembros del array "Alarms" Set alarmArray = alarmNode.SelectNodes("a:Sections/a:Section/a:Member") ' Nuevo: Declarar la tabla de alarmas ' Dim alarmTable As Object Set alarmTable = CreateObject("Scripting.Dictionary") ' Nuevo: Crear la tabla de alarmas CreateAlarmTable alarmNode, alarmTable, ws, primeraColumna ' 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 ' Deshabilitar actualizaciones y cálculos Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False ' Crear y mostrar el formulario de progreso Set progressForm = New progressForm progressForm.Show vbModeless ' 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 ' Actualizar el progreso cada 10 filas (puedes ajustar este número) If i Mod 10 = 0 Then progressForm.UpdateProgress CInt(i), alarmArray.Length DoEvents End If 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 If crearTitulos Then ' 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 End If ' Escribir los valores en las celdas correspondientes For Each subElement In subElements path = subElement.Attributes.getNamedItem("Path").Text pathParts = Split(path, ",") ' Usar la tabla de alarmas para determinar rowIndex If alarmTable.Exists(CStr(CInt(pathParts(0)))) Then rowIndex = alarmTable(CStr(CInt(pathParts(0))))("searchRowIndex") If rowIndex >= 0 Then ' Sólo procesar si rowIndex es positivo If rowIndex = 0 Then ' Si no se encontró en la hoja, agregar una nueva fila al final lastRow = lastRow + 1 rowIndex = lastRow ws.Cells(rowIndex, primeraColumna).value = CInt(pathParts(0)) alarmTable(CStr(CInt(pathParts(0))))("searchRowIndex") = rowIndex End If ' 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 = ImportBool(startValue) End If End If Next subElement ' Actualizar el desplazamiento de columna colOffset = colOffset + maxSectionIndex Else ' Procesar otros miembros usando la tabla de alarmas Set subElements = alarmArray.item(i).SelectNodes("a:Subelement") For j = 0 To subElements.Length - 1 path = subElements.item(j).Attributes.getNamedItem("Path").Text ' Usar la tabla de alarmas para determinar rowIndex If alarmTable.Exists(path) Then rowIndex = alarmTable(path)("searchRowIndex") If rowIndex >= 0 Then ' Sólo procesar si rowIndex es positivo If rowIndex = 0 Then ' Si no se encontró en la hoja, agregar una nueva fila al final lastRow = lastRow + 1 rowIndex = lastRow ws.Cells(rowIndex, primeraColumna).value = alarmTable(path)("AlarmNumStartValue") alarmTable(path)("searchRowIndex") = rowIndex End If ' Obtener "StartValue" startValue = subElements.item(j).SelectSingleNode("a:StartValue").Text ' Escribir el valor en la celda correspondiente If InStr(memberDataType, "Bool") > 0 Then ws.Cells(rowIndex, colOffset).value = ImportBool(startValue) ElseIf InStr(memberDataType, "Byte") > 0 Then ws.Cells(rowIndex, colOffset).value = ImportByte(startValue) Else ws.Cells(rowIndex, colOffset).value = startValue End If End If End If Next j ' Actualizar el desplazamiento de columna colOffset = colOffset + 1 End If Next i If crearTitulos Then ' Añadir la columna para las descripciones ws.Cells(primeraFila, colOffset).value = "Descripción" End If ' Obtener los subelementos directamente bajo "Alarms" 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 subElements.Length - 1 path = subElements.item(j).Attributes.getNamedItem("Path").Text ' Actualizar el progreso cada 10 filas (puedes ajustar este número) If i Mod 10 = 0 Then progressForm.UpdateProgress CInt(j), subElements.Length - 1 DoEvents End If ' Usar la tabla de alarmas para determinar rowIndex If alarmTable.Exists(path) Then rowIndex = alarmTable(path)("searchRowIndex") If rowIndex >= 0 Then ' Sólo procesar si rowIndex es 0 o positivo ' 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(rowIndex, colOffset).value = description End If End If Next j ' Ordenar las filas basándose en la columna primeraColumna Dim rng As Range Set rng = ws.Range(ws.Cells(primeraFila + 1, 1), ws.Cells(lastRow, ws.UsedRange.Columns.Count)) rng.Sort Key1:=ws.Cells(primeraFila + 1, primeraColumna), Order1:=xlAscending, Header:=xlNo ' Ocultar las filas que no están en alarmTable Dim row As Long Dim alarmNumCol As Long Dim alarmNum As String Dim visibleRows As New Collection ' Encontrar la columna del AlarmNum (que debería ser primeraColumna) alarmNumCol = primeraColumna ' Crear una colección de filas visibles basada en alarmTable Dim key As Variant For Each key In alarmTable.Keys If alarmTable(key)("searchRowIndex") <> 0 Then On Error Resume Next visibleRows.Add alarmTable(key)("searchRowIndex"), CStr(alarmTable(key)("searchRowIndex")) On Error GoTo 0 End If Next key ' Ocultar filas que no están en la colección de filas visibles For row = primeraFila + 1 To lastRow alarmNum = CStr(ws.Cells(row, alarmNumCol).value) On Error Resume Next If IsEmpty(visibleRows(CStr(row))) Then ws.Rows(row).Hidden = True End If On Error GoTo 0 Next row ' Cerrar el formulario de progreso Unload progressForm ' Restaurar configuraciones Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True MsgBox GetTranslatedMessage("IMPORT_COMPLETE"), vbInformation End Sub Sub CreateAlarmTable(alarmNode As Object, alarmTable As Object, ws As Worksheet, primeraColumna As Long) Dim alarmNumNode As Object Dim subElements As Object Dim subElement As Object Dim startValue As String Dim path As String Dim searchRowIndex As Long ' Encontrar el nodo AlarmNum Set alarmNumNode = alarmNode.SelectSingleNode("a:Sections/a:Section/a:Member[@Name='AlarmNum']") If Not alarmNumNode Is Nothing Then Set subElements = alarmNumNode.SelectNodes("a:Subelement") For Each subElement In subElements startValue = subElement.SelectSingleNode("a:StartValue").Text path = subElement.Attributes.getNamedItem("Path").Text ' Asignar -1 si StartValue es 0, de lo contrario buscar el índice de fila If startValue = "0" Then searchRowIndex = -1 Else searchRowIndex = FindRowIndex(ws, primeraColumna, startValue) End If ' Agregar a la tabla de alarmas alarmTable.Add path, CreateObject("Scripting.Dictionary") alarmTable(path).Add "AlarmNumStartValue", startValue alarmTable(path).Add "AlarmNumPath", path alarmTable(path).Add "searchRowIndex", searchRowIndex Next subElement Else MsgBox "No se encontró el nodo AlarmNum." End If End Sub Function FindRowIndex(ws As Worksheet, column As Long, value As String) As Long Dim lastRow As Long Dim i As Long lastRow = ws.Cells(ws.Rows.Count, column).End(xlUp).row For i = 1 To lastRow If CStr(ws.Cells(i, column).value) = value Then FindRowIndex = i Exit Function End If Next i ' Si no se encuentra, devolver 0 FindRowIndex = 0 End Function ' Y añade esta función en tu módulo de VBA: Function FindColumnIndex(ws As Worksheet, columnName As String, headerRow As Long, startColumn As Long) As Long Dim col As Integer Dim lastColumn As Integer lastColumn = ws.Cells(headerRow, ws.Columns.Count).End(xlToLeft).column For col = startColumn To lastColumn If ws.Cells(headerRow, col).value = columnName Then FindColumnIndex = col Exit Function End If Next col ' Si no se encuentra la columna, devolver 0 o manejar el error como prefieras FindColumnIndex = 0 End Function Function FindRowByAlarmNum(ws As Worksheet, alarmNum As Integer, primeraFila As Integer, primeraColumna As Integer) As Integer Dim lastRow As Integer Dim i As Integer lastRow = ws.Cells(ws.Rows.Count, primeraColumna).End(xlUp).row For i = primeraFila + 1 To lastRow If ws.Cells(i, primeraColumna).value = alarmNum Then FindRowByAlarmNum = i Exit Function End If Next i FindRowByAlarmNum = 0 ' No se encontró la fila End Function Function ImportBool(startValue As String) As String ImportBool = IIf(UCase(startValue) = "TRUE", "X", "") End Function Function ImportByte(startValue As String) As String If Left(startValue, 3) = "16#" Then ImportByte = CInt("&H" & Mid(startValue, 4)) Else ImportByte = startValue End If End Function Sub ExportSiemensXML() Dim xmlDoc As Object Dim xmlNode As Object Dim alarmsMemberNode As Object Dim i As Long, j As Long Dim ws As Worksheet Dim filePath As String Dim primeraFila As Integer, primeraColumna As Integer Dim rowIndex As Variant Dim colIndex As Integer Dim memberName As String Dim memberDataType As String Dim cellValue As Variant Dim startValueNode As Object Dim creationDate As Date Dim currentDate As Date Dim fso As Object Dim file As Object Dim fechaBase As Integer Dim numAlarmas As Integer Dim sectionsNode As Object Dim sectionNode As Object Dim memberNode As Object Dim subElementNode As Object Dim visibleRows As New Collection Dim uniqueValues As Object Set uniqueValues = CreateObject("Scripting.Dictionary") Dim duplicateFound As Boolean Dim duplicateValue As Variant Dim duplicateRow As Long 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 GetTranslatedMessage("EXPORT_COMPLETE"), vbInformation 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 GetTranslatedMessage("EXPORT_COMPLETE"), vbInformation Exit Sub End If Set ws = ActiveSheet ' Verificar valores únicos en la columna primeraColumna lastRow = ws.Cells(ws.Rows.Count, primeraColumna).End(xlUp).row duplicateFound = False For rowIndex = primeraFila + 1 To lastRow If Not ws.Rows(rowIndex).Hidden Then cellValue = ws.Cells(rowIndex, primeraColumna).value If Not IsEmpty(cellValue) Then If uniqueValues.Exists(CStr(cellValue)) Then duplicateFound = True duplicateValue = cellValue duplicateRow = rowIndex Exit For Else uniqueValues.Add CStr(cellValue), rowIndex End If End If End If Next rowIndex If duplicateFound Then MsgBox Replace(Replace(GetTranslatedMessage("DUPLICATE_VALUE"), "{0}", duplicateValue), "{1}", duplicateRow), vbExclamation Exit Sub End If ' Calcular el número de alarmas considerando solo las filas visibles numAlarmas = 0 For rowIndex = primeraFila + 1 To lastRow If Not ws.Rows(rowIndex).Hidden Then numAlarmas = numAlarmas + 1 visibleRows.Add rowIndex End If Next rowIndex ' 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 "Member" con Name="Alarms" Set alarmsMemberNode = xmlDoc.SelectSingleNode("//a:Member[@Name='Alarms']") ' Verificar si se encontró el nodo If alarmsMemberNode Is Nothing Then MsgBox GetTranslatedMessage("MEMBER_NODE_NOT_FOUND"), vbExclamation Exit Sub End If ' Actualizar el tamaño del array en el XML ' Obtener el valor actual del atributo Datatype Dim datatypeText As String datatypeText = alarmsMemberNode.Attributes.getNamedItem("Datatype").Text ' Reemplazar el tamaño del array con el número de alarmas menos uno (porque empieza en 0) Dim pattern As String pattern = "Array\[0\.\.\d+\]" Dim replacement As String replacement = "Array[0.." & (numAlarmas - 1) & "]" Dim regex As Object Set regex = CreateObject("VBScript.RegExp") regex.pattern = pattern regex.Global = True regex.IgnoreCase = False datatypeText = regex.Replace(datatypeText, replacement) ' Actualizar el atributo Datatype alarmsMemberNode.Attributes.getNamedItem("Datatype").Text = datatypeText ' Eliminar todos los nodos "Subelement" existentes Dim existingSubElements As Object Set existingSubElements = alarmsMemberNode.SelectNodes(".//a:Subelement") For i = existingSubElements.Length - 1 To 0 Step -1 existingSubElements.item(i).ParentNode.RemoveChild existingSubElements.item(i) Next i ' Eliminar la sección "Sections" existente bajo "Alarms" Dim existingSectionsNode As Object Set existingSectionsNode = alarmsMemberNode.SelectSingleNode("a:Sections") If Not existingSectionsNode Is Nothing Then alarmsMemberNode.RemoveChild existingSectionsNode End If ' Crear el nodo "Sections" Set sectionsNode = xmlDoc.createNode(1, "Sections", "http://www.siemens.com/automation/Openness/SW/Interface/v5") alarmsMemberNode.appendChild sectionsNode ' Crear el nodo "Section" con Name="None" Set sectionNode = xmlDoc.createNode(1, "Section", "http://www.siemens.com/automation/Openness/SW/Interface/v5") sectionNode.Attributes.setNamedItem(xmlDoc.createAttribute("Name")).Text = "None" sectionsNode.appendChild sectionNode ' Definir los miembros y sus tipos de datos Dim members As Variant members = Array("AlarmNum", "DB", "Byte", "Bit", "Priority", "Section", "Value", "Disable", "Is Warning", "Ons") Dim memberCol As Variant memberCol = Array(0, 1, 2, 3, 4, 5, 10, 11, 12, 13) Dim dataTypes As Variant dataTypes = Array("Int", "Int", "Int", "Byte", "Byte", "Array[1..""Numero_Sezioni""] of Bool", "Bool", "Bool", "Bool", "Bool") ' Crear y mostrar el formulario de progreso Set progressForm = New progressForm progressForm.Show vbModeless ' Crear los miembros For i = 0 To UBound(members) Set memberNode = xmlDoc.createNode(1, "Member", "http://www.siemens.com/automation/Openness/SW/Interface/v5") memberNode.Attributes.setNamedItem(xmlDoc.createAttribute("Name")).Text = members(i) memberNode.Attributes.setNamedItem(xmlDoc.createAttribute("Datatype")).Text = dataTypes(i) sectionNode.appendChild memberNode ' Actualizar el progreso cada 10 filas (puedes ajustar este número) progressForm.UpdateProgress CInt(i), UBound(members) ' Para cada miembro, crear los subelementos basados en los datos de Excel If members(i) = "Section" Then ' Manejar el caso especial de "Section" Dim visibleRowIndex As Integer visibleRowIndex = 0 For Each rowIndex In visibleRows For j = 1 To 5 ' Asumimos 5 secciones Set subElementNode = xmlDoc.createNode(1, "Subelement", "http://www.siemens.com/automation/Openness/SW/Interface/v5") subElementNode.Attributes.setNamedItem(xmlDoc.createAttribute("Path")).Text = visibleRowIndex & "," & j Set startValueNode = xmlDoc.createNode(1, "StartValue", "http://www.siemens.com/automation/Openness/SW/Interface/v5") cellValue = ws.Cells(rowIndex, primeraColumna + memberCol(i) + j - 1).value startValueNode.Text = ExportBool(Trim(cellValue)) subElementNode.appendChild startValueNode memberNode.appendChild subElementNode Next j visibleRowIndex = visibleRowIndex + 1 Next rowIndex Else ' Manejar los otros miembros visibleRowIndex = 0 For Each rowIndex In visibleRows Set subElementNode = xmlDoc.createNode(1, "Subelement", "http://www.siemens.com/automation/Openness/SW/Interface/v5") subElementNode.Attributes.setNamedItem(xmlDoc.createAttribute("Path")).Text = CStr(visibleRowIndex) Set startValueNode = xmlDoc.createNode(1, "StartValue", "http://www.siemens.com/automation/Openness/SW/Interface/v5") cellValue = ws.Cells(rowIndex, primeraColumna + memberCol(i)).value Select Case dataTypes(i) Case "Bool" startValueNode.Text = ExportBool(Trim(cellValue)) Case "Byte" startValueNode.Text = ExportByte(cellValue) Case "Int" startValueNode.Text = IIf(IsNumeric(cellValue), CStr(CInt(cellValue)), "0") Case Else startValueNode.Text = CStr(cellValue) End Select subElementNode.appendChild startValueNode memberNode.appendChild subElementNode visibleRowIndex = visibleRowIndex + 1 Next rowIndex End If Next i ' Añadir los comentarios Dim commentColumn As Integer commentColumn = primeraColumna + 14 visibleRowIndex = 0 For Each rowIndex In visibleRows Set subElementNode = xmlDoc.createNode(1, "Subelement", "http://www.siemens.com/automation/Openness/SW/Interface/v5") subElementNode.Attributes.setNamedItem(xmlDoc.createAttribute("Path")).Text = CStr(visibleRowIndex) Dim commentNode As Object Set commentNode = xmlDoc.createNode(1, "Comment", "http://www.siemens.com/automation/Openness/SW/Interface/v5") Dim multiLangTextNode As Object Set multiLangTextNode = xmlDoc.createNode(1, "MultiLanguageText", "http://www.siemens.com/automation/Openness/SW/Interface/v5") multiLangTextNode.Attributes.setNamedItem(xmlDoc.createAttribute("Lang")).Text = "it-IT" multiLangTextNode.Text = ws.Cells(rowIndex, commentColumn).value commentNode.appendChild multiLangTextNode subElementNode.appendChild commentNode alarmsMemberNode.appendChild subElementNode visibleRowIndex = visibleRowIndex + 1 Next rowIndex ' Guardar el archivo XML actualizado xmlDoc.Save filePath ' Cerrar el formulario de progreso Unload progressForm MsgBox GetTranslatedMessage("EXPORT_COMPLETE"), vbInformation 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 ExportBool(excelValue) ' Escribir "X" o dejar vacío según el valor booleano ExportBool = "FALSE" If UCase(excelValue) = "X" Or UCase(excelValue) = "TRUE" Or UCase(excelValue) = "1" Then ExportBool = "TRUE" End If End Function Function ExportByte(cellValue) ' 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 Sub MarcarFilasOcultas() Dim i As Long Dim columnaMarcar As Long Dim primeraColumna As Long Dim primeraFila As Long primeraColumna = 2 primeraFila = 5 + 1 columnaMarcar = 17 Set ws = ActiveSheet ' Verificar valores únicos en la columna primeraColumna ultimaFila = ws.Cells(ws.Rows.Count, primeraColumna).End(xlUp).row For i = primeraFila To ultimaFila If ws.Rows(i).Hidden Then ws.Cells(i, columnaMarcar).value = "X" Else ws.Cells(i, columnaMarcar).value = "" End If Next i End Sub Sub OcultarFilasSegunMarca() Dim i As Long Dim columnaMarcar As Long Dim primeraColumna As Long Dim primeraFila As Long Dim ultimaFila As Long Dim ws As Worksheet Dim progressForm As progressForm primeraColumna = 2 primeraFila = 5 columnaMarcar = 17 ' Deshabilitar actualizaciones y cálculos Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set ws = ActiveSheet ' Mostrar todas las filas antes de comenzar la importación ws.Rows.Hidden = False ' Verificar valores únicos en la columna primeraColumna ultimaFila = ws.Cells(ws.Rows.Count, primeraColumna).End(xlUp).row ' Crear y mostrar el formulario de progreso Set progressForm = New progressForm progressForm.Show vbModeless For i = primeraFila To ultimaFila If UCase(ws.Cells(i, columnaMarcar).value) = "X" Then ws.Rows(i).Hidden = True End If ' Actualizar el progreso cada 10 filas (puedes ajustar este número) If i Mod 10 = 0 Then progressForm.UpdateProgress i - primeraFila + 1, ultimaFila - primeraFila + 1 DoEvents End If Next i ' Cerrar el formulario de progreso Unload progressForm ' Restaurar configuraciones Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True MsgBox Replace(GetTranslatedMessage("ROWS_HIDDEN"), "{0}", CStr(ultimaFila - primeraFila + 1)), vbInformation End Sub Sub MostrarTodasLasFilas() Set ws = ActiveSheet ' Mostrar todas las filas antes de comenzar la importación ws.Rows.Hidden = False End Sub Sub Exportar_A_SIPA() Dim ws As Worksheet Dim wsSIPA As Worksheet Dim primeraFila As Integer, primeraColumna As Integer Dim rowIndex As Variant Dim cellValue As Variant Dim lastRow As Long Dim numAlarmas As Integer Dim visibleRows As New Collection Dim uniqueValues As Object Dim duplicateFound As Boolean Dim duplicateValue As Variant Dim duplicateRow As Long Dim wsDict As Object Dim wsSIPADict As Object Dim key As Variant Dim sipaRow As Long Dim db As Long, xbyte As Long, bit As Long Dim lastSipaRow As Long sipaRow = 2 primeraFila = 5 primeraColumna = 2 Set ws = ActiveSheet ' Verificar si la hoja "Per Supervisore SIPA" existe On Error Resume Next Set wsSIPA = ThisWorkbook.Worksheets("Per Supervisore SIPA") On Error GoTo 0 If wsSIPA Is Nothing Then MsgBox GetTranslatedMessage("SIPA_SHEET_NOT_FOUND"), vbExclamation Exit Sub End If Set uniqueValues = CreateObject("Scripting.Dictionary") ' Crear y llenar el diccionario para ws Set wsDict = CreateDict("AlarmNum", 0, "DB", 1, "Byte", 2, "Bit", 3, "Priority", 4, _ "Section.1", 5, "Section.2", 6, "Section.3", 7, "Section.4", 8, _ "Section.5", 9, "Disable", 11, "Is Warning", 12, "Descripción", 14, "Hidden", 15) ' Crear y llenar el diccionario para wsSIPA Set wsSIPADict = CreateDict("Alarm-Warning", 0, "Number", 1, "Tag", 2, "Sections", 3, _ "Priority", 4, "Description", 5, "Used", 6) ' Verificar valores únicos en la columna primeraColumna lastRow = ws.Cells(ws.Rows.Count, primeraColumna).End(xlUp).row duplicateFound = False For rowIndex = primeraFila + 1 To lastRow If Not ws.Rows(rowIndex).Hidden Then cellValue = ws.Cells(rowIndex, primeraColumna).value If Not IsEmpty(cellValue) Then If uniqueValues.Exists(CStr(cellValue)) Then duplicateFound = True duplicateValue = cellValue duplicateRow = rowIndex Exit For Else uniqueValues.Add CStr(cellValue), rowIndex End If End If End If Next rowIndex If duplicateFound Then MsgBox Replace(Replace(GetTranslatedMessage("DUPLICATE_VALUE"), "{0}", duplicateValue), "{1}", duplicateRow), vbExclamation Exit Sub End If ' Calcular el número de alarmas considerando solo las filas visibles numAlarmas = 0 For rowIndex = primeraFila + 1 To lastRow If Not ws.Rows(rowIndex).Hidden Then numAlarmas = numAlarmas + 1 visibleRows.Add rowIndex End If Next rowIndex ' Eliminar filas existentes en wsSIPA desde sipaRow lastSipaRow = wsSIPA.Cells(wsSIPA.Rows.Count, 1).End(xlUp).row If lastSipaRow >= sipaRow Then wsSIPA.Rows(sipaRow & ":" & lastSipaRow).Delete End If For Each rowIndex In visibleRows For Each key In wsSIPADict.Keys Select Case key Case "Alarm-Warning" If UCase(ws.Cells(rowIndex, wsDict("Is Warning") + primeraColumna).value) = "X" Then wsSIPA.Cells(sipaRow, wsSIPADict(key) + 1).value = "Warning" wsSIPA.Cells(sipaRow, wsSIPADict(key) + 1).Font.Color = RGB(0, 32, 240) ' Celeste Else wsSIPA.Cells(sipaRow, wsSIPADict(key) + 1).value = "Alarm" wsSIPA.Cells(sipaRow, wsSIPADict(key) + 1).Font.Color = RGB(255, 0, 0) ' Rojo End If Case "Number" wsSIPA.Cells(sipaRow, wsSIPADict(key) + 1).value = ws.Cells(rowIndex, wsDict("AlarmNum") + primeraColumna).value Case "Tag" wsSIPA.Cells(sipaRow, wsSIPADict(key) + 1).value = "DB" & ws.Cells(rowIndex, wsDict("DB") + primeraColumna).value & _ ".DBX" & ws.Cells(rowIndex, wsDict("Byte") + primeraColumna).value & _ "." & ws.Cells(rowIndex, wsDict("Bit") + primeraColumna).value Case "Sections" Dim sectionList As String Dim sectionNum As Integer sectionList = "" For sectionNum = 1 To 5 If UCase(ws.Cells(rowIndex, wsDict("Section." & sectionNum) + primeraColumna).value) = "X" Then If sectionList <> "" Then sectionList = sectionList & "," End If sectionList = sectionList & sectionNum End If Next sectionNum wsSIPA.Cells(sipaRow, wsSIPADict(key) + 1).value = sectionList Case "Priority" wsSIPA.Cells(sipaRow, wsSIPADict(key) + 1).value = ws.Cells(rowIndex, wsDict("Priority") + primeraColumna).value Case "Description" wsSIPA.Cells(sipaRow, wsSIPADict(key) + 1).value = ws.Cells(rowIndex, wsDict("Descripción") + primeraColumna).value Case "Used" If UCase(ws.Cells(rowIndex, wsDict("Disable") + primeraColumna).value) <> "X" Then wsSIPA.Cells(sipaRow, wsSIPADict(key) + 1).value = ChrW(9679) Else wsSIPA.Cells(sipaRow, wsSIPADict(key) + 1).value = "-" End If End Select Next key sipaRow = sipaRow + 1 Next rowIndex ' Pedir al usuario un nombre de archivo para guardar Dim newFilePath As String newFilePath = Application.GetSaveAsFilename(InitialFileName:="Mappa Allarmi Completa Supervisore", _ FileFilter:="Excel Files (*.xlsx), *.xlsx", _ Title:="Guardar hoja SIPA como") ' Verificar si el usuario canceló la operación If newFilePath <> "False" Then ' Crear un nuevo libro de Excel Dim newWorkbook As Workbook Set newWorkbook = Application.Workbooks.Add ' Copiar la hoja wsSIPA al nuevo libro wsSIPA.Copy Before:=newWorkbook.Sheets(1) ' Eliminar la hoja en blanco que se crea por defecto Application.DisplayAlerts = False newWorkbook.Sheets(2).Delete Application.DisplayAlerts = True ' Guardar el nuevo libro newWorkbook.SaveAs Filename:=newFilePath newWorkbook.Close SaveChanges:=True MsgBox Replace(GetTranslatedMessage("SIPA_EXPORT_SAVED"), "{0}", newFilePath), vbInformation Else MsgBox GetTranslatedMessage("SIPA_EXPORT_NOT_SAVED"), vbInformation End If ' Activar la hoja wsSIPA 'wsSIPA.Activate MsgBox GetTranslatedMessage("SIPA_EXPORT_COMPLETE"), vbInformation End Sub Function GetDictValue(dict As Object, key As Variant) As Variant If VarType(key) = vbString Then ' Si la clave es una cadena, acceder directamente GetDictValue = dict(key) ElseIf IsNumeric(key) Then ' Si la clave es un número, buscar la clave correspondiente If dict.Exists(key) Then GetDictValue = dict(dict(key)) Else GetDictValue = "Índice no válido" End If Else GetDictValue = "Tipo de clave no válido" End If End Function Function CreateDict(ParamArray items()) As Object Dim dict As Object Dim i As Long Set dict = CreateObject("Scripting.Dictionary") For i = 0 To UBound(items) Step 2 If i + 1 <= UBound(items) Then dict(items(i)) = items(i + 1) End If Next i Set CreateDict = dict End Function Function GetDB(texto As String) As Long Dim partes As Variant partes = Split(texto, "/") If UBound(partes) >= 0 Then GetDB = CLng(partes(0)) Else GetDB = -1 ' Retorna -1 si no se encuentra el DB End If End Function Function GetByte(texto As String) As Long Dim partes As Variant partes = Split(texto, "/") If UBound(partes) >= 1 Then GetByte = CLng(partes(1)) Else GetByte = -1 ' Retorna -1 si no se encuentra el Byte End If End Function Function GetBit(texto As String) As Long Dim partes As Variant partes = Split(texto, "/") If UBound(partes) >= 2 Then ' Extraer el número del bit (puede estar seguido por espacio y más texto) Dim bitPart As String bitPart = Split(partes(2), " ")(0) GetBit = CLng(bitPart) Else GetBit = -1 ' Retorna -1 si no se encuentra el Bit End If End Function ' Función para obtener el idioma actual de Excel Function GetExcelLanguage() As String Select Case Application.LanguageSettings.LanguageID(msoLanguageIDUI) Case 1034 GetExcelLanguage = "ES" ' Español Case 1040 GetExcelLanguage = "IT" ' Italiano Case Else GetExcelLanguage = "EN" ' Inglés (por defecto) End Select End Function ' Función para obtener mensajes traducidos Function GetTranslatedMessage(msgKey As String) As String Dim messages As Object Set messages = CreateObject("Scripting.Dictionary") ' Mensajes en inglés (por defecto) messages("EN") = CreateObject("Scripting.Dictionary") messages("EN")("IMPORT_COMPLETE") = "Import completed." messages("EN")("EXPORT_COMPLETE") = "Export completed." messages("EN")("FILE_NOT_SELECTED") = "No file was selected. Operation cancelled." messages("EN")("DUPLICATE_VALUE") = "A duplicate value was found: {0} in row {1}. The operation has been aborted." messages("EN")("ALARM_NODE_NOT_FOUND") = "The 'Alarms' node was not found in the XML file." messages("EN")("MEMBER_NODE_NOT_FOUND") = "The 'Member' node with Name='Alarms' was not found in the XML file." messages("EN")("ROWS_HIDDEN") = "Process completed. Rows hidden: {0}" messages("EN")("ALL_ROWS_SHOWN") = "All rows are now visible." messages("EN")("SIPA_SHEET_NOT_FOUND") = "The 'Per Supervisore SIPA' sheet does not exist in this workbook. Please create this sheet before continuing." messages("EN")("SIPA_EXPORT_COMPLETE") = "SIPA export completed." messages("EN")("SIPA_EXPORT_SAVED") = "SIPA export completed and saved in {0}" messages("EN")("SIPA_EXPORT_NOT_SAVED") = "SIPA export completed. Not saved in a separate file." ' Mensajes en español messages("ES") = CreateObject("Scripting.Dictionary") messages("ES")("IMPORT_COMPLETE") = "Importación completada." messages("ES")("EXPORT_COMPLETE") = "Exportación completada." messages("ES")("FILE_NOT_SELECTED") = "No se seleccionó ningún archivo. Operación cancelada." messages("ES")("DUPLICATE_VALUE") = "Se encontró un valor duplicado: {0} en la fila {1}. La operación ha sido abortada." messages("ES")("ALARM_NODE_NOT_FOUND") = "No se encontró el nodo 'Alarms' en el archivo XML." messages("ES")("MEMBER_NODE_NOT_FOUND") = "No se encontró el nodo 'Member' con Name='Alarms' en el archivo XML." messages("ES")("ROWS_HIDDEN") = "Proceso completado. Filas ocultadas: {0}" messages("ES")("ALL_ROWS_SHOWN") = "Todas las filas son ahora visibles." messages("ES")("SIPA_SHEET_NOT_FOUND") = "La hoja 'Per Supervisore SIPA' no existe en este libro. Por favor, cree esta hoja antes de continuar." messages("ES")("SIPA_EXPORT_COMPLETE") = "Exportación a SIPA completada." messages("ES")("SIPA_EXPORT_SAVED") = "Exportación a SIPA completada y guardada en {0}" messages("ES")("SIPA_EXPORT_NOT_SAVED") = "Exportación a SIPA completada. No se ha guardado en un archivo separado." ' Mensajes en italiano messages("IT") = CreateObject("Scripting.Dictionary") messages("IT")("IMPORT_COMPLETE") = "Importazione completata." messages("IT")("EXPORT_COMPLETE") = "Esportazione completata." messages("IT")("FILE_NOT_SELECTED") = "Nessun file selezionato. Operazione annullata." messages("IT")("DUPLICATE_VALUE") = "È stato trovato un valore duplicato: {0} nella riga {1}. L'operazione è stata interrotta." messages("IT")("ALARM_NODE_NOT_FOUND") = "Il nodo 'Alarms' non è stato trovato nel file XML." messages("IT")("MEMBER_NODE_NOT_FOUND") = "Il nodo 'Member' con Name='Alarms' non è stato trovato nel file XML." messages("IT")("ROWS_HIDDEN") = "Processo completato. Righe nascoste: {0}" messages("IT")("ALL_ROWS_SHOWN") = "Tutte le righe sono ora visibili." messages("IT")("SIPA_SHEET_NOT_FOUND") = "Il foglio 'Per Supervisore SIPA' non esiste in questa cartella di lavoro. Si prega di creare questo foglio prima di continuare." messages("IT")("SIPA_EXPORT_COMPLETE") = "Esportazione SIPA completata." messages("IT")("SIPA_EXPORT_SAVED") = "Esportazione SIPA completata e salvata in {0}" messages("IT")("SIPA_EXPORT_NOT_SAVED") = "Esportazione SIPA completata. Non salvata in un file separato." Dim lang As String lang = GetExcelLanguage() If messages(lang).Exists(msgKey) Then GetTranslatedMessage = messages(lang)(msgKey) Else GetTranslatedMessage = messages("EN")(msgKey) ' Fallback to English End If End Function