Título: [SRC] Abbreviate_Numeric_Array [by *PsYkE1]
Publicado por: Psyke1 en 5 Julio 2010, 12:31 pm
Hola chicos, esta es mi ultima funcion que sirve para simplificar arrays numéricos. En realidad es un reto que me puso mi maestro BlackZer0X! :P Añadir mi clase cCollectionEx.cls (http://foro.elhacker.net/programacion_visual_basic/src_ccollectionexcls_by_psyke1-t302651.0.html) '========================================================= ' º Function : Abbreviate_Numeric_Array ' º Author : Mr. Frog © ' º Mail : vbpsyke1@mixmail.com ' º Recommended Websites : ' http://blog.visual-coders.com.ar/ ' http://InfrAngeluX.Sytes.Net/ '========================================================= Option Explicit Option Base 0 Rem Añadir mi clase cCollectionEx.cls Public Function Abbreviate_Numeric_Array(ByRef vNumberList() As Variant) As cCollectionEx If (Not vNumberList) = -1 Then Exit Function Dim cExTemp As New cCollectionEx Dim lActualNumber As Variant Dim lToTalNumbers As Long Dim Q As Long Dim W As Long lToTalNumbers = UBound(vNumberList()) If lToTalNumbers > 2 Then Do While Q <= lToTalNumbers lActualNumber = vNumberList(Q) W = 0 If (Q < lToTalNumbers) Then Do While (vNumberList(Q) + 1 = vNumberList(Q + 1)) Or _ (vNumberList(Q) = vNumberList(Q + 1)) Q = Q + 1 W = W + 1 Loop End If With cExTemp If W > 1 Then .Add lActualNumber & "~" & vNumberList(Q) Else .Add lActualNumber End If End With If Not (W = 1) Then Q = Q + 1 Loop Set Abbreviate_Numeric_Array = cExTemp End If End Function
Ejemplo: Private Sub Form_Load() Dim Q As Long Dim dArray() As Variant Dim sResult As String dArray() = Array(1, 2, 3, 4, 4, 5, 6, 7, 7, 7, 65, 345, 4545, 4546, 4547, 9999999, 9999999999#) With Abbreviate_Numeric_Array(dArray) For Q = 1 To .Count sResult = sResult & .Item(Q) & "|" Next Q End With Debug.Print sResult End Sub
Obtengo esto: 1~7|65|345|4545~4547|9999999|9999999999|
Ahora mi funcion para desabreviar... :P '========================================================= ' º Function : DeAbbreviate_Numeric_Array ' º Author : Mr. Frog © ' º Mail : vbpsyke1@mixmail.com ' º Recommended Websites : ' http://blog.visual-coders.com.ar/ ' http://InfrAngeluX.Sytes.Net/ '========================================================= Option Explicit Option Base 0 Public Function DeAbbreviate_Numeric_Array(ByRef sNumbersItems() As String) As cCollectionEx If (Not sNumbersItems) = -1 Then Exit Function Dim cExTemp As New cCollectionEx Dim sActualItem As String Dim sNumbers() As String Dim lToTalItems As Long Dim Q As Long Dim W As Long lToTalItems = UBound(sNumbersItems()) If lToTalItems > 2 Then For Q = 0 To lToTalItems sActualItem = sNumbersItems(Q) If sActualItem Like "*~*" Then sNumbers() = Split(sActualItem, "~") For W = CDbl(sNumbers(0)) To CDbl(sNumbers(1)) cExTemp.Add W Next W Else cExTemp.Add sActualItem End If Next Q Set DeAbbreviate_Numeric_Array = cExTemp End If End Function
Un ejemplo: Private Sub Form_Load() Dim sArray() As String Dim Q As Long sArray() = Split("1|2|8|9|34|56~58|9999~10002|", "|") With DeAbbreviate_Numeric_Array(sArray()) For Q = 1 To .Count Debug.Print .Item(Q) Next Q End With End Sub
Me da esto: 1 2 8 9 34 56 57 58 9999 10000 10001 10002 DoEvents! :P
Título: Re: [SRC] Abbreviate_Numeric_Array [by *PsYkE1]
Publicado por: Debci en 5 Julio 2010, 13:11 pm
Es un muy buen ejercicio para pillar conceptos de lógica.
Muy bueno y gracias por compartir ;)
Saludos
Título: Re: [SRC] Abbreviate_Numeric_Array [by *PsYkE1]
Publicado por: Karcrack en 5 Julio 2010, 13:42 pm
Me ha gustado :D, ahora falta que hagas la funcion que des-abrevia :P, si no esto no tiene utilidad :xD Seria interesante que tambien pudiese detectar series de multiples por ejemplo... Lo unico que no me gusta es que abusas de hacer las cosas en una linea, por ejemplo: If lActualNumber + c = lNumberList(n) Then n = n + 1: c = c + 1 Else Exit Do
A me me gusta mucho mas asi, se ve mejor la logica: If lActualNumber + c = lNumberList(n) Then n = n + 1 c = c + 1 Else Exit Do End If
Saludos ;)
Título: Re: [SRC] Abbreviate_Numeric_Array [by *PsYkE1]
Publicado por: Psyke1 en 5 Julio 2010, 13:56 pm
Gracias! ;D Si, lo de las series multiples era una de las cosas a implementar, buena idea lo de "des-abreviar"... :laugh: (Lo metere tambien, buena idea) ;) En cuanto lo de las lineas es pura costumbre, auque tienes razon que es mas "entendible" como me has puesto... :silbar: En unos dias posteo la nueva :P
Salu2 y Gracias a ambos! :-* :laugh:
Título: Re: [SRC] Abbreviate_Numeric_Array [by *PsYkE1]
Publicado por: Dreamaker en 5 Julio 2010, 14:33 pm
A mi también me ha gustado y estoy de acuerdo con eso con Karcrack, hay que hacer el código un poco más legible..(y hasta aunque sea para uno mismo)
Buen trabajo ;)
Título: Re: [SRC] Abbreviate_Numeric_Array [by *PsYkE1]
Publicado por: Karcrack en 5 Julio 2010, 14:38 pm
He hecho la funcion de desabreviar :P Option Explicit Private Sub Form_Load() Dim vItem As Variant For Each vItem In DeAbbreviate("1|2|8|9|34|56~58|9999~10002|") Debug.Print vItem; Next vItem End Sub Public Function DeAbbreviate(ByVal sString As String) As Double() Dim bvTemp() As String Dim i As Long Dim n As Long Dim w As Long Dim dFir As Double Dim dLas As Double Dim bvResult() As Double bvTemp = Split(sString, "|") For i = LBound(bvTemp) To UBound(bvTemp) If bvTemp(i) Like "*~*" Then dFir = Val(Split(bvTemp(i), "~")(0)) dLas = Val(Split(bvTemp(i), "~")(1)) ReDim Preserve bvResult(0 To (n + (dLas - dFir))) For n = n To (n + (dLas - dFir)) bvResult(n) = dFir + w w = w + 1 Next n w = 0 n = n - 1 ElseIf bvTemp(i) <> vbNullString Then ReDim Preserve bvResult(0 To n) bvResult(n) = bvTemp(i) End If n = n + 1 Next i DeAbbreviate = bvResult End Function
Supongo que se podria acortar un poco, pero creo que asi queda muy claro lo que hace :D Saludos ;)
Título: Re: [SRC] Abbreviate_Numeric_Array [by *PsYkE1]
Publicado por: Psyke1 en 5 Julio 2010, 14:40 pm
@Karcrack Te odio!!! :laugh: :laugh: Queria hacerlo yo antes... :¬¬ No obstante no voy a mirar tu code, y publicare mi alternativa, despues mirare el tuyo... :P
JAJAJAJA :xD
Salu2! ;)
Título: Re: [SRC] Abbreviate_Numeric_Array [by *PsYkE1]
Publicado por: Psyke1 en 5 Julio 2010, 19:23 pm
Bueno como habeis visto, he posteado la funcion de desabreviar ;-) Tambien he quitado algunos ":" para que la funcion sea mas legible (siguiendo vuestro consejo ;) ) Voy a ver tu funcion Karcrack, aunque debo de admitir que hay cosas que no entiendo, las buscare y si tengo dudas pregunto... :D
Salu2 y Gracias! :P
Título: Re: [SRC] Abbreviate_Numeric_Array [by *PsYkE1]
Publicado por: BlackZeroX en 5 Julio 2010, 21:53 pm
Aun le falta...!¡. Dim tt(100) As Double tt(0) = 6 tt(1) = 8 tt(2) = 9 tt(3) = 10 tt(4) = 11 tt(5) = 12 tt(6) = 12 tt(7) = 12 tt(8) = 13 tt(9) = 14 tt(10) = 15 tt(11) = 16 tt(12) = 17 tt(13) = 18 tt(14) = 19 tt(15) = 19 tt(16) = 19 tt(17) = 20 tt(18) = 20 tt(19) = 21 tt(20) = 21 tt(21) = 22 tt(22) = 23 tt(23) = 24 tt(24) = 24 tt(25) = 25 tt(26) = 25 tt(27) = 25 tt(28) = 27 tt(29) = 28 tt(30) = 29 tt(31) = 31 tt(32) = 33 tt(33) = 34 tt(34) = 34 tt(35) = 35 tt(36) = 35 tt(37) = 37 tt(38) = 37 tt(39) = 38 tt(40) = 39 tt(41) = 40 tt(42) = 43 tt(43) = 43 tt(44) = 44 tt(45) = 44 tt(46) = 45 tt(47) = 45 tt(48) = 46 tt(49) = 47 tt(50) = 48 tt(51) = 48 tt(52) = 48 tt(53) = 49 tt(54) = 50 tt(55) = 50 tt(56) = 52 tt(57) = 54 tt(58) = 56 tt(59) = 56 tt(60) = 56 tt(61) = 57 tt(62) = 59 tt(63) = 60 tt(64) = 61 tt(65) = 62 tt(66) = 63 tt(67) = 64 tt(68) = 65 tt(69) = 66 tt(70) = 66 tt(71) = 67 tt(72) = 69 tt(73) = 70 tt(74) = 70 tt(75) = 72 tt(76) = 73 tt(77) = 74 tt(78) = 75 tt(79) = 75 tt(80) = 76 tt(81) = 76 tt(82) = 77 tt(83) = 80 tt(84) = 81 tt(85) = 85 tt(86) = 87 tt(87) = 88 tt(88) = 88 tt(89) = 89 tt(90) = 89 tt(91) = 91 tt(92) = 92 tt(93) = 92 tt(94) = 94 tt(95) = 94 tt(96) = 95 tt(97) = 95 tt(98) = 96 tt(99) = 96 tt(100) = 97
Resultado: 6|8~12|12|12~19|19|19|20|20|21|21~24|24|25|25|25|27~29|31|33|34|34|35|35|37|37~40|43|43|44|44|45|45~48|48|48~50|50|52|54|56|56|56|57|59~66|66|67|69|70|70|72~75|75|76|76|77|80|81|85|87|88|88|89|89|91|92|92|94|94|95|95|96|96|97|
Sangriento Infierno Lunar!¡.
Título: Re: [SRC] Abbreviate_Numeric_Array [by *PsYkE1]
Publicado por: Psyke1 en 5 Julio 2010, 21:56 pm
Si si Black! :) Ya dije que faltaba eso aun... :P Lo corrigo en estos dias...
Salu2! ;)
|