基于VBA实现Google Authenticator的双因素认证（2FA）方案

我不是英语母语者，这是我第一次在这里分享内容。以下是一个可行的解决方案，而非提问：

我曾在网上寻找VBA实现Google Authenticator功能的完整方案，但找到的所有HMAC和SHA1示例都无法得到正确结果。于是我参考其他编程语言的实现逻辑，重现了这套代码，相关参考逻辑的说明已标注在代码注释中。

代码可以正常运行，但我只是VBA业余爱好者，欢迎大家提出优化建议。

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
    
        ' 参考社区Base32转码逻辑，调整为适配当前需求的实现
        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
            ' 参考TOTP算法实现逻辑，重现该步骤
            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


' 获取UTC时间戳（毫秒级）的实现
Function CurrentTimeMillis() As Double
    ' 返回从1970/01/01 00:00:00.0到当前系统UTC时间的毫秒数
    Dim st As SYSTEMTIME
    GetSystemTime st
    Dim t_Start, t_Now
    t_Start = DateSerial(1970, 1, 1) ' Unix时间起始点
    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

' 十六进制字符串转无符号整数
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

' HMAC-SHA1哈希实现，调整为使用无符号字节数组并返回带前导零的十六进制字符串
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

' 十六进制字符串转字节数组，调整为生成无符号字节数组
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

' 字节数组转十六进制字符串，去掉了十六进制字符间的空格
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

' 左移位运算实现
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
  
    ' 初始化幂次数组
    If i = 0 Then
      Pow2(0) = 1
      For i = 1 To 30
        Pow2(i) = 2 * Pow2(i - 1)
      Next i
    End If
    
    ' 执行左移位
    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

' 右移位运算实现
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

内容的提问来源于stack exchange，提问作者Stephan