Recopilacion de Funciones con operaciones Binarias.

[arfgh]

Este tópico es genial, no obstante estaría bien que pusieseis también las operaciones con bits tipo shr y shl.

[BlackZeroX]

Alternativa a la función Xor...

Código (vb) [Seleccionar] Expandir



Option Explicit

Private Sub Form_Load()
Const a As Long = 0
Const b As Long = 1
    MsgBox Xor_alt(a, b) & vbCrLf & (a Xor b)
End Sub

Public Function Xor_alt(ByVal n1 As Long, ByVal n2 As Long) As Long
    Xor_alt = (Not n1) And n2 Or (Not n2) And n1
End Function




P.D.: Necesito crearle un Indice a este tema... cuando tenga tiempo libre lo haré...

Dulces Lunas!¡.

[79137913]

HOLA!!!

Deberias agregar el reto de reemplazo de operadores binarios:


And, Not, Xor y Or reemplazados:

Código (vb) [Seleccionar] Expandir

Private Function AndAlt(Byte1 As Long, Byte2 As Long) As Long
Dim bit1() As Boolean
Dim bit2() As Boolean
Dim bit3() As Boolean
Dim CT     As Long
Dim Tam    As Long
Dim b1     As Long
Dim b2     As Long
b1 = Byte1
b2 = Byte2
   Do
       ReDim Preserve bit1(CT)
       If b1 = 1 Then ReDim Preserve bit1(CT): bit1(CT) = True: Exit Do
       If b1 = 0 Then ReDim Preserve bit1(CT): Exit Do
       bit1(CT) = CBool(b1 Mod 2)
       b1 = Fix(b1 / 2)
       CT = CT + 1
   Loop
   CT = 0
   Do
       If b2 = 1 Then ReDim Preserve bit2(CT): bit2(CT) = True: Exit Do
       If b2 = 0 Then ReDim Preserve bit2(CT): Exit Do
       ReDim Preserve bit2(CT)
       bit2(CT) = CBool(b2 Mod 2)
       b2 = Fix(b2 / 2)
       CT = CT + 1
   Loop
   If UBound(bit1) > UBound(bit2) Then ReDim Preserve bit2(UBound(bit1))
   If UBound(bit1) < UBound(bit2) Then ReDim Preserve bit1(UBound(bit2))
   Tam = UBound(bit1)
   ReDim bit3(Tam)
   For X = 0 To Tam
       If bit1(X) Then If bit2(X) Then bit3(X) = True
   Next
   For X = 0 To Tam
       If bit3(X) Then AndAlt = AndAlt + 2 ^ (X)
   Next

End Function

Private Function OrAlt(Byte1 As Long, Byte2 As Long) As Long
Dim bit1() As Boolean
Dim bit2() As Boolean
Dim bit3() As Boolean
Dim CT     As Long
Dim Tam    As Long
Dim b1     As Long
Dim b2     As Long
b1 = Byte1
b2 = Byte2
   Do
       ReDim Preserve bit1(CT)
       If b1 = 1 Then ReDim Preserve bit1(CT): bit1(CT) = True: Exit Do
       If b1 = 0 Then ReDim Preserve bit1(CT): Exit Do
       bit1(CT) = CBool(b1 Mod 2)
       b1 = Fix(b1 / 2)
       CT = CT + 1
   Loop
   CT = 0
   Do
       If b2 = 1 Then ReDim Preserve bit2(CT): bit2(CT) = True: Exit Do
       If b2 = 0 Then ReDim Preserve bit2(CT): Exit Do
       ReDim Preserve bit2(CT)
       bit2(CT) = CBool(b2 Mod 2)
       b2 = Fix(b2 / 2)
       CT = CT + 1
   Loop
   If UBound(bit1) > UBound(bit2) Then ReDim Preserve bit2(UBound(bit1))
   If UBound(bit1) < UBound(bit2) Then ReDim Preserve bit1(UBound(bit2))
   Tam = UBound(bit1)
   ReDim bit3(Tam)
   For X = 0 To Tam
       If bit1(X) Then bit3(X) = True
       If bit2(X) Then bit3(X) = True
   Next
   For X = 0 To Tam
       If bit3(X) Then OrAlt = OrAlt + 2 ^ (X)
   Next

End Function

Private Function XorAlt(Byte1 As Long, Byte2 As Long) As Long
Dim bit1() As Boolean
Dim bit2() As Boolean
Dim bit3() As Boolean
Dim CT     As Long
Dim Tam    As Long
Dim b1     As Long
Dim b2     As Long
b1 = Byte1
b2 = Byte2
   Do
       ReDim Preserve bit1(CT)
       If b1 = 1 Then ReDim Preserve bit1(CT): bit1(CT) = True: Exit Do
       If b1 = 0 Then ReDim Preserve bit1(CT): Exit Do
       bit1(CT) = CBool(b1 Mod 2)
       b1 = Fix(b1 / 2)
       CT = CT + 1
   Loop
   CT = 0
   Do
       If b2 = 1 Then ReDim Preserve bit2(CT): bit2(CT) = True: Exit Do
       If b2 = 0 Then ReDim Preserve bit2(CT): Exit Do
       ReDim Preserve bit2(CT)
       bit2(CT) = CBool(b2 Mod 2)
       b2 = Fix(b2 / 2)
       CT = CT + 1
   Loop
   If UBound(bit1) > UBound(bit2) Then ReDim Preserve bit2(UBound(bit1))
   If UBound(bit1) < UBound(bit2) Then ReDim Preserve bit1(UBound(bit2))
   Tam = UBound(bit1)
   ReDim bit3(Tam)
   For X = 0 To Tam
       If bit1(X) Then If bit2(X) = False Then bit3(X) = True
       If bit2(X) Then If bit1(X) = False Then bit3(X) = True
   Next
   For X = 0 To Tam
       If bit3(X) Then XorAlt = XorAlt + 2 ^ (X)
   Next

End Function

Private Function NotAlt(Byte1 As Long) As Long
   NotAlt = -(Byte1 + 1)
End Function

GRACIAS POR LEER!!!

[Psyke1]

Un oneliner que he tenido que crear para un proyecto en curso.
Devuelve la diferencia entre dos colores con un número del 0 al 100 según el porcentaje.

Código (vb) [Seleccionar] Expandir


Public Function ColorDiff(ByVal lC1 As Long, ByVal lC2 As Long) As Single
   ColorDiff = &H64 - &H64 * (Abs((lC1 And &HFF) - (lC2 And &HFF)) + Abs(((lC1 \ &H100) And &HFF) - ((lC2 \ &H100) And &HFF)) + Abs(((lC1 \ &H10000) And &HFF) - ((lC2 \ &H10000) And &HFF))) / &H2FD
End Function

DoEvents!

[pkj]

Es una buena idea, pero podriais corregir los fallos gordos, que aqui dejan editar

Una sub? mas bien no

Código [Seleccionar] Expandir


Private Sub lIsNegative(ByRef lVal As Long)

   '   //  Para cualquier valor que lVal pueda tomar.

   '   //  Comprueba si lval es negativo.

   lIsNegative = (lVal And &H80000000)

End Sub


Una Sub con End Function?

Código [Seleccionar] Expandir


Private sub ColorLongToRGB(ByVal LngColor As Long, ByRef OutRed As Byte, ByRef OutGreen As Byte, ByRef OutBlue As Byte)

  OutBlue = (LngColor And &HFF0000) \ &H10000

  OutGreen = (LngColor And &HFF00&) \ &H100

  OutRed = (LngColor And &HFF)

End Function


Saludos

EDIT:

Para que veais que no solo me gusta criticar, aprovecho para dejaros mi version super cutre de los operadores And, Or, Xor y Not.
Es muy rustica pero no contiene ni un And, Or, Xor, Not y parece funcionar con positivos, negativos y mezclas y ya de paso incluye las conversiones Bin2Hex, Hex2Bin, etc...

Código (vb) [Seleccionar] Expandir


Private Function OrAlt(ByVal Valor1 As Long, ByVal Valor2 As Long) As Long
 Dim V1 As String
 Dim V2 As String
 V1 = Dec2Bin(Valor1)
 V2 = Dec2Bin(Valor2)
 
 Dim UnBit As String
 Dim Res As String
 Dim F As Integer
 For F = 1 To Len(V1)
   UnBit = "0"
   If Mid(V1, F, 1) = 1 Then UnBit = "1"
   If Mid(V2, F, 1) = 1 Then UnBit = "1"
   Res = Res & UnBit
 Next F
 
 OrAlt = Bin2Dec(Res)

End Function

Private Function AndAlt(ByVal Valor1 As Long, ByVal Valor2 As Long) As Long
 Dim V1 As String
 Dim V2 As String
 V1 = Dec2Bin(Valor1)
 V2 = Dec2Bin(Valor2)
 
 Dim UnBit As String
 Dim CuentaOK As Integer
 Dim Res As String
 Dim F As Integer
 For F = 1 To Len(V1)
   CuentaOK = 0
   UnBit = "0"
   If Mid(V1, F, 1) = 1 Then CuentaOK = CuentaOK + 1
   If Mid(V2, F, 1) = 1 Then CuentaOK = CuentaOK + 1
   If CuentaOK = 2 Then UnBit = "1"
   Res = Res & UnBit
 Next F
 
 AndAlt = Bin2Dec(Res)

End Function

Private Function XorAlt(ByVal Valor1 As Long, ByVal Valor2 As Long) As Long
 Dim V1 As String
 Dim V2 As String
 V1 = Dec2Bin(Valor1)
 V2 = Dec2Bin(Valor2)
 
 Dim UnBit As String
 Dim CuentaOK As Integer
 Dim Res As String
 Dim F As Integer
 For F = 1 To Len(V1)
   CuentaOK = 0
   UnBit = "0"
   If Mid(V1, F, 1) = 1 Then CuentaOK = CuentaOK + 1
   If Mid(V2, F, 1) = 1 Then CuentaOK = CuentaOK + 1
   If CuentaOK = 1 Then UnBit = "1"
   Res = Res & UnBit
 Next F
 
 XorAlt = Bin2Dec(Res)

End Function

Private Function NotAlt(ByVal Valor1 As Long) As Long
 Dim V1 As String
 Dim V2 As String
 V1 = Dec2Bin(Valor1)
 
 Dim UnBit As String
 Dim Res As String
 Dim F As Integer
 For F = 1 To Len(V1)
   If Mid(V1, F, 1) = "1" Then
     UnBit = "0"
   Else
     UnBit = "1"
   End If
   Res = Res & UnBit
 Next F
 
 NotAlt = Bin2Dec(Res)

End Function

Function Bin2Dec(ByVal sBinario As String) As Long
 'Bin2Dec = CDec("&H" & Bin2Hex(sBinario)) 'no hace falta el cdec :O
 Bin2Dec = "&H" & Bin2Hex(sBinario)
End Function

Public Function Dec2Bin(ByVal Valor As Long, Optional MinBits As Integer = 32) As String
 Dec2Bin = Hex2Bin(Hex$(Valor))
 Do Until Len(Dec2Bin) >= MinBits
   Dec2Bin = "0" & Dec2Bin
 Loop
End Function

Function Bin2Hex(ByVal StrBin As String) As String
 Dim F As Long

 Do Until Len(StrBin) / 4 = Len(StrBin) \ 4
   StrBin = "0" & StrBin
 Loop
 For F = Len(StrBin) - 3 To 1 Step -4
   
   Select Case Mid$(StrBin, F, 4)
     Case "0000"
       Bin2Hex = "0" & Bin2Hex
     Case "0001"
       Bin2Hex = "1" & Bin2Hex
     Case "0010"
       Bin2Hex = "2" & Bin2Hex
     Case "0011"
       Bin2Hex = "3" & Bin2Hex
     Case "0100"
       Bin2Hex = "4" & Bin2Hex
     Case "0101"
       Bin2Hex = "5" & Bin2Hex
     Case "0110"
       Bin2Hex = "6" & Bin2Hex
     Case "0111"
       Bin2Hex = "7" & Bin2Hex
     Case "1000"
       Bin2Hex = "8" & Bin2Hex
     Case "1001"
       Bin2Hex = "9" & Bin2Hex
     Case "1010"
       Bin2Hex = "A" & Bin2Hex
     Case "1011"
       Bin2Hex = "B" & Bin2Hex
     Case "1100"
       Bin2Hex = "C" & Bin2Hex
     Case "1101"
       Bin2Hex = "D" & Bin2Hex
     Case "1110"
       Bin2Hex = "E" & Bin2Hex
     Case "1111"
       Bin2Hex = "F" & Bin2Hex
 
   End Select
 Next F
 
End Function

Function Hex2Bin(ByVal CadenaHexadecimal As String) As String
 Dim F As Long
 
 CadenaHexadecimal = UCase(CadenaHexadecimal)
 
 If Len(CadenaHexadecimal) > 0 Then
   For F = Len(CadenaHexadecimal) To 1 Step -1
     Select Case Mid$(CadenaHexadecimal, F, 1)
       Case "0":
         Hex2Bin = "0000" & Hex2Bin
       Case "1":
         Hex2Bin = "0001" & Hex2Bin
       Case "2":
         Hex2Bin = "0010" & Hex2Bin
       Case "3":
         Hex2Bin = "0011" & Hex2Bin
       Case "4":
         Hex2Bin = "0100" & Hex2Bin
       Case "5":
         Hex2Bin = "0101" & Hex2Bin
       Case "6":
         Hex2Bin = "0110" & Hex2Bin
       Case "7":
         Hex2Bin = "0111" & Hex2Bin
       Case "8":
         Hex2Bin = "1000" & Hex2Bin
       Case "9":
         Hex2Bin = "1001" & Hex2Bin
       Case "A":
         Hex2Bin = "1010" & Hex2Bin
       Case "B":
         Hex2Bin = "1011" & Hex2Bin
       Case "C":
         Hex2Bin = "1100" & Hex2Bin
       Case "D":
         Hex2Bin = "1101" & Hex2Bin
       Case "E":
         Hex2Bin = "1110" & Hex2Bin
       Case "F":
         Hex2Bin = "1111" & Hex2Bin
     End Select
   
   Next F
 End If
 On Local Error GoTo 0
End Function


Saludos.