Option Explicit
'==========================
' Déclarations API
'==========================
#If VBA7 Then
Private Declare PtrSafe Function CryptAcquireContext Lib "advapi32.dll" _
Alias "CryptAcquireContextA" (ByRef phProv As LongPtr, _
ByVal pszContainer As String, ByVal pszProvider As String, _
ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptGenRandom Lib "advapi32.dll" _
(ByVal hProv As LongPtr, ByVal dwLen As Long, ByRef pbBuffer As Byte) As Long
Private Declare PtrSafe Function CryptReleaseContext Lib "advapi32.dll" _
(ByVal hProv As LongPtr, ByVal dwFlags As Long) As Long
Private m_hProv As LongPtr
#Else
Private Declare Function CryptAcquireContext Lib "advapi32.dll" _
Alias "CryptAcquireContextA" (ByRef phProv As Long, _
ByVal pszContainer As String, ByVal pszProvider As String, _
ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptGenRandom Lib "advapi32.dll" _
(ByVal hProv As Long, ByVal dwLen As Long, ByRef pbBuffer As Byte) As Long
Private Declare Function CryptReleaseContext Lib "advapi32.dll" _
(ByVal hProv As Long, ByVal dwFlags As Long) As Long
Private m_hProv As Long
#End If
'==========================
' Initialisation / libération
'==========================
Public Sub CryptoInit()
If m_hProv <> 0 Then Exit Sub
' PROV_RSA_FULL = 1, CRYPT_VERIFYCONTEXT = &HF0000000
If CryptAcquireContext(m_hProv, vbNullString, vbNullString, 1, &HF0000000) = 0 Then
Err.Raise vbObjectError + 1, "CryptoInit", "CryptAcquireContext a échoué."
End If
End Sub
Public Sub CryptoFree() 'pas obligatoire (fait à la fermeture d'Excel)
If m_hProv <> 0 Then
CryptReleaseContext m_hProv, 0
m_hProv = 0
End If
End Sub
'==========================
' Générateurs
'==========================
Private Function CryptoRandom64() As Double
Dim b(7) As Byte
Dim d As Double
If m_hProv = 0 Then CryptoInit
CryptGenRandom m_hProv, 8, b(0)
d = b(0) _
+ b(1) * 256# _
+ b(2) * 65536# _
+ b(3) * 16777216# _
+ b(4) * 4294967296# _
+ b(5) * 1099511627776# _
+ b(6) * 281474976710656# _
+ b(7) * 7.20575940379279E+16
CryptoRandom64 = d
End Function
Public Function CryptoRnd() As Double
Dim r As Double
' 2^64 - 1 ≈ 1.84467440737096E+19
r = CryptoRandom64() / 1.84467440737096E+19
' Sécurité : ne jamais renvoyer exactement 1
If r >= 1# Then r = 0.999999999999999#
CryptoRnd = r
End Function
'==========================
' Shuffle Fisher–Yates
'==========================
Public Sub ShuffleArray(ByRef arr As Variant)
Dim i As Long, j As Long
Dim tmp As Variant
Dim lo As Long, hi As Long
lo = LBound(arr)
hi = UBound(arr)
For i = hi To lo + 1 Step -1
j = lo + Int(CryptoRnd() * (i - lo + 1))
tmp = arr(i)
arr(i) = arr(j)
arr(j) = tmp
Next i
End Sub
Public Sub TestShuffle()
Dim t
Dim i As Long
t = Array("A", "B", "C", "D", "E", "F")
ShuffleArray t
For i = LBound(t) To UBound(t)
Debug.Print t(i)
Next i
End Sub