' 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�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� 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�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�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 = "�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