First of all I am not a native English speaker and new here. It is also not a question, but a possible solution.
I've been looking for a complete solution on how to implement the Google Authenticator App function in VBA. But all hmac and sha1 examples I found give wrong results.
Therefore, using other programming languages, I reproduced the logic. Sources that helped me from the community are given in the source code.
The code works for me, but I am an amateur in VBA. Maybe it is helpful and any optimization is welcome to me.
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Private Declare Sub GetSystemTime Lib "Kernel32" (ByRef lpSystemTime As SYSTEMTIME)
Sub otp()
Dim Key As String, Secret As String, Time As String, hmac As String, ch As String, p1 As String, p2 As String, otp As String
Dim offset As Long, d As Long, i As Long, n As Long, j As Long, a As Long
Secret = UCase("<replace with secret from QR>")
If Len(Secret) >= 20 Then
n = 0
j = 0
' stackoverflow.com/questions/60327784/converting-from-base-32-to-decimal-without-vba
' Change: use base32 variant
For i = 1 To Len(Secret)
ch = Mid$(Secret, i, 1)
If ch >= "A" And ch <= "Z" Then
d = asc(ch) - asc("A")
ElseIf ch >= "2" And ch <= "7" Then
d = asc(ch) - asc("0") + 24
End If
' www.idontplaydarts.com/2011/07/google-totp-two-factor-authentication-for-php/
' reproduced
n = (ShiftLeft(n, 5)) + d
j = j + 5
If j >= 8 Then
j = j - 8
Key = Key & WorksheetFunction.Dec2Hex(ShiftRight((n And ShiftLeft(255, j)), j), 2)
End If
Next i
Time = Right("0000000000000000" & Hex(WorksheetFunction.Floor(CurrentTimeMillis() / 1000 / 30, 1)), 16)
hmac = HEX_HMACSHA1(Time, Key)
offset = Hex2UInt(Right(hmac, 1))
p2 = Hex2UInt("7fffffff")
If offset = 0 Then
p1 = Hex2UInt(Left(hmac, 8))
Else
p1 = Hex2UInt(Mid(hmac, offset * 2 + 1, 8))
End If
otp = Right(WorksheetFunction.Bitand(p1, p2), 6)
Debug.Print otp
End If
End Sub
' stackoverflow.com/questions/29772224/get-unix-time-milliseconds
Function CurrentTimeMillis() As Double
' Returns the milliseconds from 1970/01/01 00:00:00.0 to system UTC
Dim st As SYSTEMTIME
GetSystemTime st
Dim t_Start, t_Now
t_Start = DateSerial(1970, 1, 1) ' Starting time for Linux
t_Now = DateSerial(st.wYear, st.wMonth, st.wDay) + _
TimeSerial(st.wHour, st.wMinute, st.wSecond)
CurrentTimeMillis = DateDiff("s", t_Start, t_Now) * 1000 + st.wMilliseconds
End Function
' stackoverflow.com/questions/40213758/convert-hex-string-to-unsigned-int-vba
Function Hex2UInt(h As String) As Double
Dim dbl As Double: dbl = CDbl("&h" & h)
If dbl < 0 Then
dbl = CDbl("&h1" & h) - 4294967296#
End If
Hex2UInt = dbl
End Function
' mrexcel.com/board/threads/hmac-sha1-hash-hex-input-string.1137771/
' Change: use byte array with unsigned integer and return hex with leading zeros
Public Function HEX_HMACSHA1(ByVal sTextToHash As String, ByVal sSharedSecretKey As String) As String
Dim asc As Object
Dim enc As Object
Dim TextToHash() As Byte
Dim SharedSecretKey() As Byte
Dim Bytes() As Byte
Dim sHexString As String
Dim i As Long
Set asc = CreateObject("System.Text.UTF8Encoding")
Set enc = CreateObject("System.Security.Cryptography.HMACSHA1")
TextToHash = HexStringToByteArray(sTextToHash)
SharedSecretKey = HexStringToByteArray(sSharedSecretKey)
enc.Key = SharedSecretKey
Bytes = enc.ComputeHash_2((TextToHash))
HEX_HMACSHA1 = ByteArrayToHexStr(Bytes)
Set asc = Nothing
Set enc = Nothing
End Function
' stackoverflow.com/questions/44979363/excel-vba-regex-function-that-returns-multiple-matches-into-a-single-cell
' Change: create byte array with unsigned integer
Function HexStringToByteArray(strInput As String) As Byte()
Dim rMatch As Object
Dim s As String
Dim arrayMatches() As Byte
Dim i As Long
With New RegExp
.Global = True
.MultiLine = True
.IgnoreCase = True
.Pattern = "([A-F0-9]{2})"
If .Test(strInput) Then
For Each rMatch In .Execute(strInput)
ReDim Preserve arrayMatches(i)
arrayMatches(i) = Hex2UInt(rMatch.Value)
i = i + 1
Next
End If
End With
HexStringToByteArray = arrayMatches
End Function
' https://www.vbforums.com/showthread.php?559398-Byte-array-to-hex-string
' Change: removed Spaces between Hex
Function ByteArrayToHexStr(b() As Byte) As String
Dim n As Long, i As Long
ByteArrayToHexStr = Space$(2 * (UBound(b) - LBound(b)) + 2)
n = 1
For i = LBound(b) To UBound(b)
Mid$(ByteArrayToHexStr, n, 2) = Right$("00" & Hex$(b(i)), 2)
n = n + 2
Next
End Function
' xbeat.net/vbspeed/c_ShiftLeft.htm
Public Static Function ShiftLeft(ByVal Value As Long, ByVal ShiftCount As Long) As Long
' by Jost Schwider, jost@schwider.de, 20010928
Dim Pow2(0 To 31) As Long
Dim i As Long
Dim mask As Long
Select Case ShiftCount
Case 1 To 31
'Ggf. Initialisieren:
If i = 0 Then
Pow2(0) = 1
For i = 1 To 30
Pow2(i) = 2 * Pow2(i - 1)
Next i
End If
'Los gehts:
mask = Pow2(31 - ShiftCount)
If Value And mask Then
ShiftLeft = (Value And (mask - 1)) * Pow2(ShiftCount) Or &H80000000
Else
ShiftLeft = (Value And (mask - 1)) * Pow2(ShiftCount)
End If
Case 0
ShiftLeft = Value
End Select
End Function
' xbeat.net/vbspeed/c_ShiftRight.htm
Public Static Function ShiftRight(ByVal Value As Long, ByVal ShiftCount As Long) As Long
' by Donald, donald@xbeat.net, 20011009
Dim lPow2(0 To 30) As Long
Dim i As Long
Select Case ShiftCount
Case 0 To 30
If i = 0 Then
lPow2(0) = 1
For i = 1 To 30
lPow2(i) = 2 * lPow2(i - 1)
Next
End If
If Value And &H80000000 Then
ShiftRight = Int(Value / lPow2(ShiftCount))
Else
ShiftRight = Value \ lPow2(ShiftCount)
End If
Case 31
If Value And &H80000000 Then
ShiftRight = -1
Else
ShiftRight = 0
End If
End Select
End Function
