INTELLIGENT WORK FORUMS
FOR COMPUTER PROFESSIONALS

Log In

Come Join Us!

Are you a
Computer / IT professional?
Join Tek-Tips Forums!
  • Talk With Other Members
  • Be Notified Of Responses
    To Your Posts
  • Keyword Search
  • One-Click Access To Your
    Favorite Forums
  • Automated Signatures
    On Your Posts
  • Best Of All, It's Free!

*Tek-Tips's functionality depends on members receiving e-mail. By joining you are opting in to receive e-mail.

Posting Guidelines

Promoting, selling, recruiting, coursework and thesis posting is forbidden.

Jobs

Functions

Luhn's Algorithm - a VBA Implementation by AlexCuse
Posted: 3 Aug 07 (Edited 6 Aug 07)

Well, if you are stumbling upon these FAQ's you probably know what luhn's (mod 10) algorithm is, but basically it is used to assign and validate things like credit card account numbers.

Wikipedia Entry

I recently had to implement this in VBA, and I saw examples out there for everything except VB6 so I thought this would be helpful to someone.

There are two functions (luhnCheck gives you the Check Digit, luhnValid checks numbers for validity).  The sub fillXL is only used to fill the public array used in looking up some of the values (I chose to do it like this to make the coding a little cleaner).

CODE

Option Compare Database
Option Explicit

' this array holds lookup values for translating digits
'(when necessary)
Dim xL(9) As Integer

Public Sub fillXL()

'this sub is used to fill the public array used for
'translation of digits

'array values in xL are for the index integer
'0 * 2 = 0 --> 0 = 0
'6*2 = 12 --> 1 + 2 = 3
'having this array available saves us from performing string
'conversions and math operations (just lookup by index)
xL(0) = 0
xL(1) = 2
xL(2) = 4
xL(3) = 6
xL(4) = 8
xL(5) = 1
xL(6) = 3
xL(7) = 5
xL(8) = 7
xL(9) = 9

End Sub

Public Function luhnCheck(ByVal intStr As String) As String

'this function is used to return the check digit to be
'appended to a given number
Dim b() As Byte
Dim x As Integer
Dim sD As Integer
' sD holds sum of digits (as modified by Luhn algorithm)
Dim lD As Integer
' lD is used to store checksum digit (10 - sD Mod 10)

'check for numeric input
If Not IsNumeric(intStr & ".0e0") Then
   luhnCheck = "X"
   Exit Function
End If

Call fillXL

sD = 0
ReDim b(Len(intStr))

b = StrConv(StrReverse(intStr), vbFromUnicode)

'b(x) - 48 == faster way to get integer value
'from unicode byte value
'first digit (starting from right)is doubled/digits added
'because once check digit is appended this will be the second
For x = LBound(b) To UBound(b)
    If x Mod 2 = 0 Then
        sD = sD + xL(b(x) - 48)
    Else
        sD = sD + (b(x) - 48)
    End If
Next

lD = 10 - (sD Mod 10)

'we don't want to add 10, if lD calculates to 10 then we
'really want to add 0
If lD = 10 Then
    lD = 0
End If

'return string with check digit appended
luhnCheck = CStr(lD)

End Function

Public Function luhnValid(ByVal intStr As String) As Boolean

'this function is used to check if a number entered is valid
Dim sD As Integer
Dim bl As Boolean
Dim b() As Byte
Dim x As Integer

'check for numeric input
If Not IsNumeric(intStr & ".0e0") Then
   luhnValid = False
   Exit Function
End If

Call fillXL

ReDim b(Len(intStr))

b = StrConv(intStr, vbFromUnicode)

bl = False
sD = 0

'start with last digit, work towards first
For x = UBound(b) To LBound(b) Step -1
    If bl Then
        sD = sD + xL(b(x) - 48)
    Else
        sD = sD + b(x) - 48
    End If
    
    bl = Not (bl)
Next

luhnValid = (sD Mod 10 = 0)

End Function

I would appreciate any feedback on this code, especially if anyone sees problems with it (as I need to put it into production very soon!).

Also special thanks to ESquared and gmmastros for their insights while I was working on this.

Alex

Back to Microsoft: Access Modules (VBA Coding) FAQ Index
Back to Microsoft: Access Modules (VBA Coding) Forum

My Archive

Resources

Close Box

Join Tek-Tips® Today!

Join your peers on the Internet's largest technical computer professional community.
It's easy to join and it's free.

Here's Why Members Love Tek-Tips Forums:

Register now while it's still free!

Already a member? Close this window and log in.

Join Us             Close