Recopilacion de Funciones con operaciones Binarias.

<< < (3/3)

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
 
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
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
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! :P

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

Una sub? mas bien no
Código:

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:

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
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.

Navegación

[0] Índice de Mensajes

[*] Página Anterior