Generar SHA384 con Visual Basic Excel
Necesito crear en Excel un código o una librería que me genere un código de encriptación SHA384, esto es que convierte cualquier texto en un dato encriptado, pueden encontrar un aplicativo en linea en http://www.sha1-online.com/
Como necesito que se genere el código fuera de linea, tengo unas instrucciones para crear el aplicativo en Visual Basic (Visual Studio), el formulario debe tener 2 Textbox y un botón, y la instrucción del botón es la que se muestra a continuación:
Imports System.Text
Imports System. Security. Cryptography
Public Class Form1
Private Sub Form1_load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
End Sub
Private Function SHA384(ByVal Content As String) As String
Dim MoLeCuL3 As New Security.Cryptography.SHA384CryptoServiceProvider
Dim ByteString() As Byte = System.Text.Encoding.ASCII.GetBytes(Content)
ByteString = MoLeCuL3.ComputeHash(ByteString)
Dim FinalString As String = Nothing
For Each bt As Byte In ByteString
FinalString &= bt.ToString("x2")
Next
Return FinalString
End Function
Private Sub Button1_clid(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
TextBox2.Text = SHA384(TextBox1.Text)
End Sub
Private Sub Label1_Click(sender As Object, e As EventArgs) Handles Label1.Click
End Sub
End Class
El problema es que no sé cómo crear algo similar en un libro de Excel, si alguien puede ayudarme me ayudaría enormemente ya que no se consigue ninguna literatura al respecto en internet.
Hace tiempo me pasaron un código para encriptar basado en sha1 no se si sea 384, este es el resultado que da, la función que debes teclear después de copiar la macro es =SHA1HASH(str)
Donde str es la celda donde este el texto que quieres encriptar
y esta es la macro
'Attribute VB_Name = "SHA1vb" Option Explicit Private Type FourBytes a As Byte b As Byte c As Byte d As Byte End Type Private Type OneLong L As Long End Type Function HexDefaultSHA1(Message() As Byte) As String Dim H1 As Long, H2 As Long, H3 As Long, H4 As Long, H5 As Long DefaultSHA1 Message, H1, H2, H3, H4, H5 HexDefaultSHA1 = DecToHex5(H1, H2, H3, H4, H5) End Function Function HexSHA1(Message() As Byte, ByVal Key1 As Long, ByVal Key2 As Long, ByVal Key3 As Long, ByVal Key4 As Long) As String Dim H1 As Long, H2 As Long, H3 As Long, H4 As Long, H5 As Long SHA1 Message, Key1, Key2, Key3, Key4, H1, H2, H3, H4, H5 HexSHA1 = DecToHex5(H1, H2, H3, H4, H5) End Function Sub DefaultSHA1(Message() As Byte, H1 As Long, H2 As Long, H3 As Long, H4 As Long, H5 As Long) SHA1 Message, &H5A827999, &H6ED9EBA1, &H8F1BBCDC, &HCA62C1D6, H1, H2, H3, H4, H5 End Sub Sub SHA1(Message() As Byte, ByVal Key1 As Long, ByVal Key2 As Long, ByVal Key3 As Long, ByVal Key4 As Long, H1 As Long, H2 As Long, H3 As Long, H4 As Long, H5 As Long) 'CA62C1D68F1BBCDC6ED9EBA15A827999 + "abc" = "A9993E36 4706816A BA3E2571 7850C26C 9CD0D89D" '"abc" = "A9993E36 4706816A BA3E2571 7850C26C 9CD0D89D" Dim U As Long, P As Long Dim FB As FourBytes, OL As OneLong Dim i As Integer Dim W(80) As Long Dim a As Long, b As Long, c As Long, d As Long, E As Long Dim T As Long H1 = &H67452301: H2 = &HEFCDAB89: H3 = &H98BADCFE: H4 = &H10325476: H5 = &HC3D2E1F0 U = UBound(Message) + 1: OL.L = U32ShiftLeft3(U): a = U \ &H20000000: LSet FB = OL 'U32ShiftRight29(U) ReDim Preserve Message(0 To (U + 8 And -64) + 63) Message(U) = 128 U = UBound(Message) Message(U - 4) = a Message(U - 3) = FB.d Message(U - 2) = FB.c Message(U - 1) = FB.b Message(U) = FB.a While P < U For i = 0 To 15 FB.d = Message(P) FB.c = Message(P + 1) FB.b = Message(P + 2) FB.a = Message(P + 3) LSet OL = FB W(i) = OL.L P = P + 4 Next i For i = 16 To 79 W(i) = U32RotateLeft1(W(i - 3) Xor W(i - 8) Xor W(i - 14) Xor W(i - 16)) Next i a = H1: b = H2: c = H3: d = H4: E = H5 For i = 0 To 19 T = U32Add(U32Add(U32Add(U32Add(U32RotateLeft5(a), E), W(i)), Key1), ((b And c) Or ((Not b) And d))) E = d: d = c: c = U32RotateLeft30(b): b = a: a = T Next i For i = 20 To 39 T = U32Add(U32Add(U32Add(U32Add(U32RotateLeft5(a), E), W(i)), Key2), (b Xor c Xor d)) E = d: d = c: c = U32RotateLeft30(b): b = a: a = T Next i For i = 40 To 59 T = U32Add(U32Add(U32Add(U32Add(U32RotateLeft5(a), E), W(i)), Key3), ((b And c) Or (b And d) Or (c And d))) E = d: d = c: c = U32RotateLeft30(b): b = a: a = T Next i For i = 60 To 79 T = U32Add(U32Add(U32Add(U32Add(U32RotateLeft5(a), E), W(i)), Key4), (b Xor c Xor d)) E = d: d = c: c = U32RotateLeft30(b): b = a: a = T Next i H1 = U32Add(H1, a): H2 = U32Add(H2, b): H3 = U32Add(H3, c): H4 = U32Add(H4, d): H5 = U32Add(H5, E) Wend End Sub Function U32Add(ByVal a As Long, ByVal b As Long) As Long If (a Xor b) < 0 Then U32Add = a + b Else U32Add = (a Xor &H80000000) + b Xor &H80000000 End If End Function Function U32ShiftLeft3(ByVal a As Long) As Long U32ShiftLeft3 = (a And &HFFFFFFF) * 8 If a And &H10000000 Then U32ShiftLeft3 = U32ShiftLeft3 Or &H80000000 End Function Function U32ShiftRight29(ByVal a As Long) As Long U32ShiftRight29 = (a And &HE0000000) \ &H20000000 And 7 End Function Function U32RotateLeft1(ByVal a As Long) As Long U32RotateLeft1 = (a And &H3FFFFFFF) * 2 If a And &H40000000 Then U32RotateLeft1 = U32RotateLeft1 Or &H80000000 If a And &H80000000 Then U32RotateLeft1 = U32RotateLeft1 Or 1 End Function Function U32RotateLeft5(ByVal a As Long) As Long U32RotateLeft5 = (a And &H3FFFFFF) * 32 Or (a And &HF8000000) \ &H8000000 And 31 If a And &H4000000 Then U32RotateLeft5 = U32RotateLeft5 Or &H80000000 End Function Function U32RotateLeft30(ByVal a As Long) As Long U32RotateLeft30 = (a And 1) * &H40000000 Or (a And &HFFFC) \ 4 And &H3FFFFFFF If a And 2 Then U32RotateLeft30 = U32RotateLeft30 Or &H80000000 End Function Function DecToHex5(ByVal H1 As Long, ByVal H2 As Long, ByVal H3 As Long, ByVal H4 As Long, ByVal H5 As Long) As String Dim H As String, L As Long DecToHex5 = "00000000 00000000 00000000 00000000 00000000" H = Hex(H1): L = Len(H): Mid(DecToHex5, 9 - L, L) = H H = Hex(H2): L = Len(H): Mid(DecToHex5, 18 - L, L) = H H = Hex(H3): L = Len(H): Mid(DecToHex5, 27 - L, L) = H H = Hex(H4): L = Len(H): Mid(DecToHex5, 36 - L, L) = H H = Hex(H5): L = Len(H): Mid(DecToHex5, 45 - L, L) = H End Function Public Function SHA1HASH(str) Dim i As Integer Dim arr() As Byte ReDim arr(0 To Len(str) - 1) As Byte For i = 0 To Len(str) - 1 arr(i) = Asc(Mid(str, i + 1, 1)) Next i SHA1HASH = Replace(LCase(HexDefaultSHA1(arr)), " ", "") End Function
