45 KiB
45 KiB
' dev Miguel Vera 2024 v0.5
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<6F> 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<63>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<63>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<63>n
ws.Rows.Hidden = False
' Obtener la <20>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<74> 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<65>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<74> 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 <20>ndice de columna
sectionIndex = CInt(pathParts(1))
colIndex = colOffset + sectionIndex - 1
' Obtener "StartValue"
startValue = subElement.SelectSingleNode("a:StartValue").Text
' Escribir "X" o dejar vac<61>o seg<65>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<74> 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<63>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 <20>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<63>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<63>n en la celda correspondiente
ws.Cells(rowIndex, colOffset).value = description
End If
End If
Next j
' Ordenar las filas bas<61>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<73>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<65>a ser primeraColumna)
alarmNumCol = primeraColumna
' Crear una colecci<63>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<73>n en la colecci<63>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 <20>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<74> 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<63>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<74> 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<6F> 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<63>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<63>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 <20>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<74> el nodo
If alarmsMemberNode Is Nothing Then
MsgBox GetTranslatedMessage("MEMBER_NODE_NOT_FOUND"), vbExclamation
Exit Sub
End If
' Actualizar el tama<6D>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<6D>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<63>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<63>n para verificar si un elemento existe en una colecci<63>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<63>n para obtener el <20>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<61>o seg<65>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<75>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 <20>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<63>n
ws.Rows.Hidden = False
' Verificar valores <20>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<63>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<63>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 <20>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<63>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<65> la operaci<63>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 = "<22>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
Function GetExcelLanguage() As String
Dim langID As Long
langID = Application.LanguageSettings.LanguageID(msoLanguageIDUI)
Select Case langID
' Espa<70>ol (varias variantes)
Case 3082, 1034, 11274, 16394, 13322, 9226, 5130, 7178, 12298, 17418, 4106, 18442, 19466, 6154, 15370, 10250, 20490, 21514, 14346, 8202
GetExcelLanguage = "ES"
' Italiano
Case 1040, 2064
GetExcelLanguage = "IT"
' Ingl<67>s (varias variantes)
Case 1033, 2057, 3081, 4105, 5129, 6153, 7177, 8201, 9225, 10249, 11273, 12297, 13321, 14345, 15369, 16393, 17417, 18441, 19465, 20489
GetExcelLanguage = "EN"
' Franc<6E>s
Case 1036, 2060, 3084, 4108, 5132, 6156, 7180, 8204, 9228, 10252, 11276, 12300, 13324, 14348, 15372, 16396, 20484
GetExcelLanguage = "FR"
' Alem<65>n
Case 1031, 2055, 3079, 4103, 5127
GetExcelLanguage = "DE"
' Portugu<67>s
Case 2070, 1046
GetExcelLanguage = "PT"
' Otros idiomas pueden ser a<>adidos aqu<71>
Case Else
' Si no se reconoce el idioma, se usa ingl<67>s por defecto
GetExcelLanguage = "EN"
End Select
' Para depuraci<63>n: imprimir el c<>digo de idioma detectado
Debug.Print "Detected Language ID: " & langID & ", Mapped to: " & GetExcelLanguage
End Function
' Funci<63>n para obtener mensajes traducidos
Function GetTranslatedMessage(msgKey As String) As String
Dim messages As Object
Dim langDict As Object
Set messages = CreateObject("Scripting.Dictionary")
' Mensajes en ingl<67>s (por defecto)
Set langDict = CreateObject("Scripting.Dictionary")
langDict.Add "IMPORT_COMPLETE", "Import completed."
langDict.Add "EXPORT_COMPLETE", "Export completed."
langDict.Add "FILE_NOT_SELECTED", "No file was selected. Operation cancelled."
langDict.Add "DUPLICATE_VALUE", "A duplicate value was found: {0} in row {1}. The operation has been aborted."
langDict.Add "ALARM_NODE_NOT_FOUND", "The 'Alarms' node was not found in the XML file."
langDict.Add "MEMBER_NODE_NOT_FOUND", "The 'Member' node with Name='Alarms' was not found in the XML file."
langDict.Add "ROWS_HIDDEN", "Process completed. Rows hidden: {0}"
langDict.Add "ALL_ROWS_SHOWN", "All rows are now visible."
langDict.Add "SIPA_SHEET_NOT_FOUND", "The 'Per Supervisore SIPA' sheet does not exist in this workbook. Please create this sheet before continuing."
langDict.Add "SIPA_EXPORT_COMPLETE", "SIPA export completed."
langDict.Add "SIPA_EXPORT_SAVED", "SIPA export completed and saved in {0}"
langDict.Add "SIPA_EXPORT_NOT_SAVED", "SIPA export completed. Not saved in a separate file."
messages.Add "EN", langDict
' Mensajes en español
Set langDict = CreateObject("Scripting.Dictionary")
langDict.Add "IMPORT_COMPLETE", "Importación completada."
langDict.Add "EXPORT_COMPLETE", "Exportación completada."
langDict.Add "FILE_NOT_SELECTED", "No se seleccionó ningún archivo. Operación cancelada."
langDict.Add "DUPLICATE_VALUE", "Se encontró un valor duplicado: {0} en la fila {1}. La operación ha sido abortada."
langDict.Add "ALARM_NODE_NOT_FOUND", "No se encontró el nodo 'Alarms' en el archivo XML."
langDict.Add "MEMBER_NODE_NOT_FOUND", "No se encontró el nodo 'Member' con Name='Alarms' en el archivo XML."
langDict.Add "ROWS_HIDDEN", "Proceso completado. Filas ocultadas: {0}"
langDict.Add "ALL_ROWS_SHOWN", "Todas las filas son ahora visibles."
langDict.Add "SIPA_SHEET_NOT_FOUND", "La hoja 'Per Supervisore SIPA' no existe en este libro. Por favor, cree esta hoja antes de continuar."
langDict.Add "SIPA_EXPORT_COMPLETE", "Exportación a SIPA completada."
langDict.Add "SIPA_EXPORT_SAVED", "Exportación a SIPA completada y guardada en {0}"
langDict.Add "SIPA_EXPORT_NOT_SAVED", "Exportación a SIPA completada. No se ha guardado en un archivo separado."
messages.Add "ES", langDict
' Mensajes en italiano
Set langDict = CreateObject("Scripting.Dictionary")
langDict.Add "IMPORT_COMPLETE", "Importazione completata."
langDict.Add "EXPORT_COMPLETE", "Esportazione completata."
langDict.Add "FILE_NOT_SELECTED", "Nessun file selezionato. Operazione annullata."
langDict.Add "DUPLICATE_VALUE", "È stato trovato un valore duplicato: {0} nella riga {1}. L'operazione è stata interrotta."
langDict.Add "ALARM_NODE_NOT_FOUND", "Il nodo 'Alarms' non è stato trovato nel file XML."
langDict.Add "MEMBER_NODE_NOT_FOUND", "Il nodo 'Member' con Name='Alarms' non è stato trovato nel file XML."
langDict.Add "ROWS_HIDDEN", "Processo completato. Righe nascoste: {0}"
langDict.Add "ALL_ROWS_SHOWN", "Tutte le righe sono ora visibili."
langDict.Add "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."
langDict.Add "SIPA_EXPORT_COMPLETE", "Esportazione SIPA completata."
langDict.Add "SIPA_EXPORT_SAVED", "Esportazione SIPA completata e salvata in {0}"
langDict.Add "SIPA_EXPORT_NOT_SAVED", "Esportazione SIPA completata. Non salvata in un file separato."
messages.Add "IT", langDict
Dim lang As String
lang = GetExcelLanguage()
If messages.Exists(lang) And messages(lang).Exists(msgKey) Then
GetTranslatedMessage = messages(lang)(msgKey)
ElseIf messages("EN").Exists(msgKey) Then
GetTranslatedMessage = messages("EN")(msgKey) ' Fallback to English
Else
GetTranslatedMessage = "Message not found: " & msgKey ' Fallback if message key doesn't exist
End If
End Function
The password for the VBA is: 3vpjTCr^AuyEw&
This script works with a DB like this:
!
Use the XML file Exported from :
!
!
Then drag an drop in offline the DB to export on the Workspace area