ValidDate function
This is just a test posting to see how awful large chunks of code will look on the blog.
The code for the drop-in replacement for REALbasic's ParseDate can be found on my website
Function validDate(text as String, ByRef value As Date, assumePastFuture as integer= 0) As Boolean
// If the year provided has only one or 2 digits, check assumePastFuture
// negative value means the past, positive means future, 0 means current century
// If no year is supplied, assumePastFuture has a granularity of 1 year
Static yearPos as Integer = -9
Static monthPos as Integer = -9
Static dayPos as Integer = -9
if yearPos = -9 then // first time through
yearPos = -1 // only try this once
// try to work out local date format
// assume Gregorian calendar
// assume shortDate contains all 3 numbers
// don't use NthField or Split in case it contains other characters
dim d as new date
// clear any time numbers, in case of unusual shortDate format
d.TotalSeconds = 0
// set unique values for year, month & date
d.SQLDate = "2005-12-31"
dim s as String = d.ShortDate
dim pos() As integer
dim thisPos as Integer
thisPos = InStr( 0, s, "05" )
if thisPos > 0 then pos.Append thisPos
thisPos = InStr( 0, s, "12" )
if thisPos > 0 then pos.Append thisPos
thisPos = InStr( 0, s, "31" )
if thisPos > 0 then pos.Append thisPos
if UBound( pos ) = 2 then
// we've found all three elements
// sort them by position in shortDate
dim typ() As string = Array( "y", "m", "d" )
pos.SortWith typ
yearPos = typ.IndexOf( "y" )
monthPos = typ.IndexOf( "m" )
dayPos = typ.IndexOf( "d" )
end if
end if
if yearPos < 0 or monthPos < 0 or dayPos < 0 then
// we don't know how to parse the date
// some might want to set defaults instead of returning false
Return false
end if
// now check the date has just numbers and two delimiters
Dim sep as String
Dim tmp as String
Dim i as Integer
Dim noYearSupplied as Boolean
tmp = text
// first figure out what separator they gave us .. have to both be the same one
for i = 0 to 9
tmp = replaceAll(tmp,format(i,"0"),"")
next
select case len(tmp)
case 0
// unable to understand the format entered
return false
case 1
sep = tmp
case 2
sep = mid(tmp,1,1)
if sep <> mid(tmp,2,1) then
// invalid - two different separators
return false
end if
else
return false
end select
//make array of elements
Dim dats() as String = Split( text, sep )
if UBound( dats ) <> 2 then
// add in the missing year ?
dim tmpDate as new date
dats.Insert yearPos, format(tmpDate.year,"0000")
noYearSupplied = True
end if
if UBound( dats ) <> 2 then
//invalid date - should never get here.
Return false
end if
dim yr As integer = CDbl( dats( yearPos ) )
if yr < 100 then
// fix short year by assuming current century
// proving that we learned nothing from y2k
dim today as new Date
dim century as integer
century = today.year \ 100
century = century * 100
yr = yr + century
// use any assumptions about whether the date is past or future to set century
if assumePastFuture < 0 then
if yr > today.Year then
yr = yr - 100
end if
elseif assumePastFuture > 0 and yr < today.Year then
yr = yr + 100
end if
dats( yearPos ) = CStr( yr )
elseif noYearSupplied then
// use any assumptions about whether the date is past or future to set year
dim mth as integer = CDbl( dats( monthPos ) )
dim dy as integer = CDbl( dats( dayPos ) )
dim today as new Date
if assumePastFuture < 0 then
if mth > today.Month or ( mth = today.Month and dy > today.Day ) then
yr = yr - 1
end if
elseif assumePastFuture > 0 and ( mth < today.Month or ( mth = today.Month and dy < today.Day ) ) then
yr = yr + 1
end if
dats( yearPos ) = CStr( yr )
end if
// put detail into a date object
dim retVal as new date
dim yy,mm,dd as Integer
yy = val( dats( yearPos ) )
mm = val( dats( monthPos ) )
dd = val( dats( dayPos ) )
retVal.TotalSeconds = 0
retVal.Year = yy
retVal.Month = mm
retVal.Day = dd
// check the date object is not making corrections
if retVal.Year <> yy or retVal.Month <> mm or retVal.Day <> dd then
//probably an invalid day of the month
Return false
end if
//populate value ( ByRef side-effect )
if value = nil Then
value = new Date
end if
value.totalseconds = retVal.TotalSeconds
return true
End Function
I really should put some sort of free use licence on the code but I need to speak to Norman about that first as he contributed a significant part of the code.
