Solved

Verifying Authenticity of Users with Serial Numbers

Posted on 1998-07-02
17
241 Views
Last Modified: 2010-05-03
The serial number access code that I have formulated to initially start my application is having around 40 characters. Is there a way to compress or pack this alphanumeric string such that the resultant packed string can also be alphanumeric and can be decompressed later for verification of authenticity.
0
Comment
Question by:niyer
  • 6
  • 6
  • 5
17 Comments
 
LVL 2

Expert Comment

by:peterwest
Comment Utility
Hi,

If the data you want to compress is just string information then you could use RLE compression to achieve your aim.  Here are the two routines you'll need to compress and decompress the data.

The following constants need putting in general declarations first:

Const ASC_UA = 65
Const ASC_UZ = 90
Const ASC_A = 97
Const ASC_Z = 122
Const ASC_SPACE = 32
Const ASC_COMMA = 44
Const ASC_PERIOD = 46
Const ASC_UNKNOWN = 63
Const CODE_A = 0
Const CODE_Z = 25
Const CODE_SPACE = 34
Const CODE_COMMA = 35
Const CODE_PERIOD = 36
Const CODE_UNKNOWN = 37
Const CODE_SHIFT = 38
Const CODE_SHIFTLOCK = 39



Function Compress(in_text As String, out_data() As Integer, comp_text As String) As Integer

Const CASE_UPPER = 0
Const CASE_LOWER = 1
Const CASE_NONE = 2

Dim in_len As Integer
Dim tmp() As Integer
Dim tmp_len As Integer
Dim ch As String * 1
Dim num As Integer
Dim cur_Case As Integer
Dim new_case As Integer
Dim nxt_case As Integer
Dim nxt_num As Integer
Dim do_lock As Integer
Dim i As Integer

cur_Case = CASE_LOWER
tmp_len = 0
in_len = Len(in_text)

For i = 1 To in_len
    ch = Mid$(in_text, i, 1)
    num = Asc(ch)
    If num >= ASC_A And num <= ASC_Z Then
        new_case = CASE_LOWER
        num = num - ASC_A
    ElseIf num >= ASC_UA And num <= ASC_UZ Then
            new_case = CASE_UPPER
            num = num - ASC_UA
    Else
        new_case = CASE_NONE
        Select Case num
            Case ASC_SPACE
            num = CODE_SPACE
            Case ASC_COMMA
            num = CODE_COMMA
            Case ASC_PERIOD
            num = CODE_PERIOD
            Case Else
            num = CODE_UNKNOWN
        End Select
    End If
   
    If new_case <> CASE_NONE And new_case <> cur_Case Then
        If i = in_len Then
            do_lock = False
        Else
            nxt_num = Asc(Mid$(in_text, i + 1, 1))
            If nxt_num >= ASC_A And nxt_num <= ASC_Z Then
                nxt_case = CASE_LOWER
            Else
                nxt_case = CASE_NONE
            End If
            do_lock = (nxt_case = new_case)
        End If
       
        tmp_len = tmp_len + 1
        ReDim Preserve tmp(1 To tmp_len)
        If do_lock Then
            tmp(tmp_len) = CODE_SHIFTLOCK
            cur_Case = new_case
            comp_text = comp_text & "="
        Else
            tmp(tmp_len) = CODE_SHIFT
            comp_text = comp_text & "-"
        End If
    End If
    tmp_len = tmp_len + 1
    ReDim Preserve tmp(1 To tmp_len)
    tmp(tmp_len) = num
    comp_text = comp_text & ch
Next i

Do While tmp_len Mod 3 <> 0
    tmp_len = tmp_len + 1
    ReDim Preserve tmp(1 To tmp_len)
    tmp(tmp_len) = CODE_SHIFT
    comp_text = comp_text & "-"
Loop

ReDim out_data(1 To tmp_len \ 3)
For i = 1 To tmp_len Step 3
    out_data(i \ 3 + 1) = tmp(i) * 40& * 40 + tmp(i + 1) * 40 + tmp(i + 2) - 32768
Next i
Compress = tmp_len \ 3

End Function



Function uncompress(in_data() As Integer) As String

Dim in_len As Integer
Dim i As Integer
Dim ch As String * 1
Dim num As Integer
Dim cur_upper As Integer
Dim nxt_upper As Integer
Dim tmp() As Integer
Dim tmp_len As Integer
Dim txt As String
in_len = UBound(in_data)
ReDim tmp(1 To 3 * in_len)
tmp_len = 0
For i = 1 To in_len
    tmp_len = tmp_len + 1
    tmp(tmp_len) = (in_data(i) + 32768) \ 40 \ 40
    tmp_len = tmp_len + 1
    tmp(tmp_len) = ((in_data(i) + 32768) \ 40) Mod 40
    tmp_len = tmp_len + 1
    tmp(tmp_len) = (in_data(i) + 32768) Mod 40
Next i
cur_upper = False
txt = ""
For i = 1 To tmp_len
    num = tmp(i)
    Select Case num
        Case CODE_A To CODE_Z
            If nxt_upper Then
                txt = txt & Chr$(num + ASC_UA)
            Else
                txt = txt & Chr$(num + ASC_A)
            End If
            nxt_upper = cur_upper
        Case CODE_SPACE
            txt = txt & " "
        Case CODE_COMMA
            txt = txt & ","
        Case CODE_PERIOD
            txt = txt & "."
        Case CODE_UNKNOWN
            txt = txt & "?"
        Case CODE_SHIFT
            nxt_upper = Not cur_upper
        Case CODE_SHIFTLOCK
            cur_upper = Not cur_upper
            nxt_upper = cur_upper
    End Select
Next i
uncompress = txt

End Function





Hope this helps you

Pete
0
 
LVL 2

Expert Comment

by:peterwest
Comment Utility
Oops, Sorry!!

The code i've posted is for the RADIX compression algorithm, which, whilst it does compress data, returns a byte array of values that can't be stored in a single alphanumeric field - i'll post the code for RLE shortly.

Apologies,

Pete

0
 
LVL 2

Expert Comment

by:peterwest
Comment Utility
Hi again,

I've checked out the RLE compression routine that i've got and it's only really any good if you've got strings which contain a lot of successive recurrances of the same character.  The RADIX encoding/decoding routines i've given do indeed compress data but each byte returned contains a value that can't be represented as a character - depending on how you're storing the data you may be able to use this routine.

Let me know your thoughts and if it isn't suitable obviously just reject my answer and i'll see if I can come up with any other ideas!!!  

Pete

0
 

Author Comment

by:niyer
Comment Utility
I had tested the string compression with some Algorithns like LZW Algo but the resultant compressed string has special characters ( Not AlphaNumeric). The main problem is that I require that when I compress an Alphanumeric String, the resultant string is also AlphaNumeric, so that a user can enter it as some serial number for authentication.
0
 
LVL 2

Expert Comment

by:peterwest
Comment Utility
Hi there,

How about this then??   First do the normal compression so you end up with a data stream that isn't alpha-numeric - then, use a base64 encryption algorithm - this will convert anything, including binary data, into an alpha-numeric string.  The only problem is that the B64 string will be bigger than the original data so you may lose a little of the compression gained by compressing the data in the first place.

Anyway, i've got routines to both decode and encode B64 if you're interested - let me know.....

Pete
0
 

Author Comment

by:niyer
Comment Utility
Hi Pete,
Yeah, I would like to test the B64 encryption. Please post the decode and encode routines for B64, Thanks. What I would do is test by converting my 40 Character data string to a BYte String and then test by applying B64 and check whether that would result in a string of around 20-25 characters.
Thanks
Nithya
0
 
LVL 2

Expert Comment

by:peterwest
Comment Utility
Hi again,

Right - here goes - first the encoding routine....

Private Declare Function CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ptrDest As Any, ptrSource As Any, ByVal lenCopy As Long) As Long

Private Sub USAsciiToBase64(bIN() As Byte, b64() As Byte)

   Const TriPadding As Byte = 61 ' =
   Const Base64Table = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
   Static Base64(0 To 63) As Byte, Initialized As Boolean
   Dim TriBuf(0 To 3) As Byte, b As Byte, TriBits&
   Dim Trips&, Xtras&, bInLen&, bInPtr&, b64Ptr&

   If Not Initialized Then
      Initialized = True
      For b = 0 To 25
         Base64(b) = b + 65
         Base64(b + 26) = b + 97
      Next
      For b = 52 To 61
         Base64(b) = b - 4
      Next
      Base64(62) = 43
      Base64(63) = 47
   End If
   bInLen = UBound(bIN) - LBound(bIN) + 1
   Trips = bInLen \ 3
   Xtras = bInLen Mod 3
   ReDim b64(0 To IIf(Xtras, Trips + 1, Trips) * 4 + 1) '+1 for vbCrLf
   For bInPtr = 0 To Trips * 3 - 1 Step 3
      TriBuf(2) = bIN(bInPtr)
      TriBuf(1) = bIN(bInPtr + 1)
      TriBuf(0) = bIN(bInPtr + 2)
      CopyMemory TriBits, TriBuf(0), 3
      b64(b64Ptr) = Base64(TriBits \ &H40000)
      b64(b64Ptr + 1) = Base64((TriBits \ &H1000&) And &H3F&)
      b64(b64Ptr + 2) = Base64((TriBits \ &H40&) And &H3F&)
      b64(b64Ptr + 3) = Base64(TriBits And &H3F&)
      b64Ptr = b64Ptr + 4
   Next
   If Xtras > 0 Then
      TriBuf(0) = 0 'TriPadding
      TriBuf(2) = bIN(bInPtr)
      If Xtras > 1 Then
         TriBuf(1) = bIN(bInPtr + 1)
      Else
         TriBuf(1) = 0 'TriPadding
      End If
      CopyMemory TriBits, TriBuf(0), 3
      b64(b64Ptr) = Base64(TriBits \ &H40000)
      b64(b64Ptr + 1) = Base64((TriBits \ &H1000&) And &H3F&)
      b64(b64Ptr + 2) = IIf(Xtras = 1, TriPadding, Base64((TriBits \ &H40&) And &H3F&))
      b64(b64Ptr + 3) = TriPadding 'IIf(Xtras > 1, TriPadding, Base64(TriBits And &H3F&))
      b64Ptr = b64Ptr + 4
   End If
   b64(b64Ptr) = 13 'vbCr
   b64(b64Ptr + 1) = 10 'vbLf

End Sub




Now the decoding routine - first you need the following in general declarations:

Private Const SZ_ALPHABET = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Private Const IC_CHOPMASK = 255
Private Const IC_BITSHIFT = 4
Private Const IC_STARTMASK = &H10
Private I_SHIFT As Long
Private I_LOWSHIFT As Long
Private I_ROLLOVER As Long
Private I_HIGHMASK As Long


Then you need to call the following function to initialise the variables:


Private Function InitBase64Vars()

I_SHIFT = IC_BITSHIFT
I_LOWSHIFT = 0
I_ROLLOVER = 0
I_HIGHMASK = -1

End Function



And finally the decoding routine....

Private Function DecodeBase64(sz_Encoded() As Byte, sz_Decoded() As Byte, Optional i_EndOfText As Integer)

' Create variables
    Dim i_Ptr       As Integer
    Dim i_Char      As Integer
    Dim l_Counter As Long
   
    ReDim sz_Decoded(0)
   
    If IsMissing(i_EndOfText) Then i_EndOfText = 0

' Begin Decoding
    For l_Counter = 1 To UBound(sz_Encoded)

        DoEvents
       
' Get next alphabet
        i_Char = sz_Encoded(l_Counter - 1)

' Get Decoded value
        i_Ptr = InStr(SZ_ALPHABET, Chr$(i_Char)) - 1

' Check if character is valid
        If i_Ptr >= 0 Then

' Char is valid, process it
            If I_SHIFT = IC_BITSHIFT Then

' 1st char in block of 4, keep high part of character
                I_ROLLOVER = (i_Ptr * I_SHIFT) And IC_CHOPMASK

' Reset masks for next character
                I_HIGHMASK = &H30
                I_LOWSHIFT = IC_STARTMASK
                I_SHIFT = IC_STARTMASK

            Else

' Start saving decoded character
                DoEvents
                sz_Decoded(UBound(sz_Decoded)) = I_ROLLOVER Or ((i_Ptr And I_HIGHMASK) / I_LOWSHIFT)
                ReDim Preserve sz_Decoded(UBound(sz_Decoded) + 1)
               
                'sz_temp = sz_temp + Chr$(I_ROLLOVER Or ((i_Ptr And I_HIGHMASK) / I_LOWSHIFT))

' Calculate next mask and shift values
                I_ROLLOVER = (i_Ptr * I_SHIFT) And IC_CHOPMASK
                I_SHIFT = I_SHIFT * IC_BITSHIFT
                I_HIGHMASK = (I_HIGHMASK \ IC_BITSHIFT) Or &H30
                I_LOWSHIFT = I_LOWSHIFT / IC_BITSHIFT

                If I_SHIFT > 256 Then
                    I_SHIFT = IC_BITSHIFT
                    I_LOWSHIFT = 0
                    DoEvents
                End If
            End If

        End If
    Next

' Concat last character if required
    If (I_SHIFT > IC_BITSHIFT And I_SHIFT < 256) Then

' Character remaining in    i_RollOver
        If i_EndOfText Then

' Last string to decode in file
            sz_Decoded(UBound(sz_Decoded)) = I_ROLLOVER
            'sz_temp = sz_temp + Chr$(I_ROLLOVER)
        End If
    End If

' Exit wth decoded string
'Decode_64$ = sz_temp
End Function



Pete
0
 

Author Comment

by:niyer
Comment Utility
The B64 Encryption does not work as it increases the no. of characters and throws in special characters when it creates the encrypted text.
0
Enabling OSINT in Activity Based Intelligence

Activity based intelligence (ABI) requires access to all available sources of data. Recorded Future allows analysts to observe structured data on the open, deep, and dark web.

 
LVL 2

Expert Comment

by:swilt
Comment Utility
Does the string of chars contain a-z, A-Z and 0-9 or just A-Z, if it is just A-Z (with or without 0-9) then I should be able to write encryption/decryption routines that would shrink the size of the string
0
 
LVL 2

Expert Comment

by:swilt
Comment Utility
EncryptString only takes A-Z

Option Explicit

Public Function EncryptString(ByVal sText As String) As String
    Dim i As Integer
    Dim sBuf As String, sRet As String
   
    sBuf = ""
    For i = 1 To Len(sText)
        sBuf = sBuf & ConvToBin5(Mid$(sText, i, 1))
    Next i
    While Len(sBuf) Mod 6 > 0
        sBuf = sBuf & "0"
    Wend
    sRet = ""
    For i = 0 To (Len(sBuf) \ 6) - 1
        sRet = sRet & ConvFromBin6(Mid$(sBuf, i * 6 + 1, 6))
    Next i
    EncryptString = sRet
End Function

Public Function DecryptString(ByVal sText As String) As String
    Dim i As Integer
    Dim sBuf As String, sRet As String
   
    sBuf = ""
    For i = 1 To Len(sText)
        sBuf = sBuf & ConvToBin6(Mid$(sText, i, 1))
    Next i
    While Len(sBuf) Mod 5 > 0
        sBuf = Left$(sBuf, Len(sBuf) - 1)
    Wend
    sRet = ""
    For i = 0 To (Len(sBuf) \ 5) - 1
        sRet = sRet & ConvFromBin5(Mid$(sBuf, i * 5 + 1, 5))
    Next i
    DecryptString = sRet
End Function

Private Function ConvToBin5(ByVal nInp As String) As String
    ConvToBin5 = StrBin(Asc(nInp) - Asc("A"), 5)
End Function

Private Function ConvFromBin5(ByVal sInp As String) As String
    ConvFromBin5 = Chr$(GetBin(sInp) + Asc("A"))
End Function

Private Function ConvToBin6(ByVal nInp As String) As String
    Dim nNum As Integer
   
    Select Case nInp
    Case "A" To "Z": nNum = Asc(nInp) - Asc("A")
    Case "a" To "z": nNum = Asc(nInp) - Asc("a") + 26
    Case "0" To "9": nNum = Asc(nInp) - Asc("0") + 52
    Case "#": nNum = 62
    Case "=": nNum = 63
    End Select
    ConvToBin6 = StrBin(nNum, 6)
End Function

Private Function ConvFromBin6(ByVal sInp As String) As String
    Dim nNum As Integer
    Dim sRet As String
   
    nNum = GetBin(sInp)
    Select Case nNum
    Case 0 To 25: sRet = Chr$(Asc("A") + nNum)
    Case 26 To 51: sRet = Chr$(Asc("a") + nNum - 26)
    Case 52 To 61: sRet = Chr$(Asc("0") + nNum - 52)
    Case 62: sRet = "#"
    Case 63: sRet = "="
    End Select
    ConvFromBin6 = sRet
End Function

Private Function StrBin(ByVal nInp As Integer, nLen As Integer) As String
    Dim sRet As String
   
    While nInp > 0
        If nInp Mod 2 = 1 Then sRet = "1" & sRet Else sRet = "0" & sRet
        nInp = nInp \ 2
    Wend
    If Len(sRet) < nLen Then sRet = String$(nLen - Len(sRet), "0") & sRet
    StrBin = sRet
End Function

Private Function GetBin(ByVal sInp As String) As Integer
    Dim p As Integer, i As Integer, nTot As Integer
       
    p = 1
    nTot = 0
    For i = Len(sInp) To 1 Step -1
        nTot = nTot + p * Val(Mid$(sInp, i, 1))
        p = p * 2
    Next i
    GetBin = nTot
End Function
0
 

Author Comment

by:niyer
Comment Utility
My String has both A-Z and 0-9 and swilt's routine does not decrypt 0-9 chars, it returns a "A" for any numeric val.
0
 
LVL 2

Expert Comment

by:swilt
Comment Utility
It sure does but I'll fix it, tommorrow (uk time)
0
 
LVL 2

Accepted Solution

by:
swilt earned 100 total points
Comment Utility
This code will use whatever is set up in cIn and cOut
To work properly leave one unused char in the front on cIn (ie the '=')

Option Explicit

Const cIn = "=ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
Const cOut = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmonpqrstuvwxyz0123456789"

Public Function EncryptString(ByVal sInp As String) As String
    EncryptString = Divide(sInp, cIn, cOut)
End Function

Public Function DecryptString(ByVal sInp As String) As String
    DecryptString = Divide(sInp, cOut, cIn)
End Function

Private Function Divide(ByVal sInp As String, _
                        ByVal sBase As String, _
                        ByVal sDivisor As String)
   
    Dim sRet As String
    Dim bFin As Boolean
    Dim nBase As Integer, nDiv As Integer
    Dim i As Integer, r As Integer
    Dim nNums() As Integer
   
    sRet = ""
    nBase = Len(sBase)
    nDiv = Len(sDivisor)
    If sInp <> "" Then
        ReDim nNums(1 To Len(sInp)) As Integer
        For i = 1 To Len(sInp)
            nNums(i) = InStr(sBase, Mid$(sInp, i, 1)) - 1
        Next i
       
        bFin = False
        While Not bFin
            r = 0
            bFin = True
            For i = 1 To Len(sInp)
                nNums(i) = nNums(i) + r * nBase
                If nNums(i) > 0 Then
                    bFin = False
                    r = nNums(i) Mod nDiv
                    nNums(i) = nNums(i) \ nDiv
                End If
            Next i
            If Not bFin Then sRet = Mid$(sDivisor, r + 1, 1) & sRet
        Wend
    End If
    Divide = sRet
End Function
0
 

Author Comment

by:niyer
Comment Utility
I tested SWILT's routine and the encryption and decryption work fine but I am not getting any compression.
My input was the string below
0123-CRQ45678APBV-F-98-340-878-1242
and the output was this:
YN8mLHIVmWkcIVFTml23xoOVusZseAz
Even without the "-" in the input I did not get much compression. Any suggestion is welcome!!!!
0
 
LVL 2

Expert Comment

by:swilt
Comment Utility
The compression is in the ratio of len(cIn) to len(cOut)
The shorter cIn is or the longer cOut is the better the compression

For example
Const cIn = "=0123456789"
Const cOut = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmonpqrstuvwxyz0123456789"

? EncryptString("90398234089482304")
iYS9i6oHyv


To experiment further, if cOut is shorter then cIn
(Please note : taken "=" out of cIn on purpose)

Const cIn = "0123456789"
Const cOut = "01"

? EncryptString("34")
100010


0
 
LVL 2

Expert Comment

by:swilt
Comment Utility
If the "-" will never occur at the front of the string then you can replace then "=" with it

Try this out of interest
Const cIn = "-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
Const cOut = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmonpqrstuvwxyz0123456789!£$%^&*()_+-=[]{}:@~;#<>?,./\|"

0
 

Author Comment

by:niyer
Comment Utility
I will keep experimenting with diff cin and cout and hope I will get an optimum value for a good compression !!!
0

Featured Post

What Is Threat Intelligence?

Threat intelligence is often discussed, but rarely understood. Starting with a precise definition, along with clear business goals, is essential.

Join & Write a Comment

Have you ever wanted to restrict the users input in a textbox to numbers, and while doing that make sure that they can't 'cheat' by pasting in non-numeric text? Of course you can do that with code you write yourself but it's tedious and error-prone …
You can of course define an array to hold data that is of a particular type like an array of Strings to hold customer names or an array of Doubles to hold customer sales, but what do you do if you want to coordinate that data? This article describes…
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

763 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

6 Experts available now in Live!

Get 1:1 Help Now