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
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
[*] Página Anterior