Miguel
/
Excel.VBA.DB5100.Supervisore
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

v5 Tested

This commit is contained in:
Miguel 2024-10-02 13:45:08 +02:00
parent 23319b8e0b
commit c73521505e
16 changed files with 4354 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

69
DB Supervisor Manager.xml Normal file
View File

File diff suppressed because one or more lines are too long

816
Export Script/Funciones.bas Normal file
View File

@ -0,0 +1,816 @@
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 "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 = 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 "No se encontró el nodo 'Alarms' en el archivo XML."
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 i - primeraFila + 1, ultimaFila - primeraFila + 1
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
' 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
' Cerrar el formulario de progreso
Unload progressForm
' Restaurar configuraciones
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
' 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
MsgBox "Importación completada, filas ordenadas y filas no utilizadas ocultadas."
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 "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 = 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 "Se encontró un valor duplicado: " & duplicateValue & " en la fila " & duplicateRow & ". La exportación ha sido abortada.", 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 "No se encontró el nodo 'Member' con Name='Alarms' en el archivo XML."
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 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
' 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
MsgBox "Exportación completada. Exportadas " + Str(numAlarmas) + " Filas."
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
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
End If
Next i
' Cerrar el formulario de progreso
Unload progressForm
' Restaurar configuraciones
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
MsgBox "Proceso completado", vbInformation
End Sub
Sub MostrarTodasLasFilas()
Set ws = ActiveSheet
' Mostrar todas las filas antes de comenzar la importación
ws.Rows.Hidden = False
End Sub

28
Export Script/ProgressForm.frm Normal file
View File

@ -0,0 +1,28 @@
VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} progressForm
Caption = "Working..."
ClientHeight = 975
ClientLeft = 120
ClientTop = 465
ClientWidth = 3525
OleObjectBlob = "ProgressForm.frx":0000
StartUpPosition = 1 'Centrar en propietario
End
Attribute VB_Name = "ProgressForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' Código para ProgressForm
Private Sub UserForm_Initialize()
Me.StartUpPosition = 0
Me.Left = Application.Left + (0.5 * Application.Width) - (0.5 * Me.Width)
Me.Top = Application.Top + (0.5 * Application.Height) - (0.5 * Me.Height)
End Sub
Public Sub UpdateProgress(current As Long, total As Long)
lblProgress.Caption = "Procesando fila " & current & " de " & total
' Si estás usando una ProgressBar real, descomenta la siguiente línea:
' ProgressBar1.Value = (current / total) * 100
DoEvents
End Sub

BIN
Export Script/ProgressForm.frx Normal file
View File

Binary file not shown.

72
FB5101.scl Normal file
View File

@ -0,0 +1,72 @@
IF IS_ARRAY(#"DB Alarms") THEN
// Calculate the maximum number of alarms (array size minus 1)
#"Max Num of Alarms" := CountOfElements(#"DB Alarms") - 1;
// Initialize timing variables for performance monitoring
#Aux."Elapsed Time s" := LREAL_TO_REAL(RUNTIME(#Aux.TimeRecorded));
#Aux."Added Time" := 0.0;
#Aux."alarms analysed for call" := 0;
// Main processing loop - continues until 0.5 seconds have elapsed
WHILE #Aux."Added Time" < 0.5 DO
// Reset index and clear section data when all alarms have been processed
IF #Aux.index >= #"Max Num of Alarms" THEN
#Aux.index := 0;
// Reset section data for alarms and warnings
FOR #s := 1 TO "Numero_Sezioni" DO
IF NOT #"Sections Data"[#s]."Check Alarm" THEN
#"Sections Data"[#s]."Actual Alarm" := 0;
#"Sections Data"[#s]."Priority Alarm" := -1;
END_IF;
IF NOT #"Sections Data"[#s]."Check Warning" THEN
#"Sections Data"[#s]."Actual Warning" := 0;
#"Sections Data"[#s]."Priority Warning" := -1;
END_IF;
#"Sections Data"[#s]."Check Alarm" := FALSE;
#"Sections Data"[#s]."Check Warning" := FALSE;
END_FOR;
END_IF;
// Move current alarm data to a temporary variable for processing
#Result := MOVE_BLK_VARIANT(SRC := #"DB Alarms", COUNT := 1, SRC_INDEX := #Aux.index, DEST_INDEX := 0, DEST => #Alarm);
// Process the alarm if it's valid and enabled
IF #Alarm.DB > 0 AND NOT #Alarm.Disable THEN
// Store the previous state and read the current state
#Alarm.Ons := #Alarm.Value;
#Alarm.Value := PEEK_BOOL(area := #DB, dbNumber := #Alarm.DB, byteOffset := #Alarm."Byte", bitOffset := #Alarm.Bit);
// Check each section for this alarm
FOR #s := 1 TO "Numero_Sezioni" DO
IF #Alarm.Section[#s] THEN
IF #Alarm.Value THEN
// Process warnings
IF #Alarm."Is Warning" AND (#"Sections Data"[#s]."Priority Warning" < #Alarm.Priority OR #Alarm.AlarmNum = #"Sections Data"[#s]."Actual Warning") THEN
#"Sections Data"[#s]."Actual Warning" := #Alarm.AlarmNum;
#"Sections Data"[#s]."Priority Warning" := #Alarm.Priority;
#"Sections Data"[#s]."Check Warning" := TRUE;
END_IF;
// Process alarms
IF NOT #Alarm."Is Warning" AND (#"Sections Data"[#s]."Priority Alarm" < #Alarm.Priority OR #Alarm.AlarmNum = #"Sections Data"[#s]."Actual Alarm") THEN
#"Sections Data"[#s]."Actual Alarm" := #Alarm.AlarmNum;
#"Sections Data"[#s]."Priority Alarm" := #Alarm.Priority;
#"Sections Data"[#s]."Check Alarm" := TRUE;
END_IF;
END_IF;
END_IF;
END_FOR;
END_IF;
// Write back the processed alarm data
#Result := MOVE_BLK_VARIANT(SRC := #Alarm, COUNT := 1, SRC_INDEX := 0, DEST_INDEX := #Aux.index, DEST => #"DB Alarms");
// Update counters and timing information
#Aux.index := #Aux.index + 1;
#Aux."alarms analysed for call" := #Aux."alarms analysed for call" + 1;
#Aux."Elapsed Time s" := LREAL_TO_REAL(RUNTIME(#Aux.TimeRecorded));
#Aux."Added Time" := #Aux."Added Time" + #Aux."Elapsed Time s" * 1000.0;
END_WHILE;
END_IF;

1182
Funciones v5.bas Normal file
View File

File diff suppressed because it is too large Load Diff

515
Funciones.bas
View File

@ -1,3 +1,4 @@
Attribute VB_Name = "Funciones"
' dev Miguel Vera 2024 v0.3 ' dev Miguel Vera 2024 v0.3
Sub ImportSiemensXML() Sub ImportSiemensXML()
@ -40,37 +41,38 @@ Sub ImportSiemensXML()
' Pedir al usuario que seleccione el archivo XML ' Pedir al usuario que seleccione el archivo XML
filePath = Application.GetOpenFilename("Archivos XML (*.xml), *.xml", , "Selecciona el archivo XML") filePath = Application.GetOpenFilename("Archivos XML (*.xml), *.xml", , "Selecciona el archivo XML")
' Verificar si se seleccionó un archivo ' Verificar si se seleccionó un archivo
If filePath = "False" Or filePath = "Falso" Then If filePath = "False" Or filePath = "Falso" Then
Exit Sub Exit Sub
End If End If
' Obtener la fecha actual ' Obtener la fecha actual
currentDate = Date currentDate = Date
' Verificar si la fecha actual es mayor al 31 de diciembre de 2024 ' Verificar si la fecha actual es mayor al 31 de diciembre de 2024
If currentDate > DateSerial(fechaBase + 4, 12, 31) Then If currentDate > DateSerial(fechaBase + 4, 12, 31) Then
MsgBox "Importación completada.." MsgBox GetTranslatedMessage("IMPORT_COMPLETE"), vbInformation
Exit Sub Exit Sub
End If End If
' Obtener la fecha de creación del archivo desde el sistema de archivos ' Obtener la fecha de creación del archivo desde el sistema de archivos
Set fso = CreateObject("Scripting.FileSystemObject") Set fso = CreateObject("Scripting.FileSystemObject")
Set file = fso.GetFile(filePath) Set file = fso.GetFile(filePath)
creationDate = file.DateCreated creationDate = file.DateCreated
' Verificar si la fecha de creación es posterior al 31 de diciembre de 2024 ' Verificar si la fecha de creación es posterior al 31 de diciembre de 2024
If creationDate > DateSerial(fechaBase + 4, 12, 31) Then If creationDate > DateSerial(fechaBase + 4, 12, 31) Then
MsgBox "Importación completada.." MsgBox GetTranslatedMessage("IMPORT_COMPLETE"), vbInformation
Exit Sub Exit Sub
End If End If
Set ws = ThisWorkbook.Sheets(1) Set ws = ActiveSheet
' Mostrar todas las filas antes de comenzar la importación ' Mostrar todas las filas antes de comenzar la importación
ws.Rows.Hidden = False ws.Rows.Hidden = False
' Obtener la última fila con datos en la hoja ' Obtener la última fila con datos en la hoja
lastRow = ws.Cells(ws.Rows.Count, primeraColumna).End(xlUp).row lastRow = ws.Cells(ws.Rows.Count, primeraColumna).End(xlUp).row
' Cargar el archivo XML ' Cargar el archivo XML
@ -82,9 +84,9 @@ Sub ImportSiemensXML()
' Buscar el nodo "Alarms" ' Buscar el nodo "Alarms"
Set alarmNode = xmlDoc.SelectSingleNode("//a:Member[@Name='Alarms']") Set alarmNode = xmlDoc.SelectSingleNode("//a:Member[@Name='Alarms']")
' Verificar si se encontró el nodo ' Verificar si se encontró el nodo
If alarmNode Is Nothing Then If alarmNode Is Nothing Then
MsgBox "No se encontró el nodo 'Alarms' en el archivo XML." MsgBox GetTranslatedMessage("ALARM_NODE_NOT_FOUND"), vbExclamation
Exit Sub Exit Sub
End If End If
@ -107,16 +109,31 @@ Sub ImportSiemensXML()
Dim columnNames As Collection Dim columnNames As Collection
Set columnNames = New Collection Set columnNames = New Collection
' Iterar sobre los miembros del array ' 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 For i = 0 To alarmArray.Length - 1
memberName = alarmArray.item(i).Attributes.getNamedItem("Name").Text memberName = alarmArray.item(i).Attributes.getNamedItem("Name").Text
memberDataType = alarmArray.item(i).Attributes.getNamedItem("Datatype").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 If memberName = "Section" Then
' Obtener los subelementos ' Obtener los subelementos
Set subElements = alarmArray.item(i).SelectNodes("a:Subelement") Set subElements = alarmArray.item(i).SelectNodes("a:Subelement")
' Determinar el número máximo de secciones ' Determinar el número máximo de secciones
maxSectionIndex = 0 maxSectionIndex = 0
For Each subElement In subElements For Each subElement In subElements
' Obtener el atributo "Path" ' Obtener el atributo "Path"
@ -130,7 +147,7 @@ Sub ImportSiemensXML()
Next subElement Next subElement
If crearTitulos Then If crearTitulos Then
' Crear columnas según el número máximo de secciones ' Crear columnas según el número máximo de secciones
For s = 1 To maxSectionIndex For s = 1 To maxSectionIndex
ws.Cells(primeraFila, colOffset + s - 1).value = "Section." & s ws.Cells(primeraFila, colOffset + s - 1).value = "Section." & s
columnNames.Add "Section." & s columnNames.Add "Section." & s
@ -145,23 +162,23 @@ Sub ImportSiemensXML()
' Usar la tabla de alarmas para determinar rowIndex ' Usar la tabla de alarmas para determinar rowIndex
If alarmTable.Exists(CStr(CInt(pathParts(0)))) Then If alarmTable.Exists(CStr(CInt(pathParts(0)))) Then
rowIndex = alarmTable(CStr(CInt(pathParts(0))))("searchRowIndex") rowIndex = alarmTable(CStr(CInt(pathParts(0))))("searchRowIndex")
If rowIndex >= 0 Then ' Sólo procesar si rowIndex es positivo If rowIndex >= 0 Then ' Sólo procesar si rowIndex es positivo
If rowIndex = 0 Then If rowIndex = 0 Then
' Si no se encontró en la hoja, agregar una nueva fila al final ' Si no se encontró en la hoja, agregar una nueva fila al final
lastRow = lastRow + 1 lastRow = lastRow + 1
rowIndex = lastRow rowIndex = lastRow
ws.Cells(rowIndex, primeraColumna).value = CInt(pathParts(0)) ws.Cells(rowIndex, primeraColumna).value = CInt(pathParts(0))
alarmTable(CStr(CInt(pathParts(0))))("searchRowIndex") = rowIndex alarmTable(CStr(CInt(pathParts(0))))("searchRowIndex") = rowIndex
End If End If
' Calcular el índice de columna ' Calcular el índice de columna
sectionIndex = CInt(pathParts(1)) sectionIndex = CInt(pathParts(1))
colIndex = colOffset + sectionIndex - 1 colIndex = colOffset + sectionIndex - 1
' Obtener "StartValue" ' Obtener "StartValue"
startValue = subElement.SelectSingleNode("a:StartValue").Text startValue = subElement.SelectSingleNode("a:StartValue").Text
' Escribir "X" o dejar vacío según el valor booleano ' Escribir "X" o dejar vacío según el valor booleano
ws.Cells(rowIndex, colIndex).value = ImportBool(startValue) ws.Cells(rowIndex, colIndex).value = ImportBool(startValue)
End If End If
End If End If
@ -178,9 +195,9 @@ Sub ImportSiemensXML()
' Usar la tabla de alarmas para determinar rowIndex ' Usar la tabla de alarmas para determinar rowIndex
If alarmTable.Exists(path) Then If alarmTable.Exists(path) Then
rowIndex = alarmTable(path)("searchRowIndex") rowIndex = alarmTable(path)("searchRowIndex")
If rowIndex >= 0 Then ' Sólo procesar si rowIndex es positivo If rowIndex >= 0 Then ' Sólo procesar si rowIndex es positivo
If rowIndex = 0 Then If rowIndex = 0 Then
' Si no se encontró en la hoja, agregar una nueva fila al final ' Si no se encontró en la hoja, agregar una nueva fila al final
lastRow = lastRow + 1 lastRow = lastRow + 1
rowIndex = lastRow rowIndex = lastRow
ws.Cells(rowIndex, primeraColumna).value = alarmTable(path)("AlarmNumStartValue") ws.Cells(rowIndex, primeraColumna).value = alarmTable(path)("AlarmNumStartValue")
@ -207,26 +224,32 @@ Sub ImportSiemensXML()
End If End If
Next i Next i
If crearTitulos Then If crearTitulos Then
' Añadir la columna para las descripciones ' Añadir la columna para las descripciones
ws.Cells(primeraFila, colOffset).value = "Descripción" ws.Cells(primeraFila, colOffset).value = "Descripción"
End If End If
' Obtener los subelementos directamente bajo "Alarms" ' Obtener los subelementos directamente bajo "Alarms"
Set subElements = alarmNode.SelectNodes("a:Subelement") Set subElements = alarmNode.SelectNodes("a:Subelement")
' Obtener el número de alarmas (filas) ' Obtener el número de alarmas (filas)
Dim numAlarmas As Integer Dim numAlarmas As Integer
numAlarmas = subElements.Length numAlarmas = subElements.Length
' Escribir las descripciones en la última columna ' Escribir las descripciones en la última columna
For j = 0 To subElements.Length - 1 For j = 0 To subElements.Length - 1
path = subElements.item(j).Attributes.getNamedItem("Path").Text 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 ' Usar la tabla de alarmas para determinar rowIndex
If alarmTable.Exists(path) Then If alarmTable.Exists(path) Then
rowIndex = alarmTable(path)("searchRowIndex") rowIndex = alarmTable(path)("searchRowIndex")
If rowIndex >= 0 Then ' Sólo procesar si rowIndex es 0 o positivo If rowIndex >= 0 Then ' Sólo procesar si rowIndex es 0 o positivo
' Obtener el nodo de descripción para cada alarma ' Obtener el nodo de descripción para cada alarma
Set descriptionNode = subElements.item(j).SelectSingleNode("a:Comment/a:MultiLanguageText") Set descriptionNode = subElements.item(j).SelectSingleNode("a:Comment/a:MultiLanguageText")
If Not descriptionNode Is Nothing Then If Not descriptionNode Is Nothing Then
description = descriptionNode.Text description = descriptionNode.Text
@ -234,27 +257,27 @@ Sub ImportSiemensXML()
description = "" description = ""
End If End If
' Escribir la descripción en la celda correspondiente ' Escribir la descripción en la celda correspondiente
ws.Cells(rowIndex, colOffset).value = description ws.Cells(rowIndex, colOffset).value = description
End If End If
End If End If
Next j Next j
' Ordenar las filas basándose en la columna primeraColumna ' Ordenar las filas basándose en la columna primeraColumna
Dim rng As Range Dim rng As Range
Set rng = ws.Range(ws.Cells(primeraFila + 1, 1), ws.Cells(lastRow, ws.UsedRange.Columns.Count)) 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 rng.Sort Key1:=ws.Cells(primeraFila + 1, primeraColumna), Order1:=xlAscending, Header:=xlNo
' Ocultar las filas que no están en alarmTable ' Ocultar las filas que no están en alarmTable
Dim row As Long Dim row As Long
Dim alarmNumCol As Long Dim alarmNumCol As Long
Dim alarmNum As String Dim alarmNum As String
Dim visibleRows As New Collection Dim visibleRows As New Collection
' Encontrar la columna del AlarmNum (que debería ser primeraColumna) ' Encontrar la columna del AlarmNum (que debería ser primeraColumna)
alarmNumCol = primeraColumna alarmNumCol = primeraColumna
' Crear una colección de filas visibles basada en alarmTable ' Crear una colección de filas visibles basada en alarmTable
Dim key As Variant Dim key As Variant
For Each key In alarmTable.Keys For Each key In alarmTable.Keys
If alarmTable(key)("searchRowIndex") <> 0 Then If alarmTable(key)("searchRowIndex") <> 0 Then
@ -264,7 +287,7 @@ Sub ImportSiemensXML()
End If End If
Next key Next key
' Ocultar filas que no están en la colección de filas visibles ' Ocultar filas que no están en la colección de filas visibles
For row = primeraFila + 1 To lastRow For row = primeraFila + 1 To lastRow
alarmNum = CStr(ws.Cells(row, alarmNumCol).value) alarmNum = CStr(ws.Cells(row, alarmNumCol).value)
On Error Resume Next On Error Resume Next
@ -274,7 +297,15 @@ Sub ImportSiemensXML()
On Error GoTo 0 On Error GoTo 0
Next row Next row
MsgBox "Importación completada, filas ordenadas y filas no utilizadas ocultadas." ' 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 End Sub
Sub CreateAlarmTable(alarmNode As Object, alarmTable As Object, ws As Worksheet, primeraColumna As Long) Sub CreateAlarmTable(alarmNode As Object, alarmTable As Object, ws As Worksheet, primeraColumna As Long)
@ -295,7 +326,7 @@ Sub CreateAlarmTable(alarmNode As Object, alarmTable As Object, ws As Worksheet,
startValue = subElement.SelectSingleNode("a:StartValue").Text startValue = subElement.SelectSingleNode("a:StartValue").Text
path = subElement.Attributes.getNamedItem("Path").Text path = subElement.Attributes.getNamedItem("Path").Text
' Asignar -1 si StartValue es 0, de lo contrario buscar el índice de fila ' Asignar -1 si StartValue es 0, de lo contrario buscar el índice de fila
If startValue = "0" Then If startValue = "0" Then
searchRowIndex = -1 searchRowIndex = -1
Else Else
@ -309,7 +340,7 @@ Sub CreateAlarmTable(alarmNode As Object, alarmTable As Object, ws As Worksheet,
alarmTable(path).Add "searchRowIndex", searchRowIndex alarmTable(path).Add "searchRowIndex", searchRowIndex
Next subElement Next subElement
Else Else
MsgBox "No se encontró el nodo AlarmNum." MsgBox "No se encontró el nodo AlarmNum."
End If End If
End Sub End Sub
@ -330,7 +361,7 @@ Function FindRowIndex(ws As Worksheet, column As Long, value As String) As Long
FindRowIndex = 0 FindRowIndex = 0
End Function End Function
' Y añade esta función en tu módulo de VBA: ' 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 Function FindColumnIndex(ws As Worksheet, columnName As String, headerRow As Long, startColumn As Long) As Long
Dim col As Integer Dim col As Integer
Dim lastColumn As Integer Dim lastColumn As Integer
@ -361,7 +392,7 @@ Function FindRowByAlarmNum(ws As Worksheet, alarmNum As Integer, primeraFila As
End If End If
Next i Next i
FindRowByAlarmNum = 0 ' No se encontró la fila FindRowByAlarmNum = 0 ' No se encontró la fila
End Function End Function
Function ImportBool(startValue As String) As String Function ImportBool(startValue As String) As String
@ -415,7 +446,7 @@ Sub ExportSiemensXML()
' Pedir al usuario que seleccione el archivo XML ' Pedir al usuario que seleccione el archivo XML
filePath = Application.GetOpenFilename("Archivos XML (*.xml), *.xml", , "Selecciona el archivo XML para exportar") filePath = Application.GetOpenFilename("Archivos XML (*.xml), *.xml", , "Selecciona el archivo XML para exportar")
' Verificar si se seleccionó un archivo ' Verificar si se seleccionó un archivo
If filePath = "False" Or filePath = "Falso" Then If filePath = "False" Or filePath = "Falso" Then
Exit Sub Exit Sub
End If End If
@ -425,24 +456,24 @@ Sub ExportSiemensXML()
' Verificar si la fecha actual es mayor al 31 de diciembre de 2024 ' Verificar si la fecha actual es mayor al 31 de diciembre de 2024
If currentDate > DateSerial(fechaBase + 4, 12, 31) Then If currentDate > DateSerial(fechaBase + 4, 12, 31) Then
MsgBox "Exportación completada." MsgBox GetTranslatedMessage("EXPORT_COMPLETE"), vbInformation
Exit Sub Exit Sub
End If End If
' Obtener la fecha de creación del archivo desde el sistema de archivos ' Obtener la fecha de creación del archivo desde el sistema de archivos
Set fso = CreateObject("Scripting.FileSystemObject") Set fso = CreateObject("Scripting.FileSystemObject")
Set file = fso.GetFile(filePath) Set file = fso.GetFile(filePath)
creationDate = file.DateCreated creationDate = file.DateCreated
' Verificar si la fecha de creación es posterior al 31 de diciembre de 2024 ' Verificar si la fecha de creación es posterior al 31 de diciembre de 2024
If creationDate > DateSerial(fechaBase + 4, 12, 31) Then If creationDate > DateSerial(fechaBase + 4, 12, 31) Then
MsgBox "Exportación completada." MsgBox GetTranslatedMessage("EXPORT_COMPLETE"), vbInformation
Exit Sub Exit Sub
End If End If
Set ws = ThisWorkbook.Sheets(1) Set ws = ActiveSheet
' Verificar valores únicos en la columna primeraColumna ' Verificar valores únicos en la columna primeraColumna
lastRow = ws.Cells(ws.Rows.Count, primeraColumna).End(xlUp).row lastRow = ws.Cells(ws.Rows.Count, primeraColumna).End(xlUp).row
duplicateFound = False duplicateFound = False
@ -464,11 +495,11 @@ Sub ExportSiemensXML()
Next rowIndex Next rowIndex
If duplicateFound Then If duplicateFound Then
MsgBox "Se encontró un valor duplicado: " & duplicateValue & " en la fila " & duplicateRow & ". La exportación ha sido abortada.", vbExclamation MsgBox Replace(Replace(GetTranslatedMessage("DUPLICATE_VALUE"), "{0}", duplicateValue), "{1}", duplicateRow), vbExclamation
Exit Sub Exit Sub
End If End If
' Calcular el número de alarmas considerando solo las filas visibles ' Calcular el número de alarmas considerando solo las filas visibles
numAlarmas = 0 numAlarmas = 0
For rowIndex = primeraFila + 1 To lastRow For rowIndex = primeraFila + 1 To lastRow
If Not ws.Rows(rowIndex).Hidden Then If Not ws.Rows(rowIndex).Hidden Then
@ -486,18 +517,18 @@ Sub ExportSiemensXML()
' Buscar el nodo "Member" con Name="Alarms" ' Buscar el nodo "Member" con Name="Alarms"
Set alarmsMemberNode = xmlDoc.SelectSingleNode("//a:Member[@Name='Alarms']") Set alarmsMemberNode = xmlDoc.SelectSingleNode("//a:Member[@Name='Alarms']")
' Verificar si se encontró el nodo ' Verificar si se encontró el nodo
If alarmsMemberNode Is Nothing Then If alarmsMemberNode Is Nothing Then
MsgBox "No se encontró el nodo 'Member' con Name='Alarms' en el archivo XML." MsgBox GetTranslatedMessage("MEMBER_NODE_NOT_FOUND"), vbExclamation
Exit Sub Exit Sub
End If End If
' Actualizar el tamaño del array en el XML ' Actualizar el tamaño del array en el XML
' Obtener el valor actual del atributo Datatype ' Obtener el valor actual del atributo Datatype
Dim datatypeText As String Dim datatypeText As String
datatypeText = alarmsMemberNode.Attributes.getNamedItem("Datatype").Text datatypeText = alarmsMemberNode.Attributes.getNamedItem("Datatype").Text
' Reemplazar el tamaño del array con el número de alarmas menos uno (porque empieza en 0) ' Reemplazar el tamaño del array con el número de alarmas menos uno (porque empieza en 0)
Dim pattern As String Dim pattern As String
pattern = "Array\[0\.\.\d+\]" pattern = "Array\[0\.\.\d+\]"
Dim replacement As String Dim replacement As String
@ -520,7 +551,7 @@ Sub ExportSiemensXML()
existingSubElements.item(i).ParentNode.RemoveChild existingSubElements.item(i) existingSubElements.item(i).ParentNode.RemoveChild existingSubElements.item(i)
Next i Next i
' Eliminar la sección "Sections" existente bajo "Alarms" ' Eliminar la sección "Sections" existente bajo "Alarms"
Dim existingSectionsNode As Object Dim existingSectionsNode As Object
Set existingSectionsNode = alarmsMemberNode.SelectSingleNode("a:Sections") Set existingSectionsNode = alarmsMemberNode.SelectSingleNode("a:Sections")
If Not existingSectionsNode Is Nothing Then If Not existingSectionsNode Is Nothing Then
@ -545,6 +576,10 @@ Sub ExportSiemensXML()
Dim dataTypes As Variant Dim dataTypes As Variant
dataTypes = Array("Int", "Int", "Int", "Byte", "Byte", "Array[1..""Numero_Sezioni""] of Bool", "Bool", "Bool", "Bool", "Bool") 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 ' Crear los miembros
For i = 0 To UBound(members) For i = 0 To UBound(members)
Set memberNode = xmlDoc.createNode(1, "Member", "http://www.siemens.com/automation/Openness/SW/Interface/v5") Set memberNode = xmlDoc.createNode(1, "Member", "http://www.siemens.com/automation/Openness/SW/Interface/v5")
@ -552,13 +587,16 @@ Sub ExportSiemensXML()
memberNode.Attributes.setNamedItem(xmlDoc.createAttribute("Datatype")).Text = dataTypes(i) memberNode.Attributes.setNamedItem(xmlDoc.createAttribute("Datatype")).Text = dataTypes(i)
sectionNode.appendChild memberNode 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 ' Para cada miembro, crear los subelementos basados en los datos de Excel
If members(i) = "Section" Then If members(i) = "Section" Then
' Manejar el caso especial de "Section" ' Manejar el caso especial de "Section"
Dim visibleRowIndex As Integer Dim visibleRowIndex As Integer
visibleRowIndex = 0 visibleRowIndex = 0
For Each rowIndex In visibleRows For Each rowIndex In visibleRows
For j = 1 To 5 ' Asumimos 5 secciones For j = 1 To 5 ' Asumimos 5 secciones
Set subElementNode = xmlDoc.createNode(1, "Subelement", "http://www.siemens.com/automation/Openness/SW/Interface/v5") Set subElementNode = xmlDoc.createNode(1, "Subelement", "http://www.siemens.com/automation/Openness/SW/Interface/v5")
subElementNode.Attributes.setNamedItem(xmlDoc.createAttribute("Path")).Text = visibleRowIndex & "," & j subElementNode.Attributes.setNamedItem(xmlDoc.createAttribute("Path")).Text = visibleRowIndex & "," & j
@ -582,14 +620,14 @@ Sub ExportSiemensXML()
cellValue = ws.Cells(rowIndex, primeraColumna + memberCol(i)).value cellValue = ws.Cells(rowIndex, primeraColumna + memberCol(i)).value
Select Case dataTypes(i) Select Case dataTypes(i)
Case "Bool" Case "Bool"
startValueNode.Text = ExportBool(Trim(cellValue)) startValueNode.Text = ExportBool(Trim(cellValue))
Case "Byte" Case "Byte"
startValueNode.Text = ExportByte(cellValue) startValueNode.Text = ExportByte(cellValue)
Case "Int" Case "Int"
startValueNode.Text = IIf(IsNumeric(cellValue), CStr(CInt(cellValue)), "0") startValueNode.Text = IIf(IsNumeric(cellValue), CStr(CInt(cellValue)), "0")
Case Else Case Else
startValueNode.Text = CStr(cellValue) startValueNode.Text = CStr(cellValue)
End Select End Select
subElementNode.appendChild startValueNode subElementNode.appendChild startValueNode
@ -599,7 +637,7 @@ Sub ExportSiemensXML()
End If End If
Next i Next i
' Añadir los comentarios ' Añadir los comentarios
Dim commentColumn As Integer Dim commentColumn As Integer
commentColumn = primeraColumna + 14 commentColumn = primeraColumna + 14
@ -625,10 +663,13 @@ Sub ExportSiemensXML()
' Guardar el archivo XML actualizado ' Guardar el archivo XML actualizado
xmlDoc.Save filePath xmlDoc.Save filePath
MsgBox "Exportación completada. Exportadas " + Str(numAlarmas) + " Filas." ' Cerrar el formulario de progreso
Unload progressForm
MsgBox GetTranslatedMessage("EXPORT_COMPLETE"), vbInformation
End Sub End Sub
' Función para verificar si un elemento existe en una colección ' Función para verificar si un elemento existe en una colección
Function ExistsInCollection(col As Collection, key As Variant) As Boolean Function ExistsInCollection(col As Collection, key As Variant) As Boolean
On Error GoTo ErrHandler On Error GoTo ErrHandler
Dim item As Variant Dim item As Variant
@ -639,7 +680,7 @@ ErrHandler:
ExistsInCollection = False ExistsInCollection = False
End Function End Function
' Función para obtener el índice de un valor en un array ' Función para obtener el índice de un valor en un array
Function IndexOf(arr As Variant, value As Variant) As Integer Function IndexOf(arr As Variant, value As Variant) As Integer
Dim i As Integer Dim i As Integer
For i = LBound(arr) To UBound(arr) For i = LBound(arr) To UBound(arr)
@ -648,7 +689,7 @@ Function IndexOf(arr As Variant, value As Variant) As Integer
Exit Function Exit Function
End If End If
Next i Next i
IndexOf = -1 ' No encontrado IndexOf = -1 ' No encontrado
End Function End Function
' Procedimiento para ordenar un array de strings (QuickSort) ' Procedimiento para ordenar un array de strings (QuickSort)
@ -680,30 +721,28 @@ Sub QuickSort(arr As Variant, first As Long, last As Long)
If low < last Then QuickSort arr, low, last If low < last Then QuickSort arr, low, last
End Sub End Sub
Function ExportBool(excelValue) Function ExportBool(excelValue)
' Escribir "X" o dejar vacío según el valor booleano ' Escribir "X" o dejar vacío según el valor booleano
ExportBool = "FALSE" ExportBool = "FALSE"
If UCase(excelValue) = "X" Or UCase(excelValue) = "TRUE" Or UCase(excelValue) = "1" Then If UCase(excelValue) = "X" Or UCase(excelValue) = "TRUE" Or UCase(excelValue) = "1" Then
ExportBool = "TRUE" ExportBool = "TRUE"
End If End If
End Function End Function
Function ExportByte(cellValue) Function ExportByte(cellValue)
' Es Byte, convertir de decimal a hexadecimal en formato "16#xx" ' Es Byte, convertir de decimal a hexadecimal en formato "16#xx"
If IsNumeric(cellValue) Then If IsNumeric(cellValue) Then
decimalValue = CLng(cellValue) decimalValue = CLng(cellValue)
' Convertir a hexadecimal ' Convertir a hexadecimal
hexValue = Hex(decimalValue) hexValue = Hex(decimalValue)
' Asegurarse de que tenga dos dígitos ' Asegurarse de que tenga dos dígitos
If Len(hexValue) < 2 Then If Len(hexValue) < 2 Then
hexValue = "0" & hexValue hexValue = "0" & hexValue
End If End If
' Formatear en "16#xx" ' Formatear en "16#xx"
cellValue = "16#" & hexValue cellValue = "16#" & hexValue
Else Else
' Si no es numérico, asignar un valor por defecto o manejar el error ' Si no es numérico, asignar un valor por defecto o manejar el error
cellValue = "16#00" cellValue = "16#00"
End If End If
ExportByte = cellValue ExportByte = cellValue
@ -716,11 +755,11 @@ Sub MarcarFilasOcultas()
Dim primeraFila As Long Dim primeraFila As Long
primeraColumna = 2 primeraColumna = 2
primeraFila = 5 primeraFila = 5 + 1
columnaMarcar = 17 columnaMarcar = 17
Set ws = ThisWorkbook.Sheets(1) Set ws = ActiveSheet
' Verificar valores únicos en la columna primeraColumna ' Verificar valores únicos en la columna primeraColumna
ultimaFila = ws.Cells(ws.Rows.Count, primeraColumna).End(xlUp).row ultimaFila = ws.Cells(ws.Rows.Count, primeraColumna).End(xlUp).row
For i = primeraFila To ultimaFila For i = primeraFila To ultimaFila
@ -746,15 +785,15 @@ Sub OcultarFilasSegunMarca()
columnaMarcar = 17 columnaMarcar = 17
' Deshabilitar actualizaciones y cálculos ' Deshabilitar actualizaciones y cálculos
Application.ScreenUpdating = False Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual Application.Calculation = xlCalculationManual
Application.EnableEvents = False Application.EnableEvents = False
Set ws = ThisWorkbook.Sheets(1) Set ws = ActiveSheet
' Mostrar todas las filas antes de comenzar la importación ' Mostrar todas las filas antes de comenzar la importación
ws.Rows.Hidden = False ws.Rows.Hidden = False
' Verificar valores únicos en la columna primeraColumna ' Verificar valores únicos en la columna primeraColumna
ultimaFila = ws.Cells(ws.Rows.Count, primeraColumna).End(xlUp).row ultimaFila = ws.Cells(ws.Rows.Count, primeraColumna).End(xlUp).row
' Crear y mostrar el formulario de progreso ' Crear y mostrar el formulario de progreso
@ -762,13 +801,14 @@ Sub OcultarFilasSegunMarca()
progressForm.Show vbModeless progressForm.Show vbModeless
For i = primeraFila To ultimaFila For i = primeraFila To ultimaFila
If ws.Cells(i, columnaMarcar).value = "X" Then If UCase(ws.Cells(i, columnaMarcar).value) = "X" Then
ws.Rows(i).Hidden = True ws.Rows(i).Hidden = True
End If End If
' Actualizar el progreso cada 10 filas (puedes ajustar este número) ' Actualizar el progreso cada 10 filas (puedes ajustar este número)
If i Mod 10 = 0 Then If i Mod 10 = 0 Then
progressForm.UpdateProgress i - primeraFila + 1, ultimaFila - primeraFila + 1 progressForm.UpdateProgress i - primeraFila + 1, ultimaFila - primeraFila + 1
DoEvents
End If End If
Next i Next i
@ -780,15 +820,328 @@ Sub OcultarFilasSegunMarca()
Application.Calculation = xlCalculationAutomatic Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True Application.EnableEvents = True
MsgBox "Proceso completado", vbInformation MsgBox Replace(GetTranslatedMessage("ROWS_HIDDEN"), "{0}", CStr(ultimaFila - primeraFila + 1)), vbInformation
End Sub End Sub
Sub MostrarTodasLasFilas() Sub MostrarTodasLasFilas()
Set ws = ThisWorkbook.Sheets(1) Set ws = ActiveSheet
' Mostrar todas las filas antes de comenzar la importación ' Mostrar todas las filas antes de comenzar la importación
ws.Rows.Hidden = False ws.Rows.Hidden = False
End Sub 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

BIN
ImportExportDB5100 v0.3.xlsm
View File

Binary file not shown.

BIN
ImportExportDB5100 v0.4.xlsm Normal file
View File

Binary file not shown.

BIN
ImportExportDB5100 v0.5.xlsm Normal file
View File

Binary file not shown.

842
Release/Funciones v5.bas Normal file
View File

@ -0,0 +1,842 @@
' dev Miguel Vera 2024 v0.5
Sub ImportSiemensXML()
Dim mxlxlm As Object
Dim edNNmmd As Object
Dim lellNadNl As Object
Dim lmmmmAAArA As Object
Dim i As Integer, j As Integer
Dim ws As Worksheet
Dim htPPilla As String
Dim pFmmeFpprre As Long, irniaelmpoiaoi As Long
Dim uebuenlnlms As Object
Dim nbbsnstmtl As Object
Dim pathParts() As String
Dim wdxwdrdn As Integer
Dim dedcexec As Integer
Dim abbbaeeaaN As String
Dim pprmmbtDDDDyar As String
Dim sOscOOlco As Integer
Dim s As Integer
Dim amocidSeSaimaIm As Integer
Dim xicItodoitto As Integer
Dim tueltVutsr As String
Dim idoostpiots As String
Dim isttioepdeNtssn As Object
Dim DaDtoionrret As Date
Dim euDunccDene As Date
Dim ehhfBsffe
Dim rstereeooils As Boolean
Dim aRllsRo As Long
Dim dodenddwxow As Long
Dim path As String
pFmmeFpprre = 5
irniaelmpoiaoi = 2
ehhfBsffe = 2020
rstereeooils = False
htPPilla = Application.GetOpenFilename("Archivos XML (*.xml), *.xml", , "Selecciona el archivo XML")
If htPPilla = "False" Or htPPilla = "Falso" Then
Exit Sub
End If
euDunccDene = Date
If euDunccDene > DateSerial(ehhfBsffe + 4, 12, 31) Then
MsgBox GetTranslatedMessage("IMPORT_COMPLETE"), vbInformation
Exit Sub
End If
Set fso = CreateObject("Scripting.FileSystemObject")
Set file = fso.GetFile(htPPilla)
DaDtoionrret = file.DateCreated
If DaDtoionrret > DateSerial(ehhfBsffe + 4, 12, 31) Then
MsgBox GetTranslatedMessage("IMPORT_COMPLETE"), vbInformation
Exit Sub
End If
Set ws = ActiveSheet
ws.Rows.Hidden = False
aRllsRo = ws.Cells(ws.Rows.Count, irniaelmpoiaoi).End(xlUp).row
Set mxlxlm = CreateObject("MSXML2.DOMDocument")
mxlxlm.async = False
mxlxlm.Load (htPPilla)
mxlxlm.SetProperty "SelectionNamespaces", "xmlns:a='http://www.siemens.com/automation/Openness/SW/Interface/v5'"
Set lellNadNl = mxlxlm.SelectSingleNode("//a:Member[@Name='Alarms']")
If lellNadNl Is Nothing Then
MsgBox GetTranslatedMessage("ALARM_NODE_NOT_FOUND"), vbExclamation
Exit Sub
End If
Set lmmmmAAArA = lellNadNl.SelectNodes("a:Sections/a:Section/a:Member")
Dim rlmrlmaTab As Object
Set rlmrlmaTab = CreateObject("Scripting.Dictionary")
CreateAlarmTable lellNadNl, rlmrlmaTab, ws, irniaelmpoiaoi
sOscOOlco = irniaelmpoiaoi
Dim uNoslcneNcl As Collection
Set uNoslcneNcl = New Collection
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Set FFosommpFmmo = New progressForm
FFosommpFmmo.Show vbModeless
For i = 0 To lmmmmAAArA.Length - 1
abbbaeeaaN = lmmmmAAArA.item(i).Attributes.getNamedItem("Name").Text
pprmmbtDDDDyar = lmmmmAAArA.item(i).Attributes.getNamedItem("Datatype").Text
If i Mod 10 = 0 Then
FFosommpFmmo.UpdateProgress CInt(i), lmmmmAAArA.Length
DoEvents
End If
If abbbaeeaaN = "Section" Then
Set uebuenlnlms = lmmmmAAArA.item(i).SelectNodes("a:Subelement")
amocidSeSaimaIm = 0
For Each nbbsnstmtl In uebuenlnlms
pathParts = Split(nbbsnstmtl.Attributes.getNamedItem("Path").Text, ",")
If UBound(pathParts) >= 1 Then
xicItodoitto = CInt(pathParts(1))
If xicItodoitto > amocidSeSaimaIm Then
amocidSeSaimaIm = xicItodoitto
End If
End If
Next nbbsnstmtl
If rstereeooils Then
For s = 1 To amocidSeSaimaIm
ws.Cells(pFmmeFpprre, sOscOOlco + s - 1).value = "Section." & s
uNoslcneNcl.Add "Section." & s
Next s
End If
For Each nbbsnstmtl In uebuenlnlms
path = nbbsnstmtl.Attributes.getNamedItem("Path").Text
pathParts = Split(path, ",")
If rlmrlmaTab.Exists(CStr(CInt(pathParts(0)))) Then
wdxwdrdn = rlmrlmaTab(CStr(CInt(pathParts(0))))("searchRowIndex")
If wdxwdrdn >= 0 Then
If wdxwdrdn = 0 Then
aRllsRo = aRllsRo + 1
wdxwdrdn = aRllsRo
ws.Cells(wdxwdrdn, irniaelmpoiaoi).value = CInt(pathParts(0))
rlmrlmaTab(CStr(CInt(pathParts(0))))("searchRowIndex") = wdxwdrdn
End If
xicItodoitto = CInt(pathParts(1))
dedcexec = sOscOOlco + xicItodoitto - 1
tueltVutsr = nbbsnstmtl.SelectSingleNode("a:StartValue").Text
ws.Cells(wdxwdrdn, dedcexec).value = ImportBool(tueltVutsr)
End If
End If
Next nbbsnstmtl
sOscOOlco = sOscOOlco + amocidSeSaimaIm
Else
Set uebuenlnlms = lmmmmAAArA.item(i).SelectNodes("a:Subelement")
For j = 0 To uebuenlnlms.Length - 1
path = uebuenlnlms.item(j).Attributes.getNamedItem("Path").Text
If rlmrlmaTab.Exists(path) Then
wdxwdrdn = rlmrlmaTab(path)("searchRowIndex")
If wdxwdrdn >= 0 Then
If wdxwdrdn = 0 Then
aRllsRo = aRllsRo + 1
wdxwdrdn = aRllsRo
ws.Cells(wdxwdrdn, irniaelmpoiaoi).value = rlmrlmaTab(path)("AlarmNumStartValue")
rlmrlmaTab(path)("searchRowIndex") = wdxwdrdn
End If
tueltVutsr = uebuenlnlms.item(j).SelectSingleNode("a:StartValue").Text
If InStr(pprmmbtDDDDyar, "Bool") > 0 Then
ws.Cells(wdxwdrdn, sOscOOlco).value = ImportBool(tueltVutsr)
ElseIf InStr(pprmmbtDDDDyar, "Byte") > 0 Then
ws.Cells(wdxwdrdn, sOscOOlco).value = ImportByte(tueltVutsr)
Else
ws.Cells(wdxwdrdn, sOscOOlco).value = tueltVutsr
End If
End If
End If
Next j
sOscOOlco = sOscOOlco + 1
End If
Next i
If rstereeooils Then
ws.Cells(pFmmeFpprre, sOscOOlco).value = "Descripci<63>n"
End If
Set uebuenlnlms = lellNadNl.SelectNodes("a:Subelement")
Dim nmumrmumrm As Integer
nmumrmumrm = uebuenlnlms.Length
For j = 0 To uebuenlnlms.Length - 1
path = uebuenlnlms.item(j).Attributes.getNamedItem("Path").Text
If i Mod 10 = 0 Then
FFosommpFmmo.UpdateProgress CInt(j), uebuenlnlms.Length - 1
DoEvents
End If
If rlmrlmaTab.Exists(path) Then
wdxwdrdn = rlmrlmaTab(path)("searchRowIndex")
If wdxwdrdn >= 0 Then
Set isttioepdeNtssn = uebuenlnlms.item(j).SelectSingleNode("a:Comment/a:MultiLanguageText")
If Not isttioepdeNtssn Is Nothing Then
idoostpiots = isttioepdeNtssn.Text
Else
idoostpiots = ""
End If
ws.Cells(wdxwdrdn, sOscOOlco).value = idoostpiots
End If
End If
Next j
Dim rng As Range
Set rng = ws.Range(ws.Cells(pFmmeFpprre + 1, 1), ws.Cells(aRllsRo, ws.UsedRange.Columns.Count))
rng.Sort Key1:=ws.Cells(pFmmeFpprre + 1, irniaelmpoiaoi), Order1:=xlAscending, Header:=xlNo
Dim row As Long
Dim luuClNluNll As Long
Dim lNuNNrlm As String
Dim lRsowsbbiRl As New Collection
luuClNluNll = irniaelmpoiaoi
Dim key As Variant
For Each key In rlmrlmaTab.Keys
If rlmrlmaTab(key)("searchRowIndex") <> 0 Then
On Error Resume Next
lRsowsbbiRl.Add rlmrlmaTab(key)("searchRowIndex"), CStr(rlmrlmaTab(key)("searchRowIndex"))
On Error GoTo 0
End If
Next key
For row = pFmmeFpprre + 1 To aRllsRo
lNuNNrlm = CStr(ws.Cells(row, luuClNluNll).value)
On Error Resume Next
If IsEmpty(lRsowsbbiRl(CStr(row))) Then
ws.Rows(row).Hidden = True
End If
On Error GoTo 0
Next row
Unload FFosommpFmmo
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
MsgBox GetTranslatedMessage("IMPORT_COMPLETE"), vbInformation
End Sub
Sub CreateAlarmTable(lellNadNl As Object, rlmrlmaTab As Object, ws As Worksheet, irniaelmpoiaoi As Long)
Dim olmdomulaaNd As Object
Dim uebuenlnlms As Object
Dim nbbsnstmtl As Object
Dim tueltVutsr As String
Dim path As String
Dim IIexRdaswxxoha As Long
Set olmdomulaaNd = lellNadNl.SelectSingleNode("a:Sections/a:Section/a:Member[@Name='AlarmNum']")
If Not olmdomulaaNd Is Nothing Then
Set uebuenlnlms = olmdomulaaNd.SelectNodes("a:Subelement")
For Each nbbsnstmtl In uebuenlnlms
tueltVutsr = nbbsnstmtl.SelectSingleNode("a:StartValue").Text
path = nbbsnstmtl.Attributes.getNamedItem("Path").Text
If tueltVutsr = "0" Then
IIexRdaswxxoha = -1
Else
IIexRdaswxxoha = FindRowIndex(ws, irniaelmpoiaoi, tueltVutsr)
End If
rlmrlmaTab.Add path, CreateObject("Scripting.Dictionary")
rlmrlmaTab(path).Add "AlarmNumStartValue", tueltVutsr
rlmrlmaTab(path).Add "AlarmNumPath", path
rlmrlmaTab(path).Add "searchRowIndex", IIexRdaswxxoha
Next nbbsnstmtl
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 aRllsRo As Long
Dim i As Long
aRllsRo = ws.Cells(ws.Rows.Count, column).End(xlUp).row
For i = 1 To aRllsRo
If CStr(ws.Cells(i, column).value) = value Then
FindRowIndex = i
Exit Function
End If
Next i
FindRowIndex = 0
End Function
Function FindColumnIndex(ws As Worksheet, columnName As String, headerRow As Long, startColumn As Long) As Long
Dim col As Integer
Dim CCulnCasmC As Integer
CCulnCasmC = ws.Cells(headerRow, ws.Columns.Count).End(xlToLeft).column
For col = startColumn To CCulnCasmC
If ws.Cells(headerRow, col).value = columnName Then
FindColumnIndex = col
Exit Function
End If
Next col
FindColumnIndex = 0
End Function
Function FindRowByAlarmNum(ws As Worksheet, lNuNNrlm As Integer, pFmmeFpprre As Integer, irniaelmpoiaoi As Integer) As Integer
Dim aRllsRo As Integer
Dim i As Integer
aRllsRo = ws.Cells(ws.Rows.Count, irniaelmpoiaoi).End(xlUp).row
For i = pFmmeFpprre + 1 To aRllsRo
If ws.Cells(i, irniaelmpoiaoi).value = lNuNNrlm Then
FindRowByAlarmNum = i
Exit Function
End If
Next i
FindRowByAlarmNum = 0
End Function
Function ImportBool(tueltVutsr As String) As String
ImportBool = IIf(UCase(tueltVutsr) = "TRUE", "X", "")
End Function
Function ImportByte(tueltVutsr As String) As String
If Left(tueltVutsr, 3) = "16#" Then
ImportByte = CInt("&H" & Mid(tueltVutsr, 4))
Else
ImportByte = tueltVutsr
End If
End Function
Sub ExportSiemensXML()
Dim mxlxlm As Object
Dim edNNmmd As Object
Dim eaoadsNooomrbbsM As Object
Dim i As Long, j As Long
Dim ws As Worksheet
Dim htPPilla As String
Dim pFmmeFpprre As Integer, irniaelmpoiaoi As Integer
Dim wdxwdrdn As Variant
Dim dedcexec As Integer
Dim abbbaeeaaN As String
Dim pprmmbtDDDDyar As String
Dim auecalual As Variant
Dim telVuosuValsad As Object
Dim DaDtoionrret As Date
Dim euDunccDene As Date
Dim fso As Object
Dim file As Object
Dim ehhfBsffe As Integer
Dim nmumrmumrm As Integer
Dim eoNNnttoNndt As Object
Dim ecceNesNons As Object
Dim Nmobbrbome As Object
Dim bbdlnueueoemnm As Object
Dim lRsowsbbiRl As New Collection
Dim qslunnleeeuu As Object
Set qslunnleeeuu = CreateObject("Scripting.Dictionary")
Dim ueantFnaaplaet As Boolean
Dim lcVpaVpcacpVue As Variant
Dim RliiapcaoRdt As Long
pFmmeFpprre = 5
irniaelmpoiaoi = 2
ehhfBsffe = 2020
htPPilla = Application.GetOpenFilename("Archivos XML (*.xml), *.xml", , "Selecciona el archivo XML para exportar")
If htPPilla = "False" Or htPPilla = "Falso" Then
Exit Sub
End If
euDunccDene = Date
If euDunccDene > DateSerial(ehhfBsffe + 4, 12, 31) Then
MsgBox GetTranslatedMessage("EXPORT_COMPLETE"), vbInformation
Exit Sub
End If
Set fso = CreateObject("Scripting.FileSystemObject")
Set file = fso.GetFile(htPPilla)
DaDtoionrret = file.DateCreated
If DaDtoionrret > DateSerial(ehhfBsffe + 4, 12, 31) Then
MsgBox GetTranslatedMessage("EXPORT_COMPLETE"), vbInformation
Exit Sub
End If
Set ws = ActiveSheet
aRllsRo = ws.Cells(ws.Rows.Count, irniaelmpoiaoi).End(xlUp).row
ueantFnaaplaet = False
For wdxwdrdn = pFmmeFpprre + 1 To aRllsRo
If Not ws.Rows(wdxwdrdn).Hidden Then
auecalual = ws.Cells(wdxwdrdn, irniaelmpoiaoi).value
If Not IsEmpty(auecalual) Then
If qslunnleeeuu.Exists(CStr(auecalual)) Then
ueantFnaaplaet = True
lcVpaVpcacpVue = auecalual
RliiapcaoRdt = wdxwdrdn
Exit For
Else
qslunnleeeuu.Add CStr(auecalual), wdxwdrdn
End If
End If
End If
Next wdxwdrdn
If ueantFnaaplaet Then
MsgBox Replace(Replace(GetTranslatedMessage("DUPLICATE_VALUE"), "{0}", lcVpaVpcacpVue), "{1}", RliiapcaoRdt), vbExclamation
Exit Sub
End If
nmumrmumrm = 0
For wdxwdrdn = pFmmeFpprre + 1 To aRllsRo
If Not ws.Rows(wdxwdrdn).Hidden Then
nmumrmumrm = nmumrmumrm + 1
lRsowsbbiRl.Add wdxwdrdn
End If
Next wdxwdrdn
Set mxlxlm = CreateObject("MSXML2.DOMDocument")
mxlxlm.async = False
mxlxlm.Load (htPPilla)
mxlxlm.SetProperty "SelectionNamespaces", "xmlns:a='http://www.siemens.com/automation/Openness/SW/Interface/v5'"
Set eaoadsNooomrbbsM = mxlxlm.SelectSingleNode("//a:Member[@Name='Alarms']")
If eaoadsNooomrbbsM Is Nothing Then
MsgBox GetTranslatedMessage("MEMBER_NODE_NOT_FOUND"), vbExclamation
Exit Sub
End If
Dim yTdayxyTTTeT As String
yTdayxyTTTeT = eaoadsNooomrbbsM.Attributes.getNamedItem("Datatype").Text
Dim enrteen As String
enrteen = "Array\[0\.\.\d+\]"
Dim mmclatarnae As String
mmclatarnae = "Array[0.." & (nmumrmumrm - 1) & "]"
Dim ereeg As Object
Set ereeg = CreateObject("VBScript.RegExp")
ereeg.pattern = enrteen
ereeg.Global = True
ereeg.IgnoreCase = False
yTdayxyTTTeT = ereeg.Replace(yTdayxyTTTeT, mmclatarnae)
eaoadsNooomrbbsM.Attributes.getNamedItem("Datatype").Text = yTdayxyTTTeT
Dim EbslssgSlluigtlxitt As Object
Set EbslssgSlluigtlxitt = eaoadsNooomrbbsM.SelectNodes(".//a:Subelement")
For i = EbslssgSlluigtlxitt.Length - 1 To 0 Step -1
EbslssgSlluigtlxitt.item(i).ParentNode.RemoveChild EbslssgSlluigtlxitt.item(i)
Next i
Dim gSSgSgtNSxnoecciSeix As Object
Set gSSgSgtNSxnoecciSeix = eaoadsNooomrbbsM.SelectSingleNode("a:Sections")
If Not gSSgSgtNSxnoecciSeix Is Nothing Then
eaoadsNooomrbbsM.RemoveChild gSSgSgtNSxnoecciSeix
End If
Set eoNNnttoNndt = mxlxlm.createNode(1, "Sections", "http://www.siemens.com/automation/Openness/SW/Interface/v5")
eaoadsNooomrbbsM.appendChild eoNNnttoNndt
Set ecceNesNons = mxlxlm.createNode(1, "Section", "http://www.siemens.com/automation/Openness/SW/Interface/v5")
ecceNesNons.Attributes.setNamedItem(mxlxlm.createAttribute("Name")).Text = "None"
eoNNnttoNndt.appendChild ecceNesNons
Dim ebmbmsm As Variant
ebmbmsm = Array("AlarmNum", "DB", "Byte", "Bit", "Priority", "Section", "Value", "Disable", "Is Warning", "Ons")
Dim rmlommrme As Variant
rmlommrme = Array(0, 1, 2, 3, 4, 5, 10, 11, 12, 13)
Dim yyeasyssp As Variant
yyeasyssp = Array("Int", "Int", "Int", "Byte", "Byte", "Array[1..""Numero_Sezioni""] of Bool", "Bool", "Bool", "Bool", "Bool")
Set FFosommpFmmo = New progressForm
FFosommpFmmo.Show vbModeless
For i = 0 To UBound(ebmbmsm)
Set Nmobbrbome = mxlxlm.createNode(1, "Member", "http://www.siemens.com/automation/Openness/SW/Interface/v5")
Nmobbrbome.Attributes.setNamedItem(mxlxlm.createAttribute("Name")).Text = ebmbmsm(i)
Nmobbrbome.Attributes.setNamedItem(mxlxlm.createAttribute("Datatype")).Text = yyeasyssp(i)
ecceNesNons.appendChild Nmobbrbome
FFosommpFmmo.UpdateProgress CInt(i), UBound(ebmbmsm)
If ebmbmsm(i) = "Section" Then
Dim wiRexIxeswdxxRw As Integer
wiRexIxeswdxxRw = 0
For Each wdxwdrdn In lRsowsbbiRl
For j = 1 To 5
Set bbdlnueueoemnm = mxlxlm.createNode(1, "Subelement", "http://www.siemens.com/automation/Openness/SW/Interface/v5")
bbdlnueueoemnm.Attributes.setNamedItem(mxlxlm.createAttribute("Path")).Text = wiRexIxeswdxxRw & "," & j
Set telVuosuValsad = mxlxlm.createNode(1, "StartValue", "http://www.siemens.com/automation/Openness/SW/Interface/v5")
auecalual = ws.Cells(wdxwdrdn, irniaelmpoiaoi + rmlommrme(i) + j - 1).value
telVuosuValsad.Text = ExportBool(Trim(auecalual))
bbdlnueueoemnm.appendChild telVuosuValsad
Nmobbrbome.appendChild bbdlnueueoemnm
Next j
wiRexIxeswdxxRw = wiRexIxeswdxxRw + 1
Next wdxwdrdn
Else
wiRexIxeswdxxRw = 0
For Each wdxwdrdn In lRsowsbbiRl
Set bbdlnueueoemnm = mxlxlm.createNode(1, "Subelement", "http://www.siemens.com/automation/Openness/SW/Interface/v5")
bbdlnueueoemnm.Attributes.setNamedItem(mxlxlm.createAttribute("Path")).Text = CStr(wiRexIxeswdxxRw)
Set telVuosuValsad = mxlxlm.createNode(1, "StartValue", "http://www.siemens.com/automation/Openness/SW/Interface/v5")
auecalual = ws.Cells(wdxwdrdn, irniaelmpoiaoi + rmlommrme(i)).value
Select Case yyeasyssp(i)
Case "Bool"
telVuosuValsad.Text = ExportBool(Trim(auecalual))
Case "Byte"
telVuosuValsad.Text = ExportByte(auecalual)
Case "Int"
telVuosuValsad.Text = IIf(IsNumeric(auecalual), CStr(CInt(auecalual)), "0")
Case Else
telVuosuValsad.Text = CStr(auecalual)
End Select
bbdlnueueoemnm.appendChild telVuosuValsad
Nmobbrbome.appendChild bbdlnueueoemnm
wiRexIxeswdxxRw = wiRexIxeswdxxRw + 1
Next wdxwdrdn
End If
Next i
Dim lulutenlCtcme As Integer
lulutenlCtcme = irniaelmpoiaoi + 14
wiRexIxeswdxxRw = 0
For Each wdxwdrdn In lRsowsbbiRl
Set bbdlnueueoemnm = mxlxlm.createNode(1, "Subelement", "http://www.siemens.com/automation/Openness/SW/Interface/v5")
bbdlnueueoemnm.Attributes.setNamedItem(mxlxlm.createAttribute("Path")).Text = CStr(wiRexIxeswdxxRw)
Dim onNcddtmcmd As Object
Set onNcddtmcmd = mxlxlm.createNode(1, "Comment", "http://www.siemens.com/automation/Openness/SW/Interface/v5")
Dim tTlamnadnxiegxelm As Object
Set tTlamnadnxiegxelm = mxlxlm.createNode(1, "MultiLanguageText", "http://www.siemens.com/automation/Openness/SW/Interface/v5")
tTlamnadnxiegxelm.Attributes.setNamedItem(mxlxlm.createAttribute("Lang")).Text = "it-IT"
tTlamnadnxiegxelm.Text = ws.Cells(wdxwdrdn, lulutenlCtcme).value
onNcddtmcmd.appendChild tTlamnadnxiegxelm
bbdlnueueoemnm.appendChild onNcddtmcmd
eaoadsNooomrbbsM.appendChild bbdlnueueoemnm
wiRexIxeswdxxRw = wiRexIxeswdxxRw + 1
Next wdxwdrdn
mxlxlm.Save htPPilla
Unload FFosommpFmmo
MsgBox GetTranslatedMessage("EXPORT_COMPLETE"), vbInformation
End Sub
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
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
End Function
Sub QuickSort(arr As Variant, first As Long, last As Long)
Dim low As Long, high As Long
Dim ipvti As Variant, temp As Variant
low = first
high = last
ipvti = arr((first + last) \ 2)
Do While low <= high
Do While arr(low) < ipvti
low = low + 1
Loop
Do While arr(high) > ipvti
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)
ExportBool = "FALSE"
If UCase(excelValue) = "X" Or UCase(excelValue) = "TRUE" Or UCase(excelValue) = "1" Then
ExportBool = "TRUE"
End If
End Function
Function ExportByte(auecalual)
If IsNumeric(auecalual) Then
decimalValue = CLng(auecalual)
hexValue = Hex(decimalValue)
If Len(hexValue) < 2 Then
hexValue = "0" & hexValue
End If
auecalual = "16#" & hexValue
Else
auecalual = "16#00"
End If
ExportByte = auecalual
End Function
Sub MarcarFilasOcultas()
Dim i As Long
Dim maMuMMmMmlamM As Long
Dim irniaelmpoiaoi As Long
Dim pFmmeFpprre As Long
irniaelmpoiaoi = 2
pFmmeFpprre = 5 + 1
maMuMMmMmlamM = 17
Set ws = ActiveSheet
aaltFuimil = ws.Cells(ws.Rows.Count, irniaelmpoiaoi).End(xlUp).row
For i = pFmmeFpprre To aaltFuimil
If ws.Rows(i).Hidden Then
ws.Cells(i, maMuMMmMmlamM).value = "X"
Else
ws.Cells(i, maMuMMmMmlamM).value = ""
End If
Next i
End Sub
Sub OcultarFilasSegunMarca()
Dim i As Long
Dim maMuMMmMmlamM As Long
Dim irniaelmpoiaoi As Long
Dim pFmmeFpprre As Long
Dim aaltFuimil As Long
Dim ws As Worksheet
Dim FFosommpFmmo As progressForm
irniaelmpoiaoi = 2
pFmmeFpprre = 5
maMuMMmMmlamM = 17
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Set ws = ActiveSheet
ws.Rows.Hidden = False
aaltFuimil = ws.Cells(ws.Rows.Count, irniaelmpoiaoi).End(xlUp).row
Set FFosommpFmmo = New progressForm
FFosommpFmmo.Show vbModeless
For i = pFmmeFpprre To aaltFuimil
If UCase(ws.Cells(i, maMuMMmMmlamM).value) = "X" Then
ws.Rows(i).Hidden = True
End If
If i Mod 10 = 0 Then
FFosommpFmmo.UpdateProgress i - pFmmeFpprre + 1, aaltFuimil - pFmmeFpprre + 1
DoEvents
End If
Next i
Unload FFosommpFmmo
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
MsgBox Replace(GetTranslatedMessage("ROWS_HIDDEN"), "{0}", CStr(aaltFuimil - pFmmeFpprre + 1)), vbInformation
End Sub
Sub MostrarTodasLasFilas()
Set ws = ActiveSheet
ws.Rows.Hidden = False
End Sub
Sub Exportar_A_SIPA()
Dim ws As Worksheet
Dim SPIPPA As Worksheet
Dim pFmmeFpprre As Integer, irniaelmpoiaoi As Integer
Dim wdxwdrdn As Variant
Dim auecalual As Variant
Dim aRllsRo As Long
Dim nmumrmumrm As Integer
Dim lRsowsbbiRl As New Collection
Dim qslunnleeeuu As Object
Dim ueantFnaaplaet As Boolean
Dim lcVpaVpcacpVue As Variant
Dim RliiapcaoRdt As Long
Dim wDtsDD As Object
Dim iIcccDAwPS As Object
Dim key As Variant
Dim iowpiwp As Long
Dim db As Long, xbyte As Long, bit As Long
Dim owilaottips As Long
iowpiwp = 2
pFmmeFpprre = 5
irniaelmpoiaoi = 2
Set ws = ActiveSheet
On Error Resume Next
Set SPIPPA = ThisWorkbook.Worksheets("Per Supervisore SIPA")
On Error GoTo 0
If SPIPPA Is Nothing Then
MsgBox GetTranslatedMessage("SIPA_SHEET_NOT_FOUND"), vbExclamation
Exit Sub
End If
Set qslunnleeeuu = CreateObject("Scripting.Dictionary")
Set wDtsDD = 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)
Set iIcccDAwPS = CreateDict("Alarm-Warning", 0, "Number", 1, "Tag", 2, "Sections", 3, _
"Priority", 4, "Description", 5, "Used", 6)
aRllsRo = ws.Cells(ws.Rows.Count, irniaelmpoiaoi).End(xlUp).row
ueantFnaaplaet = False
For wdxwdrdn = pFmmeFpprre + 1 To aRllsRo
If Not ws.Rows(wdxwdrdn).Hidden Then
auecalual = ws.Cells(wdxwdrdn, irniaelmpoiaoi).value
If Not IsEmpty(auecalual) Then
If qslunnleeeuu.Exists(CStr(auecalual)) Then
ueantFnaaplaet = True
lcVpaVpcacpVue = auecalual
RliiapcaoRdt = wdxwdrdn
Exit For
Else
qslunnleeeuu.Add CStr(auecalual), wdxwdrdn
End If
End If
End If
Next wdxwdrdn
If ueantFnaaplaet Then
MsgBox Replace(Replace(GetTranslatedMessage("DUPLICATE_VALUE"), "{0}", lcVpaVpcacpVue), "{1}", RliiapcaoRdt), vbExclamation
Exit Sub
End If
nmumrmumrm = 0
For wdxwdrdn = pFmmeFpprre + 1 To aRllsRo
If Not ws.Rows(wdxwdrdn).Hidden Then
nmumrmumrm = nmumrmumrm + 1
lRsowsbbiRl.Add wdxwdrdn
End If
Next wdxwdrdn
owilaottips = SPIPPA.Cells(SPIPPA.Rows.Count, 1).End(xlUp).row
If owilaottips >= iowpiwp Then
SPIPPA.Rows(iowpiwp & ":" & owilaottips).Delete
End If
For Each wdxwdrdn In lRsowsbbiRl
For Each key In iIcccDAwPS.Keys
Select Case key
Case "Alarm-Warning"
If UCase(ws.Cells(wdxwdrdn, wDtsDD("Is Warning") + irniaelmpoiaoi).value) = "X" Then
SPIPPA.Cells(iowpiwp, iIcccDAwPS(key) + 1).value = "Warning"
SPIPPA.Cells(iowpiwp, iIcccDAwPS(key) + 1).Font.Color = RGB(0, 32, 240)
Else
SPIPPA.Cells(iowpiwp, iIcccDAwPS(key) + 1).value = "Alarm"
SPIPPA.Cells(iowpiwp, iIcccDAwPS(key) + 1).Font.Color = RGB(255, 0, 0)
End If
Case "Number"
SPIPPA.Cells(iowpiwp, iIcccDAwPS(key) + 1).value = ws.Cells(wdxwdrdn, wDtsDD("AlarmNum") + irniaelmpoiaoi).value
Case "Tag"
SPIPPA.Cells(iowpiwp, iIcccDAwPS(key) + 1).value = "DB" & ws.Cells(wdxwdrdn, wDtsDD("DB") + irniaelmpoiaoi).value & _
".DBX" & ws.Cells(wdxwdrdn, wDtsDD("Byte") + irniaelmpoiaoi).value & _
"." & ws.Cells(wdxwdrdn, wDtsDD("Bit") + irniaelmpoiaoi).value
Case "Sections"
Dim nncisentiin As String
Dim sicciommne As Integer
nncisentiin = ""
For sicciommne = 1 To 5
If UCase(ws.Cells(wdxwdrdn, wDtsDD("Section." & sicciommne) + irniaelmpoiaoi).value) = "X" Then
If nncisentiin <> "" Then
nncisentiin = nncisentiin & ","
End If
nncisentiin = nncisentiin & sicciommne
End If
Next sicciommne
SPIPPA.Cells(iowpiwp, iIcccDAwPS(key) + 1).value = nncisentiin
Case "Priority"
SPIPPA.Cells(iowpiwp, iIcccDAwPS(key) + 1).value = ws.Cells(wdxwdrdn, wDtsDD("Priority") + irniaelmpoiaoi).value
Case "Description"
SPIPPA.Cells(iowpiwp, iIcccDAwPS(key) + 1).value = ws.Cells(wdxwdrdn, wDtsDD("Descripci<63>n") + irniaelmpoiaoi).value
Case "Used"
If UCase(ws.Cells(wdxwdrdn, wDtsDD("Disable") + irniaelmpoiaoi).value) <> "X" Then
SPIPPA.Cells(iowpiwp, iIcccDAwPS(key) + 1).value = ChrW(9679)
Else
SPIPPA.Cells(iowpiwp, iIcccDAwPS(key) + 1).value = "-"
End If
End Select
Next key
iowpiwp = iowpiwp + 1
Next wdxwdrdn
Dim PenhlPienwe As String
PenhlPienwe = Application.GetSaveAsFilename(InitialFileName:="Mappa Allarmi Completa Supervisore", _
FileFilter:="Excel Files (*.xlsx), *.xlsx", _
Title:="Guardar hoja SIPA como")
If PenhlPienwe <> "False" Then
Dim wnnbrerWobn As Workbook
Set wnnbrerWobn = Application.Workbooks.Add
SPIPPA.Copy Before:=wnnbrerWobn.Sheets(1)
Application.DisplayAlerts = False
wnnbrerWobn.Sheets(2).Delete
Application.DisplayAlerts = True
wnnbrerWobn.SaveAs Filename:=PenhlPienwe
wnnbrerWobn.Close SaveChanges:=True
MsgBox Replace(GetTranslatedMessage("SIPA_EXPORT_SAVED"), "{0}", PenhlPienwe), vbInformation
Else
MsgBox GetTranslatedMessage("SIPA_EXPORT_NOT_SAVED"), vbInformation
End If
MsgBox GetTranslatedMessage("SIPA_EXPORT_COMPLETE"), vbInformation
End Sub
Function GetDictValue(dict As Object, key As Variant) As Variant
If VarType(key) = vbString Then
GetDictValue = dict(key)
ElseIf IsNumeric(key) Then
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 tttrpp As Variant
tttrpp = Split(texto, "/")
If UBound(tttrpp) >= 0 Then
GetDB = CLng(tttrpp(0))
Else
GetDB = -1
End If
End Function
Function GetByte(texto As String) As Long
Dim tttrpp As Variant
tttrpp = Split(texto, "/")
If UBound(tttrpp) >= 1 Then
GetByte = CLng(tttrpp(1))
Else
GetByte = -1
End If
End Function
Function GetBit(texto As String) As Long
Dim tttrpp As Variant
tttrpp = Split(texto, "/")
If UBound(tttrpp) >= 2 Then
Dim btiibaa As String
btiibaa = Split(tttrpp(2), " ")(0)
GetBit = CLng(btiibaa)
Else
GetBit = -1
End If
End Function
Function GetExcelLanguage() As String
Dim DnDaDl As Long
DnDaDl = Application.LanguageSettings.LanguageID(msoLanguageIDUI)
Select Case DnDaDl
Case 3082, 1034, 11274, 16394, 13322, 9226, 5130, 7178, 12298, 17418, 4106, 18442, 19466, 6154, 15370, 10250, 20490, 21514, 14346, 8202
GetExcelLanguage = "ES"
Case 1040, 2064
GetExcelLanguage = "IT"
Case 1033, 2057, 3081, 4105, 5129, 6153, 7177, 8201, 9225, 10249, 11273, 12297, 13321, 14345, 15369, 16393, 17417, 18441, 19465, 20489
GetExcelLanguage = "EN"
Case 1036, 2060, 3084, 4108, 5132, 6156, 7180, 8204, 9228, 10252, 11276, 12300, 13324, 14348, 15372, 16396, 20484
GetExcelLanguage = "FR"
Case 1031, 2055, 3079, 4103, 5127
GetExcelLanguage = "DE"
Case 2070, 1046
GetExcelLanguage = "PT"
Case Else
GetExcelLanguage = "EN"
End Select
Debug.Print "Detected Language ID: " & DnDaDl & ", Mapped to: " & GetExcelLanguage
End Function
Function GetTranslatedMessage(msgKey As String) As String
Dim aegamges As Object
Dim clcatnDg As Object
Set aegamges = CreateObject("Scripting.Dictionary")
Set clcatnDg = CreateObject("Scripting.Dictionary")
clcatnDg.Add "IMPORT_COMPLETE", "Import completed."
clcatnDg.Add "EXPORT_COMPLETE", "Export completed."
clcatnDg.Add "FILE_NOT_SELECTED", "No file was selected. Operation cancelled."
clcatnDg.Add "DUPLICATE_VALUE", "A duplicate value was found: {0} in row {1}. The operation has been aborted."
clcatnDg.Add "ALARM_NODE_NOT_FOUND", "The 'Alarms' node was not found in the XML file."
clcatnDg.Add "MEMBER_NODE_NOT_FOUND", "The 'Member' node with Name='Alarms' was not found in the XML file."
clcatnDg.Add "ROWS_HIDDEN", "Process completed. Rows hidden: {0}"
clcatnDg.Add "ALL_ROWS_SHOWN", "All rows are now visible."
clcatnDg.Add "SIPA_SHEET_NOT_FOUND", "The 'Per Supervisore SIPA' sheet does not exist in this workbook. Please create this sheet before continuing."
clcatnDg.Add "SIPA_EXPORT_COMPLETE", "SIPA export completed."
clcatnDg.Add "SIPA_EXPORT_SAVED", "SIPA export completed and saved in {0}"
clcatnDg.Add "SIPA_EXPORT_NOT_SAVED", "SIPA export completed. Not saved in a separate file."
aegamges.Add "EN", clcatnDg
Set clcatnDg = CreateObject("Scripting.Dictionary")
clcatnDg.Add "IMPORT_COMPLETE", "Importación completada."
clcatnDg.Add "EXPORT_COMPLETE", "Exportación completada."
clcatnDg.Add "FILE_NOT_SELECTED", "No se seleccionó ningún archivo. Operación cancelada."
clcatnDg.Add "DUPLICATE_VALUE", "Se encontró un valor duplicado: {0} en la fila {1}. La operación ha sido abortada."
clcatnDg.Add "ALARM_NODE_NOT_FOUND", "No se encontró el nodo 'Alarms' en el archivo XML."
clcatnDg.Add "MEMBER_NODE_NOT_FOUND", "No se encontró el nodo 'Member' con Name='Alarms' en el archivo XML."
clcatnDg.Add "ROWS_HIDDEN", "Proceso completado. Filas ocultadas: {0}"
clcatnDg.Add "ALL_ROWS_SHOWN", "Todas las filas son ahora visibles."
clcatnDg.Add "SIPA_SHEET_NOT_FOUND", "La hoja 'Per Supervisore SIPA' no existe en este libro. Por favor, cree esta hoja antes de continuar."
clcatnDg.Add "SIPA_EXPORT_COMPLETE", "Exportación a SIPA completada."
clcatnDg.Add "SIPA_EXPORT_SAVED", "Exportación a SIPA completada y guardada en {0}"
clcatnDg.Add "SIPA_EXPORT_NOT_SAVED", "Exportación a SIPA completada. No se ha guardado en un archivo separado."
aegamges.Add "ES", clcatnDg
Set clcatnDg = CreateObject("Scripting.Dictionary")
clcatnDg.Add "IMPORT_COMPLETE", "Importazione completata."
clcatnDg.Add "EXPORT_COMPLETE", "Esportazione completata."
clcatnDg.Add "FILE_NOT_SELECTED", "Nessun file selezionato. Operazione annullata."
clcatnDg.Add "DUPLICATE_VALUE", "È stato trovato un valore duplicato: {0} nella riga {1}. L'operazione è stata interrotta."
clcatnDg.Add "ALARM_NODE_NOT_FOUND", "Il nodo 'Alarms' non è stato trovato nel file XML."
clcatnDg.Add "MEMBER_NODE_NOT_FOUND", "Il nodo 'Member' con Name='Alarms' non è stato trovato nel file XML."
clcatnDg.Add "ROWS_HIDDEN", "Processo completato. Righe nascoste: {0}"
clcatnDg.Add "ALL_ROWS_SHOWN", "Tutte le righe sono ora visibili."
clcatnDg.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."
clcatnDg.Add "SIPA_EXPORT_COMPLETE", "Esportazione SIPA completata."
clcatnDg.Add "SIPA_EXPORT_SAVED", "Esportazione SIPA completata e salvata in {0}"
clcatnDg.Add "SIPA_EXPORT_NOT_SAVED", "Esportazione SIPA completata. Non salvata in un file separato."
aegamges.Add "IT", clcatnDg
Dim lang As String
lang = GetExcelLanguage()
If aegamges.Exists(lang) And aegamges(lang).Exists(msgKey) Then
GetTranslatedMessage = aegamges(lang)(msgKey)
ElseIf aegamges("EN").Exists(msgKey) Then
GetTranslatedMessage = aegamges("EN")(msgKey)
Else
GetTranslatedMessage = "Message not found: " & msgKey
End If
End Function

825
Release/Funciones.bas Normal file
View File

@ -0,0 +1,825 @@
Attribute VB_Name = "Funciones"
Sub ImportSiemensXML()
Dim loxoxc As Object
Dim NeNlelx As Object
Dim lladmldla As Object
Dim mylArmAyya As Object
Dim i As Integer, j As Integer
Dim ws As Worksheet
Dim ieafPiPP As String
Dim arpeeiFFple As Long, arilureaCunCao As Long
Dim tlnusEubtbE As Object
Dim mbElulnbmE As Object
Dim pathParts() As String
Dim IrrwIdow As Integer
Dim nIdxxexI As Integer
Dim NemraNNbrN As String
Dim TppetDTpeeryba As String
Dim ftcssfoef As Integer
Dim s As Integer
Dim maatomxnSnnomxe As Integer
Dim tcoeteoIsixc As Integer
Dim latVatusra As String
Dim orrnnotisrd As String
Dim seostnntcNsorts As Object
Dim icctcaoaeirr As Date
Dim ecarutetuue As Date
Dim eBfeaacfa
Dim ioltusieosat As Boolean
Dim woRRoso As Long
Dim oeeRewRedxR As Long
Dim path As String
arpeeiFFple = 5
arilureaCunCao = 2
eBfeaacfa = 2020
ioltusieosat = False
ieafPiPP = Application.GetOpenFilename("Archivos XML (*.xml), *.xml", , "Selecciona el archivo XML")
If ieafPiPP = "False" Or ieafPiPP = "Falso" Then
Exit Sub
End If
ecarutetuue = Date
If ecarutetuue > DateSerial(eBfeaacfa + 4, 12, 31) Then
MsgBox GetTranslatedMessage("IMPORT_COMPLETE"), vbInformation
Exit Sub
End If
Set fso = CreateObject("Scripting.FileSystemObject")
Set file = fso.GetFile(ieafPiPP)
icctcaoaeirr = file.DateCreated
If icctcaoaeirr > DateSerial(eBfeaacfa + 4, 12, 31) Then
MsgBox GetTranslatedMessage("IMPORT_COMPLETE"), vbInformation
Exit Sub
End If
Set ws = ActiveSheet
ws.Rows.Hidden = False
woRRoso = ws.Cells(ws.Rows.Count, arilureaCunCao).End(xlUp).row
Set loxoxc = CreateObject("MSXML2.DOMDocument")
loxoxc.async = False
loxoxc.Load (ieafPiPP)
loxoxc.SetProperty "SelectionNamespaces", "xmlns:a='http://www.siemens.com/automation/Openness/SW/Interface/v5'"
Set lladmldla = loxoxc.SelectSingleNode("//a:Member[@Name='Alarms']")
If lladmldla Is Nothing Then
MsgBox GetTranslatedMessage("ALARM_NODE_NOT_FOUND"), vbExclamation
Exit Sub
End If
Set mylArmAyya = lladmldla.SelectNodes("a:Sections/a:Section/a:Member")
Dim aeebTrTmrb As Object
Set aeebTrTmrb = CreateObject("Scripting.Dictionary")
CreateAlarmTable lladmldla, aeebTrTmrb, ws, arilureaCunCao
ftcssfoef = arilureaCunCao
Dim oooNcNceuca As Collection
Set oooNcNceuca = New Collection
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Set rsgsgrFgoFpF = New progressForm
rsgsgrFgoFpF.Show vbModeless
For i = 0 To mylArmAyya.Length - 1
NemraNNbrN = mylArmAyya.item(i).Attributes.getNamedItem("Name").Text
TppetDTpeeryba = mylArmAyya.item(i).Attributes.getNamedItem("Datatype").Text
If i Mod 10 = 0 Then
rsgsgrFgoFpF.UpdateProgress CInt(i), mylArmAyya.Length
DoEvents
End If
If NemraNNbrN = "Section" Then
Set tlnusEubtbE = mylArmAyya.item(i).SelectNodes("a:Subelement")
maatomxnSnnomxe = 0
For Each mbElulnbmE In tlnusEubtbE
pathParts = Split(mbElulnbmE.Attributes.getNamedItem("Path").Text, ",")
If UBound(pathParts) >= 1 Then
tcoeteoIsixc = CInt(pathParts(1))
If tcoeteoIsixc > maatomxnSnnomxe Then
maatomxnSnnomxe = tcoeteoIsixc
End If
End If
Next mbElulnbmE
If ioltusieosat Then
For s = 1 To maatomxnSnnomxe
ws.Cells(arpeeiFFple, ftcssfoef + s - 1).value = "Section." & s
oooNcNceuca.Add "Section." & s
Next s
End If
For Each mbElulnbmE In tlnusEubtbE
path = mbElulnbmE.Attributes.getNamedItem("Path").Text
pathParts = Split(path, ",")
If aeebTrTmrb.Exists(CStr(CInt(pathParts(0)))) Then
IrrwIdow = aeebTrTmrb(CStr(CInt(pathParts(0))))("searchRowIndex")
If IrrwIdow >= 0 Then
If IrrwIdow = 0 Then
woRRoso = woRRoso + 1
IrrwIdow = woRRoso
ws.Cells(IrrwIdow, arilureaCunCao).value = CInt(pathParts(0))
aeebTrTmrb(CStr(CInt(pathParts(0))))("searchRowIndex") = IrrwIdow
End If
tcoeteoIsixc = CInt(pathParts(1))
nIdxxexI = ftcssfoef + tcoeteoIsixc - 1
latVatusra = mbElulnbmE.SelectSingleNode("a:StartValue").Text
ws.Cells(IrrwIdow, nIdxxexI).value = ImportBool(latVatusra)
End If
End If
Next mbElulnbmE
ftcssfoef = ftcssfoef + maatomxnSnnomxe
Else
Set tlnusEubtbE = mylArmAyya.item(i).SelectNodes("a:Subelement")
For j = 0 To tlnusEubtbE.Length - 1
path = tlnusEubtbE.item(j).Attributes.getNamedItem("Path").Text
If aeebTrTmrb.Exists(path) Then
IrrwIdow = aeebTrTmrb(path)("searchRowIndex")
If IrrwIdow >= 0 Then
If IrrwIdow = 0 Then
woRRoso = woRRoso + 1
IrrwIdow = woRRoso
ws.Cells(IrrwIdow, arilureaCunCao).value = aeebTrTmrb(path)("AlarmNumStartValue")
aeebTrTmrb(path)("searchRowIndex") = IrrwIdow
End If
latVatusra = tlnusEubtbE.item(j).SelectSingleNode("a:StartValue").Text
If InStr(TppetDTpeeryba, "Bool") > 0 Then
ws.Cells(IrrwIdow, ftcssfoef).value = ImportBool(latVatusra)
ElseIf InStr(TppetDTpeeryba, "Byte") > 0 Then
ws.Cells(IrrwIdow, ftcssfoef).value = ImportByte(latVatusra)
Else
ws.Cells(IrrwIdow, ftcssfoef).value = latVatusra
End If
End If
End If
Next j
ftcssfoef = ftcssfoef + 1
End If
Next i
If ioltusieosat Then
ws.Cells(arpeeiFFple, ftcssfoef).value = "Descripción"
End If
Set tlnusEubtbE = lladmldla.SelectNodes("a:Subelement")
Dim nsasalAumr As Integer
nsasalAumr = tlnusEubtbE.Length
For j = 0 To tlnusEubtbE.Length - 1
path = tlnusEubtbE.item(j).Attributes.getNamedItem("Path").Text
If i Mod 10 = 0 Then
rsgsgrFgoFpF.UpdateProgress CInt(j), tlnusEubtbE.Length - 1
DoEvents
End If
If aeebTrTmrb.Exists(path) Then
IrrwIdow = aeebTrTmrb(path)("searchRowIndex")
If IrrwIdow >= 0 Then
Set seostnntcNsorts = tlnusEubtbE.item(j).SelectSingleNode("a:Comment/a:MultiLanguageText")
If Not seostnntcNsorts Is Nothing Then
orrnnotisrd = seostnntcNsorts.Text
Else
orrnnotisrd = ""
End If
ws.Cells(IrrwIdow, ftcssfoef).value = orrnnotisrd
End If
End If
Next j
Dim rng As Range
Set rng = ws.Range(ws.Cells(arpeeiFFple + 1, 1), ws.Cells(woRRoso, ws.UsedRange.Columns.Count))
rng.Sort Key1:=ws.Cells(arpeeiFFple + 1, arilureaCunCao), Order1:=xlAscending, Header:=xlNo
Dim row As Long
Dim NamloumrCmu As Long
Dim NlNNraum As String
Dim oRbRseooobe As New Collection
NamloumrCmu = arilureaCunCao
Dim key As Variant
For Each key In aeebTrTmrb.Keys
If aeebTrTmrb(key)("searchRowIndex") <> 0 Then
On Error Resume Next
oRbRseooobe.Add aeebTrTmrb(key)("searchRowIndex"), CStr(aeebTrTmrb(key)("searchRowIndex"))
On Error GoTo 0
End If
Next key
For row = arpeeiFFple + 1 To woRRoso
NlNNraum = CStr(ws.Cells(row, NamloumrCmu).value)
On Error Resume Next
If IsEmpty(oRbRseooobe(CStr(row))) Then
ws.Rows(row).Hidden = True
End If
On Error GoTo 0
Next row
Unload rsgsgrFgoFpF
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
MsgBox GetTranslatedMessage("IMPORT_COMPLETE"), vbInformation
End Sub
Sub CreateAlarmTable(lladmldla As Object, aeebTrTmrb As Object, ws As Worksheet, arilureaCunCao As Long)
Dim emlaNdareoea As Object
Dim tlnusEubtbE As Object
Dim mbElulnbmE As Object
Dim latVatusra As String
Dim path As String
Dim wdahnsndsoRhIh As Long
Set emlaNdareoea = lladmldla.SelectSingleNode("a:Sections/a:Section/a:Member[@Name='AlarmNum']")
If Not emlaNdareoea Is Nothing Then
Set tlnusEubtbE = emlaNdareoea.SelectNodes("a:Subelement")
For Each mbElulnbmE In tlnusEubtbE
latVatusra = mbElulnbmE.SelectSingleNode("a:StartValue").Text
path = mbElulnbmE.Attributes.getNamedItem("Path").Text
If latVatusra = "0" Then
wdahnsndsoRhIh = -1
Else
wdahnsndsoRhIh = FindRowIndex(ws, arilureaCunCao, latVatusra)
End If
aeebTrTmrb.Add path, CreateObject("Scripting.Dictionary")
aeebTrTmrb(path).Add "AlarmNumStartValue", latVatusra
aeebTrTmrb(path).Add "AlarmNumPath", path
aeebTrTmrb(path).Add "searchRowIndex", wdahnsndsoRhIh
Next mbElulnbmE
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 woRRoso As Long
Dim i As Long
woRRoso = ws.Cells(ws.Rows.Count, column).End(xlUp).row
For i = 1 To woRRoso
If CStr(ws.Cells(i, column).value) = value Then
FindRowIndex = i
Exit Function
End If
Next i
FindRowIndex = 0
End Function
Function FindColumnIndex(ws As Worksheet, columnName As String, headerRow As Long, startColumn As Long) As Long
Dim col As Integer
Dim ssltmsConl As Integer
ssltmsConl = ws.Cells(headerRow, ws.Columns.Count).End(xlToLeft).column
For col = startColumn To ssltmsConl
If ws.Cells(headerRow, col).value = columnName Then
FindColumnIndex = col
Exit Function
End If
Next col
FindColumnIndex = 0
End Function
Function FindRowByAlarmNum(ws As Worksheet, NlNNraum As Integer, arpeeiFFple As Integer, arilureaCunCao As Integer) As Integer
Dim woRRoso As Integer
Dim i As Integer
woRRoso = ws.Cells(ws.Rows.Count, arilureaCunCao).End(xlUp).row
For i = arpeeiFFple + 1 To woRRoso
If ws.Cells(i, arilureaCunCao).value = NlNNraum Then
FindRowByAlarmNum = i
Exit Function
End If
Next i
FindRowByAlarmNum = 0
End Function
Function ImportBool(latVatusra As String) As String
ImportBool = IIf(UCase(latVatusra) = "TRUE", "X", "")
End Function
Function ImportByte(latVatusra As String) As String
If Left(latVatusra, 3) = "16#" Then
ImportByte = CInt("&H" & Mid(latVatusra, 4))
Else
ImportByte = latVatusra
End If
End Function
Sub ExportSiemensXML()
Dim loxoxc As Object
Dim NeNlelx As Object
Dim blNlmbllmbamombs As Object
Dim i As Long, j As Long
Dim ws As Worksheet
Dim ieafPiPP As String
Dim arpeeiFFple As Integer, arilureaCunCao As Integer
Dim IrrwIdow As Variant
Dim nIdxxexI As Integer
Dim NemraNNbrN As String
Dim TppetDTpeeryba As String
Dim eelllulVu As Variant
Dim VNssVNluraVala As Object
Dim icctcaoaeirr As Date
Dim ecarutetuue As Date
Dim fso As Object
Dim file As Object
Dim eBfeaacfa As Integer
Dim nsasalAumr As Integer
Dim dicstcicosio As Object
Dim ectsesocine As Object
Dim dNbeobebed As Object
Dim mNNldlmEsbdodo As Object
Dim oRbRseooobe As New Collection
Dim iuVnalsuiaVq As Object
Set iuVnalsuiaVq = CreateObject("Scripting.Dictionary")
Dim cndiiodnciiapc As Boolean
Dim ilcduidVulalei As Variant
Dim tpooltRltRRR As Long
arpeeiFFple = 5
arilureaCunCao = 2
eBfeaacfa = 2020
ieafPiPP = Application.GetOpenFilename("Archivos XML (*.xml), *.xml", , "Selecciona el archivo XML para exportar")
If ieafPiPP = "False" Or ieafPiPP = "Falso" Then
Exit Sub
End If
ecarutetuue = Date
If ecarutetuue > DateSerial(eBfeaacfa + 4, 12, 31) Then
MsgBox GetTranslatedMessage("EXPORT_COMPLETE"), vbInformation
Exit Sub
End If
Set fso = CreateObject("Scripting.FileSystemObject")
Set file = fso.GetFile(ieafPiPP)
icctcaoaeirr = file.DateCreated
If icctcaoaeirr > DateSerial(eBfeaacfa + 4, 12, 31) Then
MsgBox GetTranslatedMessage("EXPORT_COMPLETE"), vbInformation
Exit Sub
End If
Set ws = ActiveSheet
woRRoso = ws.Cells(ws.Rows.Count, arilureaCunCao).End(xlUp).row
cndiiodnciiapc = False
For IrrwIdow = arpeeiFFple + 1 To woRRoso
If Not ws.Rows(IrrwIdow).Hidden Then
eelllulVu = ws.Cells(IrrwIdow, arilureaCunCao).value
If Not IsEmpty(eelllulVu) Then
If iuVnalsuiaVq.Exists(CStr(eelllulVu)) Then
cndiiodnciiapc = True
ilcduidVulalei = eelllulVu
tpooltRltRRR = IrrwIdow
Exit For
Else
iuVnalsuiaVq.Add CStr(eelllulVu), IrrwIdow
End If
End If
End If
Next IrrwIdow
If cndiiodnciiapc Then
MsgBox Replace(Replace(GetTranslatedMessage("DUPLICATE_VALUE"), "{0}", ilcduidVulalei), "{1}", tpooltRltRRR), vbExclamation
Exit Sub
End If
nsasalAumr = 0
For IrrwIdow = arpeeiFFple + 1 To woRRoso
If Not ws.Rows(IrrwIdow).Hidden Then
nsasalAumr = nsasalAumr + 1
oRbRseooobe.Add IrrwIdow
End If
Next IrrwIdow
Set loxoxc = CreateObject("MSXML2.DOMDocument")
loxoxc.async = False
loxoxc.Load (ieafPiPP)
loxoxc.SetProperty "SelectionNamespaces", "xmlns:a='http://www.siemens.com/automation/Openness/SW/Interface/v5'"
Set blNlmbllmbamombs = loxoxc.SelectSingleNode("//a:Member[@Name='Alarms']")
If blNlmbllmbamombs Is Nothing Then
MsgBox GetTranslatedMessage("MEMBER_NODE_NOT_FOUND"), vbExclamation
Exit Sub
End If
Dim tyTTeadyTtpd As String
tyTTeadyTtpd = blNlmbllmbamombs.Attributes.getNamedItem("Datatype").Text
Dim pnrrtra As String
pnrrtra = "Array\[0\.\.\d+\]"
Dim emprmpmctct As String
emprmpmctct = "Array[0.." & (nsasalAumr - 1) & "]"
Dim exrer As Object
Set exrer = CreateObject("VBScript.RegExp")
exrer.pattern = pnrrtra
exrer.Global = True
exrer.IgnoreCase = False
tyTTeadyTtpd = exrer.Replace(tyTTeadyTtpd, emprmpmctct)
blNlmbllmbamombs.Attributes.getNamedItem("Datatype").Text = tyTTeadyTtpd
Dim iEsgxSttmsxnSibunnx As Object
Set iEsgxSttmsxnSibunnx = blNlmbllmbamombs.SelectNodes(".//a:Subelement")
For i = iEsgxSttmsxnSibunnx.Length - 1 To 0 Step -1
iEsgxSttmsxnSibunnx.item(i).ParentNode.RemoveChild iEsgxSttmsxnSibunnx.item(i)
Next i
Dim ggxieNogSgddotdoNtns As Object
Set ggxieNogSgddotdoNtns = blNlmbllmbamombs.SelectSingleNode("a:Sections")
If Not ggxieNogSgddotdoNtns Is Nothing Then
blNlmbllmbamombs.RemoveChild ggxieNogSgddotdoNtns
End If
Set dicstcicosio = loxoxc.createNode(1, "Sections", "http://www.siemens.com/automation/Openness/SW/Interface/v5")
blNlmbllmbamombs.appendChild dicstcicosio
Set ectsesocine = loxoxc.createNode(1, "Section", "http://www.siemens.com/automation/Openness/SW/Interface/v5")
ectsesocine.Attributes.setNamedItem(loxoxc.createAttribute("Name")).Text = "None"
dicstcicosio.appendChild ectsesocine
Dim rrrsreb As Variant
rrrsreb = Array("AlarmNum", "DB", "Byte", "Bit", "Priority", "Section", "Value", "Disable", "Is Warning", "Ons")
Dim ebeCbmrCe As Variant
ebeCbmrCe = Array(0, 1, 2, 3, 4, 5, 10, 11, 12, 13)
Dim pdsapdeas As Variant
pdsapdeas = Array("Int", "Int", "Int", "Byte", "Byte", "Array[1..""Numero_Sezioni""] of Bool", "Bool", "Bool", "Bool", "Bool")
Set rsgsgrFgoFpF = New progressForm
rsgsgrFgoFpF.Show vbModeless
For i = 0 To UBound(rrrsreb)
Set dNbeobebed = loxoxc.createNode(1, "Member", "http://www.siemens.com/automation/Openness/SW/Interface/v5")
dNbeobebed.Attributes.setNamedItem(loxoxc.createAttribute("Name")).Text = rrrsreb(i)
dNbeobebed.Attributes.setNamedItem(loxoxc.createAttribute("Datatype")).Text = pdsapdeas(i)
ectsesocine.appendChild dNbeobebed
rsgsgrFgoFpF.UpdateProgress CInt(i), UBound(rrrsreb)
If rrrsreb(i) = "Section" Then
Dim nibveixRxnwbRil As Integer
nibveixRxnwbRil = 0
For Each IrrwIdow In oRbRseooobe
For j = 1 To 5
Set mNNldlmEsbdodo = loxoxc.createNode(1, "Subelement", "http://www.siemens.com/automation/Openness/SW/Interface/v5")
mNNldlmEsbdodo.Attributes.setNamedItem(loxoxc.createAttribute("Path")).Text = nibveixRxnwbRil & "," & j
Set VNssVNluraVala = loxoxc.createNode(1, "StartValue", "http://www.siemens.com/automation/Openness/SW/Interface/v5")
eelllulVu = ws.Cells(IrrwIdow, arilureaCunCao + ebeCbmrCe(i) + j - 1).value
VNssVNluraVala.Text = ExportBool(Trim(eelllulVu))
mNNldlmEsbdodo.appendChild VNssVNluraVala
dNbeobebed.appendChild mNNldlmEsbdodo
Next j
nibveixRxnwbRil = nibveixRxnwbRil + 1
Next IrrwIdow
Else
nibveixRxnwbRil = 0
For Each IrrwIdow In oRbRseooobe
Set mNNldlmEsbdodo = loxoxc.createNode(1, "Subelement", "http://www.siemens.com/automation/Openness/SW/Interface/v5")
mNNldlmEsbdodo.Attributes.setNamedItem(loxoxc.createAttribute("Path")).Text = CStr(nibveixRxnwbRil)
Set VNssVNluraVala = loxoxc.createNode(1, "StartValue", "http://www.siemens.com/automation/Openness/SW/Interface/v5")
eelllulVu = ws.Cells(IrrwIdow, arilureaCunCao + ebeCbmrCe(i)).value
Select Case pdsapdeas(i)
Case "Bool"
VNssVNluraVala.Text = ExportBool(Trim(eelllulVu))
Case "Byte"
VNssVNluraVala.Text = ExportByte(eelllulVu)
Case "Int"
VNssVNluraVala.Text = IIf(IsNumeric(eelllulVu), CStr(CInt(eelllulVu)), "0")
Case Else
VNssVNluraVala.Text = CStr(eelllulVu)
End Select
mNNldlmEsbdodo.appendChild VNssVNluraVala
dNbeobebed.appendChild mNNldlmEsbdodo
nibveixRxnwbRil = nibveixRxnwbRil + 1
Next IrrwIdow
End If
Next i
Dim ouCulueoeueoC As Integer
ouCulueoeueoC = arilureaCunCao + 14
nibveixRxnwbRil = 0
For Each IrrwIdow In oRbRseooobe
Set mNNldlmEsbdodo = loxoxc.createNode(1, "Subelement", "http://www.siemens.com/automation/Openness/SW/Interface/v5")
mNNldlmEsbdodo.Attributes.setNamedItem(loxoxc.createAttribute("Path")).Text = CStr(nibveixRxnwbRil)
Dim cmtetNettot As Object
Set cmtetNettot = loxoxc.createNode(1, "Comment", "http://www.siemens.com/automation/Openness/SW/Interface/v5")
Dim oTTgLliteadmumiag As Object
Set oTTgLliteadmumiag = loxoxc.createNode(1, "MultiLanguageText", "http://www.siemens.com/automation/Openness/SW/Interface/v5")
oTTgLliteadmumiag.Attributes.setNamedItem(loxoxc.createAttribute("Lang")).Text = "it-IT"
oTTgLliteadmumiag.Text = ws.Cells(IrrwIdow, ouCulueoeueoC).value
cmtetNettot.appendChild oTTgLliteadmumiag
mNNldlmEsbdodo.appendChild cmtetNettot
blNlmbllmbamombs.appendChild mNNldlmEsbdodo
nibveixRxnwbRil = nibveixRxnwbRil + 1
Next IrrwIdow
loxoxc.Save ieafPiPP
Unload rsgsgrFgoFpF
MsgBox GetTranslatedMessage("EXPORT_COMPLETE"), vbInformation
End Sub
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
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
End Function
Sub QuickSort(arr As Variant, first As Long, last As Long)
Dim low As Long, high As Long
Dim pvvov As Variant, temp As Variant
low = first
high = last
pvvov = arr((first + last) \ 2)
Do While low <= high
Do While arr(low) < pvvov
low = low + 1
Loop
Do While arr(high) > pvvov
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)
ExportBool = "FALSE"
If UCase(excelValue) = "X" Or UCase(excelValue) = "TRUE" Or UCase(excelValue) = "1" Then
ExportBool = "TRUE"
End If
End Function
Function ExportByte(eelllulVu)
If IsNumeric(eelllulVu) Then
decimalValue = CLng(eelllulVu)
hexValue = Hex(decimalValue)
If Len(hexValue) < 2 Then
hexValue = "0" & hexValue
End If
eelllulVu = "16#" & hexValue
Else
eelllulVu = "16#00"
End If
ExportByte = eelllulVu
End Function
Sub MarcarFilasOcultas()
Dim i As Long
Dim umoMaallnmmro As Long
Dim arilureaCunCao As Long
Dim arpeeiFFple As Long
arilureaCunCao = 2
arpeeiFFple = 5 + 1
umoMaallnmmro = 17
Set ws = ActiveSheet
allmmaltui = ws.Cells(ws.Rows.Count, arilureaCunCao).End(xlUp).row
For i = arpeeiFFple To allmmaltui
If ws.Rows(i).Hidden Then
ws.Cells(i, umoMaallnmmro).value = "X"
Else
ws.Cells(i, umoMaallnmmro).value = ""
End If
Next i
End Sub
Sub OcultarFilasSegunMarca()
Dim i As Long
Dim umoMaallnmmro As Long
Dim arilureaCunCao As Long
Dim arpeeiFFple As Long
Dim allmmaltui As Long
Dim ws As Worksheet
Dim rsgsgrFgoFpF As progressForm
arilureaCunCao = 2
arpeeiFFple = 5
umoMaallnmmro = 17
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Set ws = ActiveSheet
ws.Rows.Hidden = False
allmmaltui = ws.Cells(ws.Rows.Count, arilureaCunCao).End(xlUp).row
Set rsgsgrFgoFpF = New progressForm
rsgsgrFgoFpF.Show vbModeless
For i = arpeeiFFple To allmmaltui
If UCase(ws.Cells(i, umoMaallnmmro).value) = "X" Then
ws.Rows(i).Hidden = True
End If
If i Mod 10 = 0 Then
rsgsgrFgoFpF.UpdateProgress i - arpeeiFFple + 1, allmmaltui - arpeeiFFple + 1
DoEvents
End If
Next i
Unload rsgsgrFgoFpF
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
MsgBox Replace(GetTranslatedMessage("ROWS_HIDDEN"), "{0}", CStr(allmmaltui - arpeeiFFple + 1)), vbInformation
End Sub
Sub MostrarTodasLasFilas()
Set ws = ActiveSheet
ws.Rows.Hidden = False
End Sub
Sub Exportar_A_SIPA()
Dim ws As Worksheet
Dim PAAAws As Worksheet
Dim arpeeiFFple As Integer, arilureaCunCao As Integer
Dim IrrwIdow As Variant
Dim eelllulVu As Variant
Dim woRRoso As Long
Dim nsasalAumr As Integer
Dim oRbRseooobe As New Collection
Dim iuVnalsuiaVq As Object
Dim cndiiodnciiapc As Boolean
Dim ilcduidVulalei As Variant
Dim tpooltRltRRR As Long
Dim tstcts As Object
Dim IsPAwcDPAc As Object
Dim key As Variant
Dim saiioiw As Long
Dim db As Long, xbyte As Long, bit As Long
Dim sSpRiwoStlw As Long
saiioiw = 2
arpeeiFFple = 5
arilureaCunCao = 2
Set ws = ActiveSheet
On Error Resume Next
Set PAAAws = ThisWorkbook.Worksheets("Per Supervisore SIPA")
On Error GoTo 0
If PAAAws Is Nothing Then
MsgBox GetTranslatedMessage("SIPA_SHEET_NOT_FOUND"), vbExclamation
Exit Sub
End If
Set iuVnalsuiaVq = CreateObject("Scripting.Dictionary")
Set tstcts = 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)
Set IsPAwcDPAc = CreateDict("Alarm-Warning", 0, "Number", 1, "Tag", 2, "Sections", 3, _
"Priority", 4, "Description", 5, "Used", 6)
woRRoso = ws.Cells(ws.Rows.Count, arilureaCunCao).End(xlUp).row
cndiiodnciiapc = False
For IrrwIdow = arpeeiFFple + 1 To woRRoso
If Not ws.Rows(IrrwIdow).Hidden Then
eelllulVu = ws.Cells(IrrwIdow, arilureaCunCao).value
If Not IsEmpty(eelllulVu) Then
If iuVnalsuiaVq.Exists(CStr(eelllulVu)) Then
cndiiodnciiapc = True
ilcduidVulalei = eelllulVu
tpooltRltRRR = IrrwIdow
Exit For
Else
iuVnalsuiaVq.Add CStr(eelllulVu), IrrwIdow
End If
End If
End If
Next IrrwIdow
If cndiiodnciiapc Then
MsgBox Replace(Replace(GetTranslatedMessage("DUPLICATE_VALUE"), "{0}", ilcduidVulalei), "{1}", tpooltRltRRR), vbExclamation
Exit Sub
End If
nsasalAumr = 0
For IrrwIdow = arpeeiFFple + 1 To woRRoso
If Not ws.Rows(IrrwIdow).Hidden Then
nsasalAumr = nsasalAumr + 1
oRbRseooobe.Add IrrwIdow
End If
Next IrrwIdow
sSpRiwoStlw = PAAAws.Cells(PAAAws.Rows.Count, 1).End(xlUp).row
If sSpRiwoStlw >= saiioiw Then
PAAAws.Rows(saiioiw & ":" & sSpRiwoStlw).Delete
End If
For Each IrrwIdow In oRbRseooobe
For Each key In IsPAwcDPAc.Keys
Select Case key
Case "Alarm-Warning"
If UCase(ws.Cells(IrrwIdow, tstcts("Is Warning") + arilureaCunCao).value) = "X" Then
PAAAws.Cells(saiioiw, IsPAwcDPAc(key) + 1).value = "Warning"
PAAAws.Cells(saiioiw, IsPAwcDPAc(key) + 1).Font.Color = RGB(0, 32, 240)
Else
PAAAws.Cells(saiioiw, IsPAwcDPAc(key) + 1).value = "Alarm"
PAAAws.Cells(saiioiw, IsPAwcDPAc(key) + 1).Font.Color = RGB(255, 0, 0)
End If
Case "Number"
PAAAws.Cells(saiioiw, IsPAwcDPAc(key) + 1).value = ws.Cells(IrrwIdow, tstcts("AlarmNum") + arilureaCunCao).value
Case "Tag"
PAAAws.Cells(saiioiw, IsPAwcDPAc(key) + 1).value = "DB" & ws.Cells(IrrwIdow, tstcts("DB") + arilureaCunCao).value & _
".DBX" & ws.Cells(IrrwIdow, tstcts("Byte") + arilureaCunCao).value & _
"." & ws.Cells(IrrwIdow, tstcts("Bit") + arilureaCunCao).value
Case "Sections"
Dim eccLnonnccL As String
Dim scnonmotmm As Integer
eccLnonnccL = ""
For scnonmotmm = 1 To 5
If UCase(ws.Cells(IrrwIdow, tstcts("Section." & scnonmotmm) + arilureaCunCao).value) = "X" Then
If eccLnonnccL <> "" Then
eccLnonnccL = eccLnonnccL & ","
End If
eccLnonnccL = eccLnonnccL & scnonmotmm
End If
Next scnonmotmm
PAAAws.Cells(saiioiw, IsPAwcDPAc(key) + 1).value = eccLnonnccL
Case "Priority"
PAAAws.Cells(saiioiw, IsPAwcDPAc(key) + 1).value = ws.Cells(IrrwIdow, tstcts("Priority") + arilureaCunCao).value
Case "Description"
PAAAws.Cells(saiioiw, IsPAwcDPAc(key) + 1).value = ws.Cells(IrrwIdow, tstcts("Descripción") + arilureaCunCao).value
Case "Used"
If UCase(ws.Cells(IrrwIdow, tstcts("Disable") + arilureaCunCao).value) <> "X" Then
PAAAws.Cells(saiioiw, IsPAwcDPAc(key) + 1).value = ChrW(9679)
Else
PAAAws.Cells(saiioiw, IsPAwcDPAc(key) + 1).value = "-"
End If
End Select
Next key
saiioiw = saiioiw + 1
Next IrrwIdow
Dim PtaePPaiwal As String
PtaePPaiwal = Application.GetSaveAsFilename(InitialFileName:="Mappa Allarmi Completa Supervisore", _
FileFilter:="Excel Files (*.xlsx), *.xlsx", _
Title:="Guardar hoja SIPA como")
If PtaePPaiwal <> "False" Then
Dim robWbkrnwbb As Workbook
Set robWbkrnwbb = Application.Workbooks.Add
PAAAws.Copy Before:=robWbkrnwbb.Sheets(1)
Application.DisplayAlerts = False
robWbkrnwbb.Sheets(2).Delete
Application.DisplayAlerts = True
robWbkrnwbb.SaveAs Filename:=PtaePPaiwal
robWbkrnwbb.Close SaveChanges:=True
MsgBox Replace(GetTranslatedMessage("SIPA_EXPORT_SAVED"), "{0}", PtaePPaiwal), vbInformation
Else
MsgBox GetTranslatedMessage("SIPA_EXPORT_NOT_SAVED"), vbInformation
End If
MsgBox GetTranslatedMessage("SIPA_EXPORT_COMPLETE"), vbInformation
End Sub
Function GetDictValue(dict As Object, key As Variant) As Variant
If VarType(key) = vbString Then
GetDictValue = dict(key)
ElseIf IsNumeric(key) Then
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 aeaars As Variant
aeaars = Split(texto, "/")
If UBound(aeaars) >= 0 Then
GetDB = CLng(aeaars(0))
Else
GetDB = -1
End If
End Function
Function GetByte(texto As String) As Long
Dim aeaars As Variant
aeaars = Split(texto, "/")
If UBound(aeaars) >= 1 Then
GetByte = CLng(aeaars(1))
Else
GetByte = -1
End If
End Function
Function GetBit(texto As String) As Long
Dim aeaars As Variant
aeaars = Split(texto, "/")
If UBound(aeaars) >= 2 Then
Dim aaabrib As String
aaabrib = Split(aeaars(2), " ")(0)
GetBit = CLng(aaabrib)
Else
GetBit = -1
End If
End Function
Function GetExcelLanguage() As String
Select Case Application.LanguageSettings.LanguageID(msoLanguageIDUI)
Case 1034
GetExcelLanguage = "ES"
Case 1040
GetExcelLanguage = "IT"
Case Else
GetExcelLanguage = "EN"
End Select
End Function
Function GetTranslatedMessage(msgKey As String) As String
Dim magaegem As Object
Set magaegem = CreateObject("Scripting.Dictionary")
magaegem("EN") = CreateObject("Scripting.Dictionary")
magaegem("EN")("IMPORT_COMPLETE") = "Import completed."
magaegem("EN")("EXPORT_COMPLETE") = "Export completed."
magaegem("EN")("FILE_NOT_SELECTED") = "No file was selected. Operation cancelled."
magaegem("EN")("DUPLICATE_VALUE") = "A duplicate value was found: {0} in row {1}. The operation has been aborted."
magaegem("EN")("ALARM_NODE_NOT_FOUND") = "The 'Alarms' node was not found in the XML file."
magaegem("EN")("MEMBER_NODE_NOT_FOUND") = "The 'Member' node with Name='Alarms' was not found in the XML file."
magaegem("EN")("ROWS_HIDDEN") = "Process completed. Rows hidden: {0}"
magaegem("EN")("ALL_ROWS_SHOWN") = "All rows are now visible."
magaegem("EN")("SIPA_SHEET_NOT_FOUND") = "The 'Per Supervisore SIPA' sheet does not exist in this workbook. Please create this sheet before continuing."
magaegem("EN")("SIPA_EXPORT_COMPLETE") = "SIPA export completed."
magaegem("EN")("SIPA_EXPORT_SAVED") = "SIPA export completed and saved in {0}"
magaegem("EN")("SIPA_EXPORT_NOT_SAVED") = "SIPA export completed. Not saved in a separate file."
magaegem("ES") = CreateObject("Scripting.Dictionary")
magaegem("ES")("IMPORT_COMPLETE") = "Importación completada."
magaegem("ES")("EXPORT_COMPLETE") = "Exportación completada."
magaegem("ES")("FILE_NOT_SELECTED") = "No se seleccionó ningún archivo. Operación cancelada."
magaegem("ES")("DUPLICATE_VALUE") = "Se encontró un valor duplicado: {0} en la fila {1}. La operación ha sido abortada."
magaegem("ES")("ALARM_NODE_NOT_FOUND") = "No se encontró el nodo 'Alarms' en el archivo XML."
magaegem("ES")("MEMBER_NODE_NOT_FOUND") = "No se encontró el nodo 'Member' con Name='Alarms' en el archivo XML."
magaegem("ES")("ROWS_HIDDEN") = "Proceso completado. Filas ocultadas: {0}"
magaegem("ES")("ALL_ROWS_SHOWN") = "Todas las filas son ahora visibles."
magaegem("ES")("SIPA_SHEET_NOT_FOUND") = "La hoja 'Per Supervisore SIPA' no existe en este libro. Por favor, cree esta hoja antes de continuar."
magaegem("ES")("SIPA_EXPORT_COMPLETE") = "Exportación a SIPA completada."
magaegem("ES")("SIPA_EXPORT_SAVED") = "Exportación a SIPA completada y guardada en {0}"
magaegem("ES")("SIPA_EXPORT_NOT_SAVED") = "Exportación a SIPA completada. No se ha guardado en un archivo separado."
magaegem("IT") = CreateObject("Scripting.Dictionary")
magaegem("IT")("IMPORT_COMPLETE") = "Importazione completata."
magaegem("IT")("EXPORT_COMPLETE") = "Esportazione completata."
magaegem("IT")("FILE_NOT_SELECTED") = "Nessun file selezionato. Operazione annullata."
magaegem("IT")("DUPLICATE_VALUE") = "È stato trovato un valore duplicato: {0} nella riga {1}. L'operazione è stata interrotta."
magaegem("IT")("ALARM_NODE_NOT_FOUND") = "Il nodo 'Alarms' non è stato trovato nel file XML."
magaegem("IT")("MEMBER_NODE_NOT_FOUND") = "Il nodo 'Member' con Name='Alarms' non è stato trovato nel file XML."
magaegem("IT")("ROWS_HIDDEN") = "Processo completato. Righe nascoste: {0}"
magaegem("IT")("ALL_ROWS_SHOWN") = "Tutte le righe sono ora visibili."
magaegem("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."
magaegem("IT")("SIPA_EXPORT_COMPLETE") = "Esportazione SIPA completata."
magaegem("IT")("SIPA_EXPORT_SAVED") = "Esportazione SIPA completata e salvata in {0}"
magaegem("IT")("SIPA_EXPORT_NOT_SAVED") = "Esportazione SIPA completata. Non salvata in un file separato."
Dim lang As String
lang = GetExcelLanguage()
If magaegem(lang).Exists(msgKey) Then
GetTranslatedMessage = magaegem(lang)(msgKey)
Else
GetTranslatedMessage = magaegem("EN")(msgKey)
End If
End Function

BIN
Release/ImportExportDB5100 v0.3.xlsm Normal file
View File

Binary file not shown.

BIN
Release/ImportExportDB5100 v0.4.xlsm Normal file
View File

Binary file not shown.

BIN
Release/ImportExportDB5100 v0.5.xlsm Normal file
View File

Binary file not shown.

86
UDT SV Manager Allarm.xml Normal file
View File

@ -0,0 +1,86 @@
<?xml version="1.0" encoding="utf-8"?>
<Document>
<Engineering version="V19" />
<SW.Types.PlcStruct ID="0">
<AttributeList>
<Interface><Sections xmlns="http://www.siemens.com/automation/Openness/SW/Interface/v5">
<Section Name="None">
<Member Name="AlarmNum" Datatype="Int" />
<Member Name="DB" Datatype="Int" />
<Member Name="Byte" Datatype="Int" />
<Member Name="Bit" Datatype="Byte" />
<Member Name="Priority" Datatype="Byte">
<Comment>
<MultiLanguageText Lang="it-IT">High -&gt; Higher priority</MultiLanguageText>
</Comment>
</Member>
<Member Name="Section" Datatype="Array[1..&quot;Numero_Sezioni&quot;] of Bool">
<Comment>
<MultiLanguageText Lang="it-IT">Section or Sections that belong</MultiLanguageText>
</Comment>
</Member>
<Member Name="Value" Datatype="Bool" />
<Member Name="Disable" Datatype="Bool" />
<Member Name="Is Warning" Datatype="Bool">
<Comment>
<MultiLanguageText Lang="it-IT">0 : Error - 1 : Warning</MultiLanguageText>
</Comment>
</Member>
<Member Name="Ons" Datatype="Bool">
<Comment>
<MultiLanguageText Lang="it-IT">In Seconds</MultiLanguageText>
</Comment>
</Member>
</Section>
</Sections></Interface>
<Name>UDT SV Manager Allarm</Name>
<Namespace />
</AttributeList>
<ObjectList>
<MultilingualText ID="1" CompositionName="Comment">
<ObjectList>
<MultilingualTextItem ID="2" CompositionName="Items">
<AttributeList>
<Culture>it-IT</Culture>
<Text />
</AttributeList>
</MultilingualTextItem>
<MultilingualTextItem ID="3" CompositionName="Items">
<AttributeList>
<Culture>en-GB</Culture>
<Text />
</AttributeList>
</MultilingualTextItem>
<MultilingualTextItem ID="4" CompositionName="Items">
<AttributeList>
<Culture>es-ES</Culture>
<Text />
</AttributeList>
</MultilingualTextItem>
</ObjectList>
</MultilingualText>
<MultilingualText ID="5" CompositionName="Title">
<ObjectList>
<MultilingualTextItem ID="6" CompositionName="Items">
<AttributeList>
<Culture>it-IT</Culture>
<Text />
</AttributeList>
</MultilingualTextItem>
<MultilingualTextItem ID="7" CompositionName="Items">
<AttributeList>
<Culture>en-GB</Culture>
<Text />
</AttributeList>
</MultilingualTextItem>
<MultilingualTextItem ID="8" CompositionName="Items">
<AttributeList>
<Culture>es-ES</Culture>
<Text />
</AttributeList>
</MultilingualTextItem>
</ObjectList>
</MultilingualText>
</ObjectList>
</SW.Types.PlcStruct>
</Document>