elhacker.net cabecera Bienvenido(a), Visitante. Por favor Ingresar o Registrarse
¿Perdiste tu email de activación?.

 

 


Tema destacado: Tutorial básico de Quickjs


  Mostrar Temas
Páginas: 1 [2] 3 4 5 6 7 8 9 10 11 12 13 14
11  Programación / Programación Visual Basic / [SRC] itsOkCRC32 en: 27 Enero 2012, 00:06 am
.
La funcion lo que realiza es una verificación del exe para saber si a ido modificaco o no (es una seguridad muy basica).

Edito--->
(NO ES NECESARIO) OJO si lo van a usar deberan realinear el formato PE... o usar los ultimos 4 bytes de el exe (habitualmente son bytes 0)

En un modulo...

Código
  1.  
  2. Option Explicit
  3.  
  4. #Const INSERTCRC32TOEXE = False
  5.  
  6. Public Function itsOkCRC32() As Boolean
  7. '   //
  8. '   //  Funcion itsOkCRC32 creada por BlackZeroX (http://infrangelux.hostei.com)
  9. '   //
  10. '   //  Instrucciones:
  11. '   //  * COMPILA TU EXE FINAL con la constante INSERTCRC32TOEXE = false.
  12. '   //  * Cambia INSERTCRC32TOEXE de false a true ( #Const INSERTCRC32TOEXE = true )
  13. '   //  * Cambia la linea  {Open "c:\testCRC32.exe" For Binary As hFile} de este proceso con
  14. '   //  la ruta del exe que compilaste anteriormente, por ejemplo {Open "c:\testCRC32.exe" For Binary As hFile}
  15. '   //  * Ejecuta el proyecto desde este IDE, si todo a ido correctamente les aparecera un mensaje {"CRC32 configurado Correctamente"}.
  16. '   //  * Comprube tu EXE Final {c:\testCRC32.exe} ejecutandolo directamente.
  17. '   //  Si todo a hido correctamente el exe te mostrara {"CRC32 Correcto"} si solo has generado el exe y no cambiaste {INSERTCRC32TOEXE a true} te mostrara {"CRC32 erroneo"} en este ejemplo.
  18.  
  19. Dim byteData()              As Byte
  20. Dim dwSizeFile              As Long
  21. Dim dwCRC32ReadFile         As Long
  22. Dim dwCRC32Generate         As Long
  23. Dim oCRC32                  As cCRC32
  24. Dim hFile                   As Integer
  25.  
  26.    hFile = FreeFile
  27. #If (INSERTCRC32TOEXE = False) Then
  28.    Open App.Path & "\" & App.EXEName & ".exe" For Binary As hFile
  29. #Else
  30.    Open "c:\testCRC32.exe" For Binary As hFile
  31. #End If
  32.        dwSizeFile = LOF(hFile)
  33.        If ((dwSizeFile - 4) > 0) Then
  34. #If (INSERTCRC32TOEXE = True) Then
  35.            ReDim byteData(0 To (dwSizeFile - 1))
  36. #Else
  37.            ReDim byteData(0 To (dwSizeFile - 1 - 4))
  38. #End If
  39.            Get 1, , byteData
  40.            Get 1, , dwCRC32ReadFile
  41.  
  42.            Set oCRC32 = New cCRC32
  43.            dwCRC32Generate = oCRC32.GetByteArrayCrc32(byteData)
  44.            Set oCRC32 = Nothing
  45.  
  46.            If (dwCRC32Generate = dwCRC32ReadFile) Then
  47.                itsOkCRC32 = True
  48. #If (INSERTCRC32TOEXE = True) Then
  49.                MsgBox "CRC32 Ya se encontraba configurado."
  50.            Else
  51.                Put hFile, , dwCRC32Generate
  52.                MsgBox "CRC32 configurado Correctamente."
  53.                End
  54. #End If
  55.            End If
  56.        End If
  57.    Close hFile
  58.  
  59. End Function
  60.  
  61.  

cCRC32.cls (Modulo de clase)

Código:

Option Explicit

' This code is taken from the VB.NET CRC32 algorithm
' provided by Paul (wpsjr1@succeed.net) - Excellent work!

Private crc32Table() As Long

Public Function GetByteArrayCrc32(ByRef buffer() As Byte) As Long
Dim crc32Result     As Long:    crc32Result = &HFFFFFFFF
Dim i               As long
Dim iLookup         As long
   
   For i = LBound(buffer) To UBound(buffer)
      iLookup = (crc32Result And &HFF) Xor buffer(i)
      crc32Result = ((crc32Result And &HFFFFFF00) \ &H100) And 16777215 ' nasty shr 8 with vb :/
      crc32Result = crc32Result Xor crc32Table(iLookup)
   Next i
   
   GetByteArrayCrc32 = Not (crc32Result)

End Function



Private Sub Class_initialize()

    ' This is the official polynomial used by CRC32 in PKZip.
    ' Often the polynomial is shown reversed (04C11DB7).
    Dim dwPolynomial As Long
    dwPolynomial = &HEDB88320
    Dim i As Integer, j As Integer

    ReDim crc32Table(256)
    Dim dwCrc As Long

    For i = 0 To 255
        dwCrc = i
        For j = 8 To 1 Step -1
            If (dwCrc And 1) Then
                dwCrc = ((dwCrc And &HFFFFFFFE) \ 2&) And &H7FFFFFFF
                dwCrc = dwCrc Xor dwPolynomial
            Else
                dwCrc = ((dwCrc And &HFFFFFFFE) \ 2&) And &H7FFFFFFF
            End If
        Next j
        crc32Table(i) = dwCrc
    Next i

End Sub

Private Sub Class_Terminate()
    Erase crc32Table
End Sub


Ejemplo:

Código
  1.  
  2. option explicit
  3.  
  4. Sub main()
  5.    If (itsOkCRC32) Then
  6.        MsgBox "CRC32 Correcto"
  7.    Else
  8.        MsgBox "CRC32 erroneo"
  9.    End If
  10. End Sub
  11.  
  12.  

Decargar Ejemplo (Compilar en "C:\" el proyecto con el nombre "testCRC32.exe" o configurar las lineas segun lo requieran y con la constante en false, despues solo ejecutar desde el IDE con la constante en true):
http://infrangelux.sytes.net/FileX/index.php?dir=/BlackZeroX/Programacion/vb6/ejemplos%20VB6&file=itsOKCRC32.zip



Alternativa: http://foro.elhacker.net/programacion_visual_basic/src_self_crc32_check_01_poc-t351610.0.html

Dulces Lunas!¡.
12  Foros Generales / Foro Libre / -> Integrales en: 2 Diciembre 2011, 04:44 am
Cual es la integral de log(x)?... se como hacer la de ln(x)... se que ln tiene base e... en el caso de log(x) no me dieron la base (es de un libro de calculo).

Pondria la formula de la integral completa que deseo resolver pero no es mi objetivo primordial... solo desearia saber cual es la integral de log(x) o de log(u) (notece que no es ln(x) ni ln(u)).

Nota: Preferiblemente de log(u) asi obvio a log(x) obviamente en todos los casos despreciando a x.

Dulces Lunas!¡.
13  Foros Generales / Foro Libre / chiste Informatico en: 24 Noviembre 2011, 07:01 am
 :silbar: :silbar: :silbar:



 ;-) ;-) ;-) ;-) ;-) ;-)

Dulces Lunas!¡.
14  Foros Generales / Foro Libre / ¿Contrataste X Megas pero te dan Menos? ¿Te dieron Pato por Ganzo? Mirate esto.. en: 20 Noviembre 2011, 09:58 am
Esta publicación la pongo debido a que muchos de nosotros empezamos a mentar madres a las ISP de manera injustificada... digo injustificada por que muchos de nosotros carecemos en algún momento de alguna Terminología en este caso la palabra Mega... pensamos que significa MegaByte pero no, significa Mega Bit ya que carece de Sufijo como MegaByte, GigaByte ya que:

* Mega (1048576 bits) es distinto de MegaByte (8388608 bits)
* Giga (1073741824 bits) es distinto de GigaByte (8589934592 bits)

En algunos lugares, y en muchos sitios se da el caso de que se contrata 1 Mega y los usuarios erróneamente dan un mal significado a Mega creyendo que se trata de un 1Mega Byte, pero cuando prueban su internet se dan cuenta que no es un Mega de bajada o de subida (para el caso sera lo mismo).

Un ejemplo es el servicio TELMEX Infinitum donde Dicen Claramente 1Mb = MegaBit cabe destacar que MB = MegaByte... (Es estos casos Mb y MB son distintos)...

http://www.telmex.com/mx/hogar/paquetes/paquete-conectes.html
http://www.telmex.com/mx/hogar/paquetes/paquete-acerques.html
http://www.telmex.com/mx/hogar/paquetes/sinlimites.html

En todos los Casos dice Mb y no MB

Si van al Router de este ISP podran ver algo similar a esto:



Como verán la parte resaltada en color rojo se puede apreciar que dice kbps esto no significa KiloBytes / segundo si no que significa  KiloBit / segundo.

Esto es debido a que kB = KiloByte y kb = kilobit pueden revisar esto último en la siguiente liga:

https://es.wikipedia.org/wiki/Kilobit

Citando la liga:

Citar

Un kilobit es una unidad de medida de información (abreviado kb o kbit).

En la práctica la unidad kilobit se usa para medir el tráfico de la información por un canal digital, y se representa como kilobits / segundo (kbps) esta unidad representa la cantidad de bits que se transfieren de un punto a otro en un segundo.


De todo esto se puede deducir lo siguiente...

Las empresas NO te venden un servicio de bytes si no de bits.
Las empresas en sus Anuncios Nunca dicen "MegaByte" dicen "Mega" y 1 Mega en escalas Binarias equivalen a 1 048 576 bits que es lo mismo a 128 kB/s (KiloBytes / segundo).

Por ejemplo con la ayuda de la siguiente escala:

1 unidad = 1 bit.
1 Kilo = 1024 unidades ( las unidades son bits por lo tanto se puede interpretar como 1024 bits o 1 kilo bit).
1 Mega = 1 kilo * 1 kilo = 1024 * 1024 = 1 048 576.
8 bits = Byte.

Más información en la siguiente liga: https://es.wikipedia.org/wiki/Prefijo_binario

Teniendo lo anterior en cuenta y sabiendo que no nos vendes Mega Bytes por segundo si no Mega Bits por segundo podemos deducir:

Si contratamos 4 Megas de bajada a la ISP X que nos da una subida de 512 kb (Notese que es kb NO kB son cosas distintas) de bajada se debe hacer lo siguiente para saber el LIMITE MAXIMO en kB/s (kiloBytes / s) reales:


Desendente de 4 Megas:
4 Mega = 1 Mega * 4 = 4 Mega = 1048576 * 4 = 4 194 304 b/s (pero lo queremos a kb/s no en b/s)
Convertimos a Bytes para eso dividimos los bits en bytes:
4 194 304 / 8 = 524 288 B/s (solo falta pasarlo a kB/s)
La velocidad de Desencente (Descarga) real es de 524 288 b/s (pasándolo a kB/s):
524 288 / 1 Kilo = 524 288 / 1024 = 512 kB/s <--- No podrás superar esta velocidad por mucho que quieras...
La bajada real es de:
512 kB/s <--- Es la velocidad de Subida Real Máxima que tienes contratada expresada en KiloBytes/Segundo.


Ascendente de 512 kb/s (Solo lo dividimos entre 8 para pasarlo a kB/s):
512 / 1 Byte  = 512 / 8 = 64 kB/s <--- No podrás superar esta velocidad por mucho que quieras...
La bajada real es de:
64 kB/s <--- Es la velocidad de Subida REAL Máxima que se tiene contratada expresada en KiloBytes/Segundo...

Como ven solo es Falta de conocimiento... y una Maldita publicidad engañosa de las ISP... que no es engañosa porque en ningún Comercial dicen "Conexión de hasta 1 MegaByte" si no que dicen claramente "Conexión de hasta 1 Mega" y al carecer de un Sufijo se traduce que no dicen en Bytes si no en Bits y debido a esto que casi nadie sabe termina creyendo que son MegaBytes y terminan refrescándole la madre a la ISP y los pobres de Atención a cliente terminan sufirendo de nuestra ignorancia.

Dulces Lunas!¡.
15  Foros Generales / Foro Libre / Creen en los ovnis? en: 19 Noviembre 2011, 11:19 am
.
 * Antes si alguien intenta agredir de cualquier manera y lo leen No hagan un Flame... pasen a Ignorarlo, solo quiero contar algo que hace unos instantes me ha sucedido y que me ha dejado PERPLEJO.

Bueno la cosa es que hace unos minutos tube un encuentro de urgencia de miar (liberacion de vegiga)... no se preocupen mi vegita esta ya vacia... pero cuando salgo de mi cuarto el cual esta en el techo de la casa de mis padre (mi centro de mando jajaja  :xD jajaja), miro unas luces algo extrañas, similares a un avion o reflejo de un alambre, pero o por Lucifer!¡. no era un avion estaban suspendidas y empesaron a bajar por hay en los volcanes entre el Popo y el iztaccihuatl (Quiero suponer mas no lo afirmo) la cosa es que me medio asuste la verdad, diferencie que no era un avion ni un elicoptero debido a que se veia que hiba a una velocidad demasiado LENTA hasta que la perdi de vista al igual que volvia subir y a perderse de vista, pero muy extraño se quedo sustependido dicho objeto entre las nubes...

Lo grabe en video pero no se ve nada (Camara Digital HD que no tiene vision Nocturna peor tantito).

Ya no creo que Jaime Mausan este Loco...

Nota: No voy a dormir hoy...

Dulces Lunas!¡.
16  Programación / Programación Visual Basic / [Src] numberToName (Correcion al codigo anterior). en: 12 Noviembre 2011, 08:42 am
.
Es una correccion al codigo anterior por que contenia HORRORES...

desde el 1 al 999999999999999999999999999999999999999999999999999999999999999999

Ejemplo:

Código
  1.  
  2. Private Sub Form_Load()
  3.    MsgBox numberToName(InputBox("Ingresa un numero cualquiera", "numberToName", "87984516512"))
  4. End Sub
  5.  
  6.  

OutPut (Test Number: 87984516512):
Citar

ochenta y siete mil novecientos ochenta y cuatro millones quinientos dieci seis mil quinientos doce


Código
  1.  
  2. '
  3. '   /////////////////////////////////////////////////////////////
  4. '   // Autor:   BlackZeroX ( Ortega Avila Miguel Angel )       //
  5. '   //                                                         //
  6. '   // Web:     http://InfrAngeluX.Sytes.Net/                  //
  7. '   //                                                         //
  8. '   //    |-> Pueden Distribuir Este codigo siempre y cuando   //
  9. '   // no se eliminen los creditos originales de este codigo   //
  10. '   // No importando que sea modificado/editado o engrandecido //
  11. '   // o achicado, si es en base a este codigo                 //
  12. '   /////////////////////////////////////////////////////////////
  13. '   // http://infrangelux.hostei.com/index.php?option=com_content&view=article&id=8:arrtnum2string&catid=2:catprocmanager&Itemid=3
  14. '   /////////////////////////////////////////////////////////////
  15.  
  16. Option Explicit
  17.  
  18. Public Function numberToName(ByVal sNumber As String) As String
  19. '   //  MAXIMO  --> 999999999999999999999999999999999999999999999999999999999999999999 ' sección Decillones...
  20.  
  21. '   //  Millon          1 * 10^6
  22. '   //  Billon          1 * 10^12
  23. '   //  Trillon         1 * 10^18
  24. '   //  Cuatrillón      1 * 10^24
  25. '   //  Quintillón      1 * 10^30
  26. '   //  Sextillón       1 * 10^36
  27. '   //  Sptillon        1 * 10^42
  28. '   //  Octillón        1 * 10^48
  29. '   //  Sextillón       1 * 10^54
  30. '   //  Octillón        1 * 10^60
  31. '   //  <--Son bastantes numeros... como para seguirle no creen?-->
  32.  
  33. Dim i           As Long
  34. Dim lLn         As Long
  35. Dim sTmp        As String
  36. Dim bCentena    As Byte
  37. Dim bDecena     As Byte
  38. Dim bUnidad     As Byte
  39. Const MAXLEN    As Long = &H42
  40.  
  41.    lLn = Len(sNumber)
  42.    If (lLn > MAXLEN) Or (lLn = 0) Then Exit Function
  43.  
  44.    sTmp = String$(MAXLEN, "0")
  45.  
  46.    Mid$(sTmp, MAXLEN - lLn + 1) = Mid$(sNumber, 1, lLn)
  47.  
  48.    For i = 1 To MAXLEN Step 3
  49.  
  50.        bCentena = CByte(Mid$(sTmp, i, 1))
  51.        bDecena = CByte(Mid$(sTmp, i + 1, 1))
  52.        bUnidad = CByte(Mid$(sTmp, i + 2, 1))
  53.  
  54.        numberToName = numberToName & centena(bUnidad, bDecena, bCentena) & _
  55.                                      decena(bUnidad, bDecena) & _
  56.                                      unidad(bUnidad, bDecena) & _
  57.                                      IIf(Not (i = (MAXLEN - &H2)), getLeyenda(sNumber, i, bUnidad, bDecena, bCentena), "")
  58.    Next
  59.  
  60. End Function
  61.  
  62. Private Function getLeyenda(ByRef sTmp As String, ByVal i As Long, ByVal bUnidad As Byte, ByVal bDecena As Byte, ByVal bCentena As Byte) As String
  63. '   //  Se obtiene la leyenda con referencia a la ESCALA CORTA.
  64.  
  65.    Select Case i
  66.        Case &H4
  67.            If ((bCentena + bDecena) = 0) And (bUnidad = 1) Then
  68.                getLeyenda = "decillon "
  69.            ElseIf ((bCentena + bDecena + bUnidad) > 1) Then
  70.                getLeyenda = "decillones "
  71.            End If
  72.  
  73.        Case &HA
  74.            If ((bCentena + bDecena) = 0) And (bUnidad = 1) Then
  75.                getLeyenda = "nonillon "
  76.            ElseIf ((bCentena + bDecena + bUnidad) > 1) Then
  77.                getLeyenda = "nonillones "
  78.            End If
  79.  
  80.        Case &H10
  81.            If ((bCentena + bDecena) = 0) And (bUnidad = 1) Then
  82.                getLeyenda = "octillón "
  83.            ElseIf ((bCentena + bDecena + bUnidad) > 1) Then
  84.                getLeyenda = "octillónes "
  85.            End If
  86.  
  87.        Case &H16
  88.            If ((bCentena + bDecena) = 0) And (bUnidad = 1) Then
  89.                getLeyenda = "septillon "
  90.            ElseIf ((bCentena + bDecena + bUnidad) > 1) Then
  91.                getLeyenda = "septillones "
  92.            End If
  93.  
  94.        Case &H1C
  95.            If ((bCentena + bDecena) = 0) And (bUnidad = 1) Then
  96.                getLeyenda = "sextillón "
  97.            ElseIf ((bCentena + bDecena + bUnidad) > 1) Then
  98.                getLeyenda = "sextillónes "
  99.            End If
  100.  
  101.        Case &H22
  102.            If ((bCentena + bDecena) = 0) And (bUnidad = 1) Then
  103.                getLeyenda = "quintillón "
  104.            ElseIf ((bCentena + bDecena + bUnidad) > 1) Then
  105.                getLeyenda = "quintillónes "
  106.            End If
  107.  
  108.        Case &H28
  109.            If ((bCentena + bDecena) = 0) And (bUnidad = 1) Then
  110.                getLeyenda = "cuatrillón "
  111.            ElseIf ((bCentena + bDecena + bUnidad) > 1) Then
  112.                getLeyenda = "cuatrillónes "
  113.            End If
  114.  
  115.        Case &H2E
  116.            If ((bCentena + bDecena) = 0) And (bUnidad = 1) Then
  117.                getLeyenda = "trillon "
  118.            ElseIf ((bCentena + bDecena + bUnidad) > 1) Then
  119.                getLeyenda = "trillones "
  120.            End If
  121.  
  122.        Case &H34
  123.            If ((bCentena + bDecena) = 0) And (bUnidad = 1) Then
  124.                getLeyenda = "billón "
  125.            ElseIf ((bCentena + bDecena + bUnidad) > 1) Then
  126.                getLeyenda = "billones "
  127.            End If
  128.  
  129.        Case &H3A
  130.            If ((bCentena + bDecena) = 0) And (bUnidad = 1) Then
  131.                getLeyenda = "millón "
  132.            ElseIf ((bCentena + bDecena + bUnidad) > 1) Then
  133.                getLeyenda = "millones "
  134.            End If
  135.  
  136.        Case Else
  137.            If ((bCentena + bDecena + bUnidad) > 1) Then getLeyenda = "mil "
  138.  
  139.    End Select
  140.  
  141. End Function
  142.  
  143. Private Function centena(ByVal bUnidad As Byte, ByVal bDecena As Byte, ByVal bCentena As Byte) As String
  144.    Select Case bCentena
  145.        Case 1: If (bDecena + bUnidad) = 0 Then centena = "cien " Else centena = "ciento "
  146.        Case 2: centena = "doscientos "
  147.        Case 3: centena = "trescientos "
  148.        Case 4: centena = "cuatrocientos "
  149.        Case 5: centena = "quinientos "
  150.        Case 6: centena = "seiscientos "
  151.        Case 7: centena = "setecientos "
  152.        Case 8: centena = "ochocientos "
  153.        Case 9: centena = "novecientos "
  154.    End Select
  155. End Function
  156.  
  157. Private Function decena(ByVal bUnidad As Byte, ByVal bDecena As Byte) As String
  158.    Select Case bDecena
  159.        Case 1
  160.            Select Case bUnidad
  161.                Case 0: decena = "diez "
  162.                Case 1: decena = "once "
  163.                Case 2: decena = "doce "
  164.                Case 3: decena = "trece "
  165.                Case 4: decena = "catorce "
  166.                Case 5: decena = "quince "
  167.                Case 6 To 9: decena = "dieci "
  168.            End Select
  169.        Case 2
  170.            If bUnidad = 0 Then
  171.                decena = "veinte "
  172.            ElseIf bUnidad > 0 Then
  173.                decena = "veinti "
  174.            End If
  175.        Case 3: decena = "treinta "
  176.        Case 4: decena = "cuarenta "
  177.        Case 5: decena = "cincuenta "
  178.        Case 6: decena = "sesenta "
  179.        Case 7: decena = "setenta "
  180.        Case 8: decena = "ochenta "
  181.        Case 9: decena = "noventa "
  182.    End Select
  183.    If bUnidad > 0 And bDecena > 2 Then decena = decena + "y "
  184. End Function
  185.  
  186. Private Function unidad(ByVal bUnidad As Byte, ByVal bDecena As Byte) As String
  187.    If bDecena <> 1 Then
  188.        Select Case bUnidad
  189.            Case 1: unidad = "un "
  190.            Case 2: unidad = "dos "
  191.            Case 3: unidad = "tres "
  192.            Case 4: unidad = "cuatro "
  193.            Case 5: unidad = "cinco "
  194.        End Select
  195.    End If
  196.    Select Case bUnidad
  197.            Case 6: unidad = "seis "
  198.            Case 7: unidad = "siete "
  199.            Case 8: unidad = "ocho "
  200.            Case 9: unidad = "nueve "
  201.    End Select
  202. End Function
  203.  
  204.  

Temibles Lunas!¡.
17  Foros Generales / Foro Libre / [Youtube] Por lo hizo un usuario... en: 8 Noviembre 2011, 10:33 am
Solo vean este video... la tematica del video no importa revisen a detalle de donde demonios lo estan grabando...



Dulces Lunas!¡.
18  Programación / Programación Visual Basic / [Source] SpectrumColor ( Reconocimiento de tonos de colores ). en: 8 Octubre 2011, 21:55 pm
.
Estando dicutiendo con Psyke1 sobre un metodo de reconocimiento de colores y casi 2 semanas indagando en ello he creado esta clase que verifica si un color es similar a otro (Despresiando el componente Alpha).

Aqui les dejo e modulo de clase:

* La funcion que tiene es que reconoce TONOS de un color y retorna true si es derivado del mismo color ya sea un color mas claro u opaco.

cSpectrumColor.cls

Código
  1.  
  2. '
  3. '   /////////////////////////////////////////////////////////////
  4. '   //                                                         //
  5. '   // Autor:   BlackZeroX ( Ortega Avila Miguel Angel )       //
  6. '   //                                                         //
  7. '   // Web:     http://InfrAngeluX.Sytes.Net/                  //
  8. '   //                                                         //
  9. '   //    |-> Pueden Distribuir Este Codigo siempre y cuando   //
  10. '   // no se eliminen los creditos originales de este codigo   //
  11. '   // No importando que sea modificado/editado o engrandesido //
  12. '   // o achicado, si es en base a este codigo                 //
  13. '   /////////////////////////////////////////////////////////////
  14. '  // http://infrangelux.hostei.com/index.php?option=com_content&view=article&id=35:cspectrumcolor&catid=15:catmoduloscls&Itemid=24
  15. '   /////////////////////////////////////////////////////////////
  16.  
  17. Option Explicit
  18.  
  19. Private lRGBA       As Long
  20.  
  21. Public Property Get color() As Long
  22.    color = lRGBA
  23. End Property
  24.  
  25. Public Property Let color(ByVal lColor As Long)
  26.    lRGBA = lColor
  27. End Property
  28.  
  29. Public Function spectrumEqualL(ByVal lColorRGBA As Long, Optional ByVal lTolerance As Long = 10) As Boolean
  30. Dim oSpectrum       As cSpectrumColor
  31.    Set oSpectrum = New cSpectrumColor
  32.    oSpectrum.color = lColorRGBA
  33.    spectrumEqualL = spectrumEqualC(oSpectrum)
  34.    Set oSpectrum = Nothing
  35. End Function
  36.  
  37. Public Function spectrumEqualC(ByVal oSpectrum As cSpectrumColor, Optional ByVal lTolerance As Long = 10) As Boolean
  38. Dim lRed(1)             As Long
  39. Dim lGreen(1)           As Long
  40. Dim lBlue(1)            As Long
  41. Dim lBackColor          As Long
  42.  
  43.    lBackColor = oSpectrum.spectrumScale(oSpectrum.scaleFactorL(lRGBA) - 100)
  44.    Call oSpectrum.componentsRGBA(lRed(1), lGreen(1), lBlue(1), &H0)
  45.    oSpectrum.color = lBackColor
  46.  
  47.    Call componentsRGBA(lRed(0), lGreen(0), lBlue(0), &H0)
  48.  
  49.    If (max(lRed(0), lRed(1)) - min(lRed(0), lRed(1)) < lTolerance) Then
  50.        If (max(lGreen(0), lGreen(1)) - min(lGreen(0), lGreen(1)) < lTolerance) Then
  51.            If (max(lBlue(0), lBlue(1)) - min(lBlue(0), lBlue(1)) < lTolerance) Then
  52.                spectrumEqualC = True
  53.            End If
  54.        End If
  55.    End If
  56. End Function
  57.  
  58. Public Function spectrumScale(ByVal lScale As Double) As Long
  59. Dim lRed                As Long
  60. Dim lGreen              As Long
  61. Dim lBlue               As Long
  62. 'Dim lAlpha              As Long
  63.  
  64.    spectrumScale = lRGBA
  65.    Call componentsRGBA(lRed, lGreen, lBlue, &H0)
  66.    Call Me.colorFromRGBA(((lRed * (lScale / 100)) + lRed), ((lGreen * (lScale / 100)) + lGreen), ((lBlue * (lScale / 100)) + lBlue), &H0)
  67. End Function
  68.  
  69. Public Function scaleFactorL(ByVal lColorRGBA As Long) As Double
  70. Dim lRed                As Long
  71. Dim lGreen              As Long
  72. Dim lBlue               As Long
  73. 'Dim lAlpha              As Long
  74.  
  75.    Call componentsRGBA(lRed, lGreen, lBlue, &H0)
  76.  
  77.    Select Case max3(lRed, lGreen, lBlue)
  78.        Case lRed: If (lRed) Then scaleFactorL = (lColorRGBA And &HFF&) * 100 / lRed
  79.        Case lGreen: If (lGreen) Then scaleFactorL = ((lColorRGBA And &HFF00&) \ &H100&) * 100 / lGreen
  80.        Case lBlue: If (lBlue) Then scaleFactorL = ((lColorRGBA And &HFF0000) \ &H10000) * 100 / lBlue
  81.    End Select
  82.  
  83. End Function
  84.  
  85. Public Function scaleFactorC(ByVal oSpectrum As cSpectrumColor) As Double
  86.    scaleFactorC = scaleFactorL(oSpectrum.color())
  87. End Function
  88.  
  89. Private Function max(ByVal lVal1 As Long, ByVal lval2 As Long) As Long
  90.    If (lVal1 > lval2) Then
  91.        max = lVal1
  92.    Else
  93.        max = lval2
  94.    End If
  95. End Function
  96.  
  97. Private Function min(ByVal lVal1 As Long, ByVal lval2 As Long) As Long
  98.    If (lVal1 < lval2) Then
  99.        min = lVal1
  100.    Else
  101.        min = lval2
  102.    End If
  103. End Function
  104.  
  105. Private Function max3(ByVal lVal1 As Long, ByVal lval2 As Long, ByVal lval3 As Long) As Long
  106.    max3 = max(max(lVal1, lval2), lval3)
  107. End Function
  108.  
  109. Public Sub componentsRGBA(ByRef lRed As Long, ByRef lGreen As Long, ByRef lBlue As Long, ByRef lAlpha As Long)
  110.    lRed = (lRGBA And &HFF&)
  111.    lGreen = ((lRGBA And &HFF00&) / &H100&)
  112.    lBlue = ((lRGBA And &HFF0000) / &H10000)
  113.    lAlpha = ((lRGBA And &HFF000000) / &H1000000)
  114. End Sub
  115.  
  116. Public Sub colorFromRGBA(ByVal lRed As Long, ByVal lGreen As Long, ByVal lBlue As Long, ByVal lAlpha As Long)
  117.    lRGBA = (lRed)
  118.    lRGBA = (lRGBA Or ((lGreen And &HFF&) * &H100&))
  119.    lRGBA = (lRGBA Or ((lBlue And &HFF&) * &H10000))
  120.    lRGBA = (lRGBA Or ((lAlpha And &HFF&) * &H1000000))
  121. End Sub
  122.  
  123.  

Prueba/Test:

Código
  1.  
  2.  
  3. '   //  En un form...
  4. '   //  Se requieren 6 VScroll (con propiedad Index).
  5. '   //  Se requieren 2 PictureBox (con propiedad Index)
  6.  
  7. Option Explicit
  8.  
  9. Dim oSpectrum(1)    As cSpectrumColor
  10.  
  11. Private Sub Form_Load()
  12. Dim i           As Long
  13.    Set oSpectrum(0) = New cSpectrumColor
  14.    Set oSpectrum(1) = New cSpectrumColor
  15.  
  16.    For i = VScroll1.LBound To VScroll1.UBound
  17.        VScroll1(i).min = 0
  18.        VScroll1(i).max = 255
  19.    Next
  20. End Sub
  21.  
  22. Private Sub Form_Terminate()
  23.    Set oSpectrum(0) = Nothing
  24.    Set oSpectrum(1) = Nothing
  25. End Sub
  26.  
  27. Private Sub VScroll1_Change(Index As Integer)
  28.    Call VScroll1_Scroll(Index)
  29. End Sub
  30.  
  31. Private Sub VScroll1_Scroll(Index As Integer)
  32. Dim i           As Long
  33.    If (Index > &H2) Then i = 1
  34.    Picture1(i).BackColor = RGB(Int(VScroll1((i * 3)).Value), _
  35.                                Int(VScroll1((i * 3) + 1).Value), _
  36.                                Int(VScroll1((i * 3) + 2).Value))
  37.    oSpectrum(i).color = Picture1(i).BackColor
  38.    Debug.Print oSpectrum(i).spectrumEqualC(oSpectrum(i Xor 1)), i, i Xor 1
  39. End Sub
  40.  
  41.  

P.D.: el codigo lo estare editando y publicando en cSpectrumColor.

Temibles Lunas!¡.
19  Foros Generales / Foro Libre / Google mata a Bambi en: 27 Septiembre 2011, 10:05 am
Minuto 1:38  :xD :xD :xD :xD :xD :xD... podre animalito.



Dulces Lunas!¡.
20  Programación / Programación Visual Basic / [Source] cPushSort en: 27 Septiembre 2011, 04:33 am
.
Esta clase solo sive para agregar elementos y buscar dichos elementos de la manera ams rapida posible que con un simple array y un simple for next.

* Permite Agregar un array long (Se puede mejorar el algoritmo respecto a esto, pero lo deje asi.).
* Permite agregar Elementos Unicos en el momento que se desee.
* Retorna la posicion (IndexOf) si se encuentra de lo contrario retorna un valor constante INVALIDVALUEARRAY.
* Permite consultar X elemento ( GetElement).
* Permite eliminar X elemento segun su indice ( Remove(); posiblemente se tenga que buscar primero con IndexOf() ).
* Retorna la cantidad de elementos.
* Tiene una tasa de BUSQUEDA MUY RAPIDA.

Código
  1.  
  2. '
  3. '   /////////////////////////////////////////////////////////////
  4. '   //                                                         //
  5. '   // Autor:   BlackZeroX ( Ortega Avila Miguel Angel )       //
  6. '   //                                                         //
  7. '   // Web:     http://InfrAngeluX.Sytes.Net/                  //
  8. '   //                                                         //
  9. '   //    |-> Pueden Distribuir Este Codigo siempre y cuando   //
  10. '   // no se eliminen los creditos originales de este codigo   //
  11. '   // No importando que sea modificado/editado o engrandesido //
  12. '   // o achicado, si es en base a este codigo                 //
  13. '   /////////////////////////////////////////////////////////////
  14.  
  15. Option Explicit
  16.  
  17. Private lMem()          As Long
  18. Private lCount          As Long
  19. Private bDuplicate      As Boolean
  20.  
  21. Public Sub clear()
  22.    Erase lMem()
  23.    lCount = 0
  24. End Sub
  25.  
  26. Public Property Get Count() As Long
  27.    Count = lCount
  28. End Property
  29.  
  30. '   //  Retorna la cantidad de elementos restantes.
  31. Public Function Remove(ByVal lIndex As Long) As Long
  32.    Remove = RemoveInArrayLong(lIndex, lMem())
  33. End Function
  34.  
  35. Public Property Get DuplicateElements() As Boolean
  36.    DuplicateElements = bDuplicate
  37. End Property
  38.  
  39. Public Property Let DuplicateElements(ByVal bBool As Boolean)
  40.    bDuplicate = bBool
  41. End Property
  42.  
  43. '   //  Agrega un array a la coleccion y retorna la cantidad de elementos agregados a ella.
  44. Public Function AddArray(ByRef lArray() As Long) As Long
  45. Dim i                   As Long
  46. Dim c                   As Long
  47.    If Not (ItsArrayINI(VarPtrA(lArray))) Then Exit Function
  48.    c = lCount
  49.    For i = LBound(lArray()) To UBound(lArray())
  50.        Me.Add lArray(i)
  51.    Next
  52.    AddArray = (lCount - c) '   //  Cantidad de elementos REALMENTE AGREGADOS: es igual a la direfencia del valor anterior y el actual de lCount.
  53. End Function
  54.  
  55. '   //  Inserta en el Array el elemento Dado de manera Ascendente.
  56. '   //  Agrega lVal en la coleccion de manera ordenada, y retorna el indice de su hubicacion.
  57. '   //  Se retorna el indice de la hubicacion (...cambia este indice si se agrega otro y es menor a este...).
  58. Public Function Add(ByVal lVal As Long) As Long
  59. Dim lRetPos             As Long
  60.    '   //  Buscamos la posicion en donde insertar...
  61.    If ExitsInArray(lVal, lMem(), lRetPos) And Not bDuplicate Then Exit Function
  62.    ReDim Preserve lMem(lCount)
  63.    lCount = (lCount + 1)
  64.    If ((lCount - 1) - lRetPos) Then '   //  Recorremos a la derecha TODOS los elementos.
  65.        CopyMemory VarPtr(lMem(lRetPos + 1)), VarPtr(lMem(lRetPos)), ((lCount - lRetPos) * &H4)
  66.    End If
  67.    lMem(lRetPos) = lVal
  68.    Add = lRetPos
  69. End Function
  70.  
  71. '   //  Obtenemos una copia de la coleccion de elementos.
  72. Public Function GetArray() As Long()
  73.    GetArray = lMem()
  74. End Function
  75.  
  76. Public Function IndexOf(ByVal lVal As Long) As Long
  77.    If Not ExitsInArray(lVal, lMem, IndexOf) Then IndexOf = INVALIDVALUEARRAY
  78. End Function
  79.  
  80. Public Function GetElement(ByVal lIndex As Long) As Long
  81.    If (lIndex < lCount) Then GetElement = lMem(lIndex)
  82. End Function
  83.  
  84. Private Function ExitsInArray(ByRef lVal As Long, ByRef lArray() As Long, ByRef lRetPos As Long) As Boolean
  85. Dim lLIndex                 As Long
  86. Dim lUIndex                 As Long
  87. Dim iSortType               As Long
  88.  
  89.    If Not (ItsArrayINI(VarPtrA(lArray))) Then lRetPos = 0: Exit Function
  90.  
  91.    lLIndex = LBound(lArray())
  92.    lUIndex = UBound(lArray())
  93.  
  94.    If (lArray(lUIndex) < lArray(lLIndex)) Then
  95.        SwapLong lLIndex, lUIndex
  96.        iSortType = 1
  97.    End If
  98.  
  99.    If (lVal < lArray(lLIndex)) Then
  100.        lRetPos = lLIndex
  101.    ElseIf (lVal = lArray(lLIndex)) Then
  102.        lRetPos = lLIndex
  103.        ExitsInArray = True
  104.    Else
  105.        If (lVal > lArray(lUIndex)) Then
  106.            lRetPos = lUIndex
  107.        ElseIf (lVal = lArray(lUIndex)) Then
  108.            lRetPos = lUIndex
  109.            ExitsInArray = True
  110.        Else
  111.            Do Until ExitsInArray
  112.                lRetPos = ((lLIndex + lUIndex) \ 2)
  113.                If ((lRetPos <> lLIndex) And (lRetPos <> lUIndex)) Then
  114.                    If (lArray(lRetPos) < lVal) Then
  115.                        lLIndex = lRetPos
  116.                    ElseIf (lArray(lRetPos) > lVal) Then
  117.                        lUIndex = lRetPos
  118.                    ElseIf (lArray(lRetPos) = lVal) Then
  119.                        ExitsInArray = True
  120.                    End If
  121.                Else
  122.                    Exit Do
  123.                End If
  124.            Loop
  125.        End If
  126.    End If
  127.  
  128.    If Not (ExitsInArray) Then              '   //  Obtenemos la posicion donde deberia estar dicho elemento.
  129.        If (iSortType = 1) Then
  130.            If (lArray(lRetPos) > lVal) Then lRetPos = (lRetPos - 1)
  131.        Else
  132.            If (lArray(lRetPos) < lVal) Then lRetPos = (lRetPos + 1)
  133.        End If
  134.    End If
  135.  
  136. End Function
  137.  
  138. Private Sub Class_Terminate()
  139.    Call Me.clear
  140. End Sub
  141.  
  142.  

En un Modulo...
Código
  1.  
  2. Option Explicit
  3.  
  4. Public Const INVALIDVALUEARRAY As Long = (-1)
  5.  
  6. Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal pDest As Long, ByVal pSrc As Long, ByVal ByteLen As Long)
  7. Public Declare Function VarPtrA Lib "msvbvm60.dll" Alias "VarPtr" (ByRef Ptr() As Any) As Long
  8.  
  9. Public Function ItsArrayINI(ByVal lngPtr As Long, Optional LnBytes As Long = 4) As Boolean
  10. Dim lng_PtrSA                   As Long
  11.    If ((lngPtr <> 0) And (LnBytes > 0)) Then
  12.        Call CopyMemory(ByVal VarPtr(lng_PtrSA), ByVal lngPtr, LnBytes)
  13.        ItsArrayINI = (Not (lng_PtrSA = 0))
  14.    End If
  15. End Function
  16.  
  17. Public Sub SwapLong(ByRef lVal1 As Long, ByRef lval2 As Long)
  18.    lval2 = lval2 Xor lVal1
  19.    lVal1 = lVal1 Xor lval2
  20.    lval2 = lval2 Xor lVal1
  21. End Sub
  22.  
  23. '   //  Return (Cantidad de elementos).
  24. Public Function RemoveInArrayLong(ByVal lIndex As Long, ByRef lArray() As Long) As Long
  25.    If (ItsArrayINI(VarPtrA(lArray)) = True) Then
  26.        RemoveInArrayLong = UBound(lArray)
  27.        If Not ((lIndex < 0) Or (lIndex > RemoveInArrayLong)) Then
  28.            If Not (lIndex = RemoveInArrayLong) Then
  29.                Call CopyMemory(ByVal VarPtr(lArray(lIndex)), ByVal VarPtr(lArray(lIndex + 1)), (RemoveInArrayLong - lIndex) * 4)
  30.            End If
  31.            If ((RemoveInArrayLong - 1) > INVALIDVALUEARRAY) Then
  32.                ReDim Preserve lArray(RemoveInArrayLong - 1)
  33.            Else
  34.                Erase lArray()
  35.            End If
  36.        End If
  37.    End If
  38. End Function
  39.  
  40.  

Temibles Lunas!¡.
Páginas: 1 [2] 3 4 5 6 7 8 9 10 11 12 13 14
WAP2 - Aviso Legal - Powered by SMF 1.1.21 | SMF © 2006-2008, Simple Machines