' ' dd_unq32.bas ' ' This provides functions for creating unique database keys ' as stored in a file. ' ' AUTHOR ' Don Dickinson ' ddickinson@usinternet.com ' dickinson.basicguru.com ' ' COMPILES WITH ' pbdll or pbcc 32-bit versions ' ' DEPENDS ON ' no other files ' ' LICENSE ' Hereby Public Domain. Use at your own risk. ' ' EXPORTED FUNCTIONS ' TenTo36 converts a quad to a base36 number ' GetUniqueBase36Number retrieves the next available base36 ' number from a file ' #if not %def(%DD_UNQ32_BAS) %DD_UNQ32_BAS = 1 '- Number of file lock retries in %DD_UNQ32_MAX_TRIES = 2000 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Get36Byte '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Function Get36Byte(ByVal i As Long) As String 'StdOut " OneByte: " + Format$(i) + " "; If i < 10 Then Function = Format$(i) Else Function = Chr$(65 + i - 10) End If End Function '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' TenTo36 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Function TenTo36 Alias "TenTo36" (ByVal L As Quad) Export As String Dim i As Long Dim oneByte As Long Dim sAccum As String If L >= 36^7 Then sAccum = "ZZZZZZZ" ElseIf L < 36 Then sAccum = "000000" + Get36Byte(L) Else sAccum = "" For i = 6 To 1 Step -1 If L >= 36^i Then oneByte = L \ 36^i sAccum = sAccum + Get36Byte(oneByte) L = L - oneByte * 36^i Else sAccum = sAccum + "0" End If Next i sAccum = sAccum + Get36Byte(L) End If Function = sAccum End Function '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' GetUniqueBase36Number ' zFileName is a file to use. This file will be updated with the ' number last used. You should not alter this file from another ' program. The routine attempts to get an exclusive lock on the file. ' if after %MAX_TRIES number of tries, it cannot get a lock or if ' any other error occurs, it fails by returning an empty string. ' If it succeeds, it returns the b36 number in string format. '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Function GetUniqueBase36Number Alias "GetUniqueBase36Number" _ ( ByVal zFileName As String ) Export As String Dim iTries As Long Dim iFF As Long Dim qResult As Quad Dim sInput As String Dim sResult as String iFF = FreeFile Do Err = 0 Open zFileName For Binary Lock Read Write As #iFF If Err Then iTries = iTries + 1 If iTries > %DD_UNQ32_MAX_TRIES Then Exit Do End If Else Exit Do End If sleep 20 Loop If iTries > %DD_UNQ32_MAX_TRIES Then qResult = 0 ElseIf Lof(iFF) = 0 Then qResult = 1 sResult = Format$(qResult) Put #iFF,, sResult Close #iFF Else sInput = Space$(Lof(iFF)) Get #iFF,, sInput qResult = Int(Val(sInput)) qResult = qResult + 1 If qResult < 1 Then qResult = 1 End If Seek #iFF, 1 sResult = Format$(qResult) Put #iFF,, sResult Close #iFF End If Function = TenTo36(qResult) End Function #endif