Cryptographically Secure Random Long or Integer
This has been asked for, so I whipped it up.
Here's the code for a class, but it's got VB_PredeclaredId turned on, so you're better off downloading the attached project, and grabbing the ApiRnd from there. For the uninitiated, the VB_PredeclaredId allows us to use the class with no need for explicit instantiation. It just becomes an extension of the language.
Code:
Option Explicit
'
Private Declare Function CryptAcquireContextW Lib "advapi32.dll" (hProv As Long, ByVal pszContainer As Long, ByVal pszProvider As Long, ByVal dwProvType As Long, ByVal dwFlags As Long) As Boolean
Private Declare Function CryptReleaseContext Lib "advapi32.dll" (ByVal hProv As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptGenRandom Lib "advapi32.dll" (ByVal hProv As Long, ByVal dwLen As Long, pbBuffer As Any) As Boolean
'
Private hProv As Long
'
Public Function RndInt() As Integer
' Returns a stochastic random Long in the full range of a Long:
' -32,768 to 32,767
'
Call CryptGenRandom(hProv, 2&, RndInt)
End Function
Public Function RndIntRng(ByVal Min As Long, ByVal Max As Long) As Integer
' Returns a stochastic random Integer in the range of Min to Max.
' This one won't overflow, as Longs are used for Min & Max.
' But, it's up to the caller to guarantee that Min & Max are in the -32,768 to 32,767 range.
'
' If you know the range, this could be made faster by eliminating
' the Select Case, and just creating your own appropriate mask.
' But, the way it is, it's universal.
'
Dim ZeroRange As Long
If Min > Max Then ZeroRange = Min: Min = Max: Max = ZeroRange ' Swap min and max.
ZeroRange = Max - Min ' Create zero-based range. This can overflow in theory.
Dim Mask As Long
Select Case ZeroRange
Case Is > &H7FFF&: Mask = &HFFFF&
Case Is > &H3FFF&: Mask = &H7FFF&
Case Is > &H1FFF&: Mask = &H3FFF&
Case Is > &HFFF&: Mask = &H1FFF&
Case Is > &H7FF&: Mask = &HFFF&
Case Is > &H3FF&: Mask = &H7FF&
Case Is > &H1FF&: Mask = &H3FF&
Case Is > &HFF&: Mask = &H1FF&
Case Is > &H7F&: Mask = &HFF&
Case Is > &H3F&: Mask = &H7F&
Case Is > &H1F&: Mask = &H3F&
Case Is > &HF&: Mask = &H1F&
Case Is > &H7&: Mask = &HF&
Case Is > &H3&: Mask = &H7&
Case Is > &H1&: Mask = &H3&
Case Else: Mask = &H1&
End Select
'
Dim RndLong As Long
Do
Call CryptGenRandom(hProv, 4&, RndLong)
RndLong = RndLong And Mask
Loop While RndLong > ZeroRange
'
RndIntRng = RndLong + Min
End Function
Public Function RndLng() As Long
' Returns a stochastic random Long in the full range of a Long:
' -2,147,483,648 to 2,147,483,647
'
Call CryptGenRandom(hProv, 4&, RndLng)
End Function
Public Function RndLngRng(ByVal Min As Long, ByVal Max As Long) As Long
' Returns a stochastic random Long in the range of Min to Max.
' This will overflow if the total range is more than 2,147,483,647.
'
' If you know the range, this could be made faster by eliminating
' the Select Case, and just creating your own appropriate mask.
' But, the way it is, it's universal.
'
Dim ZeroRange As Long
If Min > Max Then ZeroRange = Min: Min = Max: Max = ZeroRange ' Swap min and max.
ZeroRange = Max - Min ' Create zero-based range. This can overflow in theory.
Dim Mask As Long
Select Case ZeroRange
Case Is > &H3FFFFFFF: Mask = &H7FFFFFFF
Case Is > &H1FFFFFFF: Mask = &H3FFFFFFF
Case Is > &HFFFFFFF: Mask = &H1FFFFFFF
Case Is > &H7FFFFFF: Mask = &HFFFFFFF
Case Is > &H3FFFFFF: Mask = &H7FFFFFF
Case Is > &H1FFFFFF: Mask = &H3FFFFFF
Case Is > &HFFFFFF: Mask = &H1FFFFFF
Case Is > &H7FFFFF: Mask = &HFFFFFF
Case Is > &H3FFFFF: Mask = &H7FFFFF
Case Is > &H1FFFFF: Mask = &H3FFFFF
Case Is > &HFFFFF: Mask = &H1FFFFF
Case Is > &H7FFFF: Mask = &HFFFFF
Case Is > &H3FFFF: Mask = &H7FFFF
Case Is > &H1FFFF: Mask = &H3FFFF
Case Is > &HFFFF&: Mask = &H1FFFF
Case Is > &H7FFF&: Mask = &HFFFF&
Case Is > &H3FFF&: Mask = &H7FFF&
Case Is > &H1FFF&: Mask = &H3FFF&
Case Is > &HFFF&: Mask = &H1FFF&
Case Is > &H7FF&: Mask = &HFFF&
Case Is > &H3FF&: Mask = &H7FF&
Case Is > &H1FF&: Mask = &H3FF&
Case Is > &HFF&: Mask = &H1FF&
Case Is > &H7F&: Mask = &HFF&
Case Is > &H3F&: Mask = &H7F&
Case Is > &H1F&: Mask = &H3F&
Case Is > &HF&: Mask = &H1F&
Case Is > &H7&: Mask = &HF&
Case Is > &H3&: Mask = &H7&
Case Is > &H1&: Mask = &H3&
Case Else: Mask = &H1&
End Select
'
Dim RndLong As Long
Do
Call CryptGenRandom(hProv, 4&, RndLong)
RndLong = RndLong And Mask
Loop While RndLong > ZeroRange
'
RndLngRng = RndLong + Min
End Function
Private Sub Class_Initialize()
Const CRYPT_VERIFYCONTEXT As Long = &HF0000000
Const PROV_RSA_FULL As Long = &H1&
Call CryptAcquireContextW(hProv, ByVal 0&, ByVal 0&, PROV_RSA_FULL, CRYPT_VERIFYCONTEXT)
End Sub
Private Sub Class_Terminate()
Call CryptReleaseContext(hProv, ByVal 0&)
End Sub
Code:
Option Explicit
Private Sub Form_Click()
Debug.Print ApiRnd.RndIntRng(1, 5)
End Sub