<% cCharset = "Windows-1252" response.AddHeader "Content-type", "text/html;charset=" & cCharset dDebug=false Session.LCID = 1033 session.codepage=1252 dSQL="" Set tables_data = CreateObject("Scripting.Dictionary") %> <% '// locale settings ' locale settings set locale_info = CreateObject("Scripting.Dictionary") ' date settings locale_info.Add "LOCALE_ICENTURY", "1" locale_info.Add "LOCALE_IDATE", "0" locale_info.Add "LOCALE_ILDATE", "0" locale_info.Add "LOCALE_SDATE", "/" locale_info.Add "LOCALE_SLONGDATE", "dddd, MMMM dd, yyyy" locale_info.Add "LOCALE_SSHORTDATE", "M/d/yyyy" ' weekday names locale_info.Add "LOCALE_SDAYNAME1", "Monday" locale_info.Add "LOCALE_SDAYNAME2", "Tuesday" locale_info.Add "LOCALE_SDAYNAME3", "Wednesday" locale_info.Add "LOCALE_SDAYNAME4", "Thursday" locale_info.Add "LOCALE_SDAYNAME5", "Friday" locale_info.Add "LOCALE_SDAYNAME6", "Saturday" locale_info.Add "LOCALE_SDAYNAME7", "Sunday" locale_info.Add "LOCALE_SABBREVDAYNAME1", "Mon" locale_info.Add "LOCALE_SABBREVDAYNAME2", "Tue" locale_info.Add "LOCALE_SABBREVDAYNAME3", "Wed" locale_info.Add "LOCALE_SABBREVDAYNAME4", "Thu" locale_info.Add "LOCALE_SABBREVDAYNAME5", "Fri" locale_info.Add "LOCALE_SABBREVDAYNAME6", "Sat" locale_info.Add "LOCALE_SABBREVDAYNAME7", "Sun" ' month names locale_info.Add "LOCALE_SMONTHNAME1", "January" locale_info.Add "LOCALE_SMONTHNAME2", "February" locale_info.Add "LOCALE_SMONTHNAME3", "March" locale_info.Add "LOCALE_SMONTHNAME4", "April" locale_info.Add "LOCALE_SMONTHNAME5", "May" locale_info.Add "LOCALE_SMONTHNAME6", "June" locale_info.Add "LOCALE_SMONTHNAME7", "July" locale_info.Add "LOCALE_SMONTHNAME8", "August" locale_info.Add "LOCALE_SMONTHNAME9", "September" locale_info.Add "LOCALE_SMONTHNAME10", "October" locale_info.Add "LOCALE_SMONTHNAME11", "November" locale_info.Add "LOCALE_SMONTHNAME12", "December" locale_info.Add "LOCALE_SABBREVMONTHNAME1", "Jan" locale_info.Add "LOCALE_SABBREVMONTHNAME2", "Feb" locale_info.Add "LOCALE_SABBREVMONTHNAME3", "Mar" locale_info.Add "LOCALE_SABBREVMONTHNAME4", "Apr" locale_info.Add "LOCALE_SABBREVMONTHNAME5", "May" locale_info.Add "LOCALE_SABBREVMONTHNAME6", "Jun" locale_info.Add "LOCALE_SABBREVMONTHNAME7", "Jul" locale_info.Add "LOCALE_SABBREVMONTHNAME8", "Aug" locale_info.Add "LOCALE_SABBREVMONTHNAME9", "Sep" locale_info.Add "LOCALE_SABBREVMONTHNAME10", "Oct" locale_info.Add "LOCALE_SABBREVMONTHNAME11", "Nov" locale_info.Add "LOCALE_SABBREVMONTHNAME12", "Dec" ' time settings locale_info.Add "LOCALE_ITIME", "0" locale_info.Add "LOCALE_ITIMEMARKPOSN", "0" locale_info.Add "LOCALE_ITLZERO", "0" locale_info.Add "LOCALE_S1159", "AM" locale_info.Add "LOCALE_S2359", "PM" locale_info.Add "LOCALE_STIME", ":" locale_info.Add "LOCALE_STIMEFORMAT", "h:mm:ss tt" ' currency settings locale_info.Add "LOCALE_ICURRDIGITS", "2" locale_info.Add "LOCALE_ICURRENCY", "0" locale_info.Add "LOCALE_INEGCURR", "0" locale_info.Add "LOCALE_SCURRENCY", "$" locale_info.Add "LOCALE_SMONDECIMALSEP", "." locale_info.Add "LOCALE_SMONGROUPING", "3;0" locale_info.Add "LOCALE_SMONTHOUSANDSEP", "," ' numbers formatting settings locale_info.Add "LOCALE_IDIGITS", "2" locale_info.Add "LOCALE_INEGNUMBER", "1" locale_info.Add "LOCALE_SDECIMAL", "." locale_info.Add "LOCALE_SGROUPING", "3;0" locale_info.Add "LOCALE_SNEGATIVESIGN", "-" locale_info.Add "LOCALE_SPOSITIVESIGN", "" locale_info.Add "LOCALE_STHOUSAND", "," locale_info("LOCALE_ILONGDATE")=GetLongDateFormat() '// locale functions '// number, currency, date & time functions function fformat_number(val) dim sign, vint, frac, out, ptr, gi, fmul, i, sfrac dim grouping if not isNumeric(val) then fformat_number=val exit function end if if val>=0 then sign=1 vint = int(val) frac = val-vint else sign=-1 vint = int(-val) frac = -val-vint end if out = formatnumber(vint,0) '// grouping grouping=split(locale_info("LOCALE_SGROUPING"),";") if uBound(grouping)>0 and grouping(0)<>"" then ptr=len(out) for gi=0 to uBound(grouping)-1 if not grouping(gi)<>"" then gi=gi-1 if ptr<=grouping(gi) then ptr=0 exit for end if out=substr(out,1,ptr-grouping(gi)) & locale_info("LOCALE_STHOUSAND") & substr(out,ptr-grouping(gi)) ptr=ptr-grouping(gi) next end if ''// fractional digits if locale_info("LOCALE_IDIGITS")>0 then fmul=1 for i=0 to locale_info("LOCALE_IDIGITS")-1 fmul=fmul*10 next frac=round(frac*fmul) sfrac=cstr(frac) dl=len(sfrac) while dl0 then fformat_number = locale_info("LOCALE_SPOSITIVESIGN") & out exit function else select case locale_info("LOCALE_INEGNUMBER") case 0 fformat_number = "(" & out & ")" exit function case 1 fformat_number = "-" & out exit function case 2 fformat_number = "- " & out exit function case 3 fformat_number = out & "-" exit function case 4 fformat_number = out & " -" exit function end select end if fformat_number=val end function function fformat_currency(val) dim sign, vint, frac, out, ptr, gi, fmul, sfrac dim grouping if not isNumeric(val) then format_currency = val if val>=0 then sign=1 vint = int(val) frac = val-vint else sign=-1 vint = int(-val) frac = -val-vint end if out = formatnumber(vint,0) '// grouping grouping=split(locale_info("LOCALE_SMONGROUPING"),";") if uBound(grouping)>0 and grouping(0)<>"" then ptr=len(out) for gi=0 to uBound(grouping)-1 if not grouping(gi)<>"" then gi=gi-1 if ptr<=grouping(gi) then ptr=0 exit for end if out=substr(out,1,ptr-grouping(gi)) & locale_info("LOCALE_SMONTHOUSANDSEP") & substr(out,ptr-grouping(gi)) ptr=ptr-grouping(gi) next end if '// fractional digits if locale_info("LOCALE_ICURRDIGITS")>0 then fmul=1 for i=0 to locale_info("LOCALE_ICURRDIGITS")-1 fmul=fmul*10 next frac=round(frac*fmul) sfrac=cstr(frac) dl=len(sfrac) while dl0 then select case locale_info("LOCALE_ICURRENCY") case 0 fformat_currency = cstr(locale_info("LOCALE_SCURRENCY")) & cstr(out) exit function case 1 fformat_currency = cstr(out) & cstr(locale_info("LOCALE_SCURRENCY")) exit function case 2 fformat_currency = cstr(locale_info("LOCALE_SCURRENCY")) & " " & cstr(out) exit function case 3 fformat_currency = cstr(out) & " " & cstr(locale_info("LOCALE_SCURRENCY")) exit function end select else select case locale_info("LOCALE_INEGCURR") case 0 fformat_currency = "(" & cstr(locale_info("LOCALE_SCURRENCY")) & cstr(out) & ")" exit function case 1 fformat_currency = "-" & cstr(locale_info("LOCALE_SCURRENCY")) & cstr(out) exit function case 2 fformat_currency = cstr(locale_info("LOCALE_SCURRENCY")) & "-" & cstr(out) exit function case 3 fformat_currency = cstr(locale_info("LOCALE_SCURRENCY")) & cstr(out) exit function case 4 fformat_currency = "(" & cstr(out) & cstr(locale_info("LOCALE_SCURRENCY")) & ")" exit function case 5 fformat_currency = "-" & cstr(out) & cstr(locale_info("LOCALE_SCURRENCY")) exit function case 6 fformat_currency = cstr(out) & "-" & cstr(locale_info("LOCALE_SCURRENCY")) exit function case 7 fformat_currency = cstr(out) & cstr(locale_info("LOCALE_SCURRENCY")) & "-" exit function case 8 fformat_currency = "-" & cstr(out) & " " & cstr(locale_info("LOCALE_SCURRENCY")) exit function case 9 fformat_currency = "-" & cstr(locale_info("LOCALE_SCURRENCY")) & " " & cstr(out) exit function case 10 fformat_currency = cstr(out) & " " & cstr(locale_info("LOCALE_SCURRENCY")) & "-" exit function case 11 fformat_currency = cstr(locale_info("LOCALE_SCURRENCY")) & " " & cstr(out) & "-" exit function case 12 fformat_currency = cstr(locale_info("LOCALE_SCURRENCY")) & " -" & cstr(out) exit function case 13 fformat_currency = cstr(out) & "- " & cstr(locale_info("LOCALE_SCURRENCY")) exit function case 14 fformat_currency = "(" & cstr(locale_info("LOCALE_SCURRENCY")) & " " & cstr(out) & ")" exit function case 15 fformat_currency = "(" & cstr(out) & " " & cstr(locale_info("LOCALE_SCURRENCY")) & ")" exit function end select end if fformat_currency = val end function '// converts mysql datetime to array(year,month,day,hour,minute,second) function db2time(val) dim arr(6) arr(0)="" arr(1)="" arr(2)="" arr(3)="" arr(4)="" arr(5)="" if isnull(val) then db2time=arr exit function end if if isdate(val) then arr(0)=year(val) arr(1)=month(val) arr(2)=day(val) arr(3)=hour(val) arr(4)=minute(val) arr(5)=second(val) db2time=arr exit function end if str=CStr(val) dim isdst, havedate, havetime, pattern, y, mo, d, h, mi, s, vlen dim vnow(3) Dim regEx, Match, Matches Dim matchesCount Set regEx = New RegExp regEx.IgnoreCase = True regEx.Global = True pattern="" vnow(0)=year(now) vnow(1)=month(now) vnow(2)=day(now) havedate=0 havetime=0 if isNumeric(str) then '// timestamp havedate=1 vlen=len(str) if vlen>=10 then havetime=1 select case vlen case 14 pattern="(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})" case 12 pattern="(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})" case 10 pattern="(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})" case 8 pattern="(\d{4})(\d{2})(\d{2})" case 6 pattern="(\d{2})(\d{2})(\d{2})" case 4 pattern="(\d{2})(\d{2})" case 2 pattern="(\d{2})" case else db2time = arr exit function end select regEx.Pattern = pattern Set Matches = regEx.Execute(str) matchesCount = Matches.Count If matchesCount > 0 Then set m=Matches(0) y = subMatches(0).Value If matchesCount > 1 Then mo = m.subMatches(1) Else mo = 1 End If If matchesCount > 2 Then d = m.subMatches(2) Else d = 1 End If If matchesCount > 3 Then h = m.subMatches(3) Else h = 0 End If If matchesCount > 4 Then mi = m.subMatches(4) Else mi = 0 end if If matchesCount > 5 Then s = m.subMatches(5) Else s = 0 End If else db2time = arr exit function end if else if not isNumeric(str) and not isnull(str) and trim(str)<>"" then '// date,time,datetime ' str=year(str) & "-" & month(str) & "-" & day(str) & " " & hour(str) & ":" & minute(str) & ":" & second(str) regEx.Pattern = "(\d{4})-(\d{1,2})-(\d{1,2}) (\d{1,2}):(\d{1,2}):(\d{1,2})" Set Matches = regEx.Execute(str) matchesCount = Matches.Count If matchesCount > 0 Then set m=Matches(0) y = m.subMatches(0) mo = m.subMatches(1) d = m.subMatches(2) h = m.subMatches(3) mi = m.subMatches(4) s = m.subMatches(5) havedate=1 havetime=1 else regEx.Pattern = "(\d{4})-(\d{1,2})-(\d{1,2})" Set Matches = regEx.Execute(str) matchesCount = Matches.Count If matchesCount > 0 Then set m=Matches(0) y = m.subMatches(0) mo = m.subMatches(1) d = m.subMatches(2) h = 0 mi = 0 s = 0 havedate=1 else regEx.Pattern = "(\d{2})-(\d{1,2})-(\d{1,2})" Set Matches = regEx.Execute(str) matchesCount = Matches.Count If matchesCount > 0 Then set m=Matches(0) y=vnow(0) mo=vnow(1)+1 d=vnow(2) h = m.subMatches(3) mi = m.subMatches(4) s = m.subMatches(5) havetime=1 else db2time = arr exit function end if end if end if else db2time = arr exit function end if end if if havetime=0 then h=0 mi=0 s=0 end if if havedate=0 then y=vnow(0) mo=vnow("1")+1 d=vnow("2") end if arr(0)=y arr(1)=mo arr(2)=d arr(3)=h arr(4)=mi arr(5)=s db2time = arr end function function format_datetime(ttime()) format_datetime = format_datetime_custom(ttime,locale_info("LOCALE_SSHORTDATE") & " " & locale_info("LOCALE_STIMEFORMAT")) end function function fformat_time(ttime()) fformat_time = format_datetime_custom(ttime,locale_info("LOCALE_STIMEFORMAT")) end function function format_shortdate(ttime()) format_shortdate = format_datetime_custom(ttime,locale_info("LOCALE_SSHORTDATE")) end function function format_longdate(ttime()) format_longdate = format_datetime_custom(ttime,locale_info("LOCALE_SLONGDATE")) end function function simpledate2db(strdate,formatid) dim sstr, mmonth, dday, yyear dim numbers sstr=strdate numbers=parsenumbers(sstr) if uBound(numbers)=0 then simpledate2db = strdate while uBound(numbers)<3 numbers(uBound(numbers)+1)=1 wend if formatid=0 then mmonth=numbers(0) dday=numbers(1) yyear=numbers(2) else if formatid=1 then dday=numbers(0) mmonth=numbers(1) yyear=numbers(2) else if formatid=2 then yyear=numbers(0) mmonth=numbers(1) dday=numbers(2) else simpledate2db = strdate end if end if end if if yyear<100 then if yyear<60 then yyear=yyear+2000 else yyear=yyear+1900 end if end if simpledate2db = yyear & "-" & mmonth & "-" & dday end function function localdate2db(strdate) localdate2db = simpledate2db(strdate,locale_info("LOCALE_IDATE")) end function function localtime2db(strtime) '// check if we use 12hours clock dim use12, pos, pm, amstr, pmstr, str, h, k dim numbers use12=0 pos=instr(1,locale_info("LOCALE_STIMEFORMAT"),"h" & locale_info("LOCALE_STIME")) if pos>0 then use12=1 ' determine am/pm pm=0 amstr=locale_info("LOCALE_S1159") pmstr=locale_info("LOCALE_S2359") posam=instr(1,strtime,amstr) pospm=instr(1,strtime,pmstr) if posam=0 and pospm>0 then pm=1 elseif posam>0 and pospm=0 then pm=0 elseif posam=0 and pospm=0 then use12=0 else if posam>pospm then _ pm=1 end if end if str=strtime numbers=parsenumbers(str) k=uBound(numbers) while k<3 redim Preserve numbers(k+1) numbers(k)=0 k=k+1 wend h=numbers(0) m=numbers(1) s=numbers(2) if use12<>0 and h<>0 then if pm=0 and h=12 then h=0 if pm=1 and h<12 then h=h+12 end if localtime2db = cstr(h) & ":" & cstr(m) & ":" & cstr(s) end function function localdatetime2db(strdatetime,format) dim use12, locale_idate, pm, amstr, pmstr, pos, tm, mmonth, dday, yyear, h, m, s, l dim numbers locale_idate=locale_info("LOCALE_IDATE") if format="dmy" then locale_idate=1 if format="mdy" then locale_idate=0 if format="ymd" then locale_idate=2 ' check if we use 12hours clock use12=0 pos=instr(1,locale_info("LOCALE_STIMEFORMAT"),"h" & locale_info("LOCALE_STIME")) if pos>0 then use12=1 ' determine am/pm pm=0 amstr=locale_info("LOCALE_S1159") pmstr=locale_info("LOCALE_S2359") posam=instr(1,strdatetime,amstr) pospm=instr(1,strdatetime,pmstr) if posam=0 and pospm>0 then pm=1 elseif posam>0 and pospm=0 then pm=0 elseif posam=0 and pospm=0 then use12=0 else if posam>pospm then _ pm=1 end if end if numbers=parsenumbers(strdatetime) if isArray(numbers) then if uBound(numbers)<2 then localdatetime2db = null exit function end if else localdatetime2db = null exit function end if '// add current year if not specified if uBound(numbers)<3 then if locale_idate<>1 then mmonth=numbers(0) dday=numbers(1) else mmonth=numbers(1) dday=numbers(0) end if yyear=year(now) else if locale_idate=0 then mmonth=numbers(0) dday=numbers(1) yyear=numbers(2) else if locale_idate=1 then dday=numbers(0) mmonth=numbers(1) yyear=numbers(2) else if locale_idate=2 then yyear=numbers(0) mmonth=numbers(1) dday=numbers(2) end if end if end if end if if mmonth=0 or dday=0 then localdatetime2db = null exit function end if l=uBound(numbers) while l<6 redim preserve numbers(l+1) numbers(l)=0 l=l+1 wend h=numbers(3) m=numbers(4) s=numbers(5) if use12=1 and h<>0 then if pm=0 and h=12 then h=0 if pm=1 and h<12 then h=h+12 end if if yyear<100 then if yyear<60 then yyear=yyear+2000 else yyear=yyear+1900 end if end if localdatetime2db = yyear & "-" & mmonth & "-" & dday & " " & h & ":" & m & ":" & s end function function parsenumbers(str) dim i, num, pos, j dim ret() i=1 num=0 pos=1 j=0 if len(str)=0 or isnull(str) then redim ret(0) parsenumbers = ret exit function end if while i<=len(str) if isNumeric(mid(str,i,1)) and num=0 then num=1 pos=i else if not isNumeric(mid(str,i,1)) and num<>0 then reDim Preserve ret(j+1) ret(j)=cint(mid(str,pos,i-pos)) j=j+1 num=0 end if end if i=i+1 wend if num<>0 then reDim Preserve ret(j+1) ret(j)=cint(mid(cstr(str),pos,i-pos+1)) j=j+1 end if if j=0 then redim ret(0) parsenumbers = ret exit function end if parsenumbers = ret end function '// returns day of week (1-7) for (monday-sunday) function format_datetime_custom(ttime(),format) dim i,weekday, hour12, am, out, inquot, n dim keys Set subst = CreateObject("Scripting.Dictionary") if isnull(ttime) then format_datetime_custom = "" exit function else if uBound(ttime)<3 or ttime(0)="" then format_datetime_custom = "" exit function end if end if if ttime(1)=0 then _ ttime(1)=1 i=1 weekday=getdayofweek(ttime) subst.Add "dddd",locale_info("LOCALE_SDAYNAME" & weekday) subst.Add "ddd",locale_info("LOCALE_SABBREVDAYNAME" & weekday) if len(cstr(ttime(2)))=1 then subst.Add "dd","0" & cstr(ttime(2)) else subst.Add "dd",cstr(ttime(2)) end if subst.Add "d",ttime(2) subst.Add "MMMM",locale_info("LOCALE_SMONTHNAME" & ttime(1)) subst.Add "MMM",locale_info("LOCALE_SABBREVMONTHNAME" & ttime(1)) if len(cstr(ttime(1)))=1 then subst.Add "MM","0" & cstr(ttime(1)) else subst.Add "MM",cstr(ttime(1)) end if subst.Add "M",ttime(1) var = CStr(ttime(0)) while len(var)<4 var = "0" & var wend subst.Add "yyyy", var var = CStr((ttime(0) mod 100)) while len(var)<2 var = "0" & var wend subst.Add "yy", var subst.Add "y",(ttime(0) mod 10) subst.Add "gg","" if len(cstr(ttime(3)))=1 then subst.Add "HH","0" & cstr(ttime(3)) else subst.Add "HH",cstr(ttime(3)) end if subst.Add "H",ttime(3) if len(cstr(ttime(4)))=1 then subst.Add "mm","0" & cstr(ttime(4)) else subst.Add "mm",cstr(ttime(4)) end if subst.Add "m",ttime(4) if len(cstr(ttime(5)))=1 then subst.Add "ss","0" & cstr(ttime(5)) else subst.Add "ss",cstr(ttime(5)) end if subst.Add "s",ttime(5) hour12=ttime(3) am=1 if hour12>=12 then am=0 hour12=hour12-12 end if if hour12=0 then hour12=12 subst.Add "hh",cstr(hour12) subst.Add "h",hour12 if am=1 then subst.Add "tt",locale_info("LOCALE_S1159") subst.Add "t",mid(locale_info("LOCALE_S1159"),1,1) else subst.Add "tt",locale_info("LOCALE_S2359") subst.Add "t",mid(locale_info("LOCALE_S2359"),1,1) end if out=format inquot=0 while i<=len(out) if mid(out,i,1)="'" then inquot=1-inquot out=mid(out,1,i) & mid(out,i+2) flag=1 else if inquot=0 then for each key in subst if mid(out,i,len(key))=key then out=mid(out,1,i-1) & subst(key) & mid(out,len(key)+i) i=i+len(subst(key))-1 exit for end if next end if end if i=i+1 wend format_datetime_custom = out end function function getdayofweek(ttime()) dim daydif, i '// January 1, 2004 - Thursday '// Get the differewnce in days between January 1, 2004 and January 1 of given year daydif=0 if ttime(0)>=2004 then for i=2004 to ttime(0)-1 if isleapyear(i) then daydif=daydif+366 else daydif=daydif+365 end if next else for i=2003 to ttime(0) step -1 if isleapyear(i) then daydif=daydif-366 else daydif=daydif-365 end if next end if '// to given month dim mdays(13) mdays(1)=31 mdays(2)=28 mdays(3)=31 mdays(4)=30 mdays(5)=31 mdays(6)=30 mdays(7)=31 mdays(8)=31 mdays(9)=30 mdays(10)=31 mdays(11)=30 mdays(12)=31 if isleapyear(ttime(0)) then mdays(2)=29 for i=1 to ttime(1)-1 daydif=daydif+mdays(i) next '// to given day daydif=daydif+ttime(2)-1 if daydif>0 then getdayofweek = (4+daydif-1) mod 7 + 1 exit function end if getdayofweek = 7-(3-daydif) mod 7 end function function isleapyear(y) if y mod 4 <>0 then isleapyear = false exit function end if if y mod 100 <>0 then isleapyear = true exit function end if if (y/100) mod 4 <> 0 then isleapyear = false exit function end if isleapyear = true end function function GetLongDateFormat() dim format, dstart, inquote, dindex, mindex, yindex, i, c, f format=locale_info("LOCALE_SLONGDATE") '// dd,d - day '// MMMM, MMM, MM, M - month '// yyyy, yy, y - year '// dddd, ddd - day of week, ignore it '// 'sdsd' - quoted string, ignore it. dstart=-1 inquote=false dindex=-1 mindex=-1 yindex=-1 i=0 f=1 while f=1 c="" if i=0 and c<>"d" then if i-dstart<=2 then dindex=dstart dstart=-1 end if if not inquote and c="\'" then inquote=true else if c="\'" then inquote=false else if not inquote then if dindex<0 and c="d" then if dstart<0 then dstart=i end if if yindex<0 and c="y" then yindex=i if mindex<0 and c="M" then mindex=i end if end if end if if i>=len(format) then f=0 i=i+1 wend if dindex<0 or mindex<0 or yindex<0 then GetLongDateFormat = -1 exit function end if if dindex <% %> <% '//////////////////////////////////////////////////////////////////////////////// '// table and field info functions '//////////////////////////////////////////////////////////////////////////////// function GetTableData(atable,key,default) dim table table=atable If atable = "" Then table = strTableName if not tables_data.Exists(table) then GetTableData = default exit function end if if not tables_data(table).Exists(key) then GetTableData = default exit function end if GetTableData = tables_data(table)(key) end function function GetFieldData(atable,field,key,default) dim table table=atable If atable = "" Then table = strTableName if not tables_data.Exists(table) then GetFieldData = default exit function end if if not tables_data(table).Exists(field) then GetFieldData = default exit function end if if not tables_data(table)(field).Exists(key) then GetFieldData = default exit function end if GetFieldData = tables_data(table)(field)(key) end function ' return field label Function Label(field, table) Label = GetFieldData(table,field,"Label",field) end function ' return filename field if any Function GetFilenameField(field, table) GetFilenameField = GetFieldData(table,field,"Filename","") End Function ' return hyperlink prefix Function GetLinkPrefix(field, table) GetLinkPrefix = GetFieldData(table,field,"LinkPrefix","") end function ' return database field type ' using ADO DataTypeEnum constants ' the full list available at: ' http://msdn.microsoft.com/library/default.asp?url=/library/en-us/ado270/htm/mdcstdatatypeenum.asp Function GetFieldType(field, table) GetFieldType = GetFieldData(table,field,"FieldType","") end function ' return Edit format Function GetEditFormat(field, table) GetEditFormat = GetFieldData(table,field,"EditFormat","") end function ' return View format Function format(field, table) format = GetFieldData(table,field,"ViewFormat","") end function ' show time in datepicker or not Function DateEditShowTime(field, table) DateEditShowTime = GetFieldData(table,field,"ShowTime",false) end function ' return field name Function GetFieldByGoodFieldName(field, atable) dim table table=atable If atable = "" Then table = strTableName if not tables_data.Exists(table) then GetFieldByGoodFieldName = "" exit function end if for each f in tables_data(table) if tables_data(table)(f)("GoodName")=field then GetFieldByGoodFieldName = f exit function end if next GetFieldByGoodFieldName = "" end function ' return the full database field original name Function GetFullFieldName(field, table) GetFullFieldName = GetFieldData(table,field,"FullName",field) end function ' return height of text area Function GetNRows(field, table) GetNRows = GetFieldData(table,field,"nRows",field) end function ' return width of text area Function GetNCols(field, table) GetNCols = GetFieldData(table,field,"nCols",field) end function ' return number of chars to show before More... link Function GetNumberOfChars(table) GetNumberOfChars = GetTableData(table,".NumberOfChars",0) end function ' return table short name Function GetTableURL(atable) dim table table=atable If atable = "" Then table = strTableName If "RasBaalbeck" = table Then GetTableURL = "RasBaalbeck" Exit Function End If End Function ' return table Owner ID field Function GetTableOwnerID() GetTableOwnerID = GetTableData(strTableName,".OwnerID","") end function ' is field marked as required Function IsRequired(field, table) IsRequired = GetFieldData(table,field,"IsRequired",false) end function ' use Rich Text Editor or not Function UseRTE(field, table) UseRTE = GetFieldData(table,field,"UseRTE",false) end function ' add timestamp to filename when uploading files or not Function UseTimestamp(field, table) UseTimestamp = GetFieldData(table,field,"UseTimestamp",false) end function Function GetUploadFolder(field, table) Dim path path = GetFieldData(table,field,"UploadFolder","") If Len(path) > 0 then if Mid(path, Len(path) - 1) <> "/" Then path = path & "/" end if GetUploadFolder = path End Function Function GetFieldIndex(field, table) GetFieldIndex = GetFieldData(table,field,"Index",0) End Function ' return Date field edit type Function DateEditType(field, table) DateEditType=GetFieldData(table,field,"DateEditType",0) end function ' returns text edit parameters Function GetEditParams(field, table) GetEditParams=GetFieldData(table,field,"EditParams","") end function '//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'// '// data output functions '//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'// ' format field value for output Function GetData(data, field, fformat) Dim ret, numbers, l, fso, link, title, iquery, thumbnailed,thumbprefix Dim arr(6) Set fso = CreateObject("Scripting.FileSystemObject") ret = "" ' long binary data? If IsBinaryType(GetFieldType(field,"")) Then GetData="LONG BINARY DATA - CANNOT BE DISPLAYED" Exit Function Else if GetFieldType(field,"") <> 205 then if GetFieldType(field,"")=19 then ret = CLng(data(field)) else ret = data(field) end if end if End If If isnull(ret) Then GetData = "" Exit Function End If if vartype(ret)=11 then if ret=false then GetData = "" Exit Function end if End If If fformat = FORMAT_DATE_SHORT Then ret = format_shortdate(db2time(data(field))) Elseif fformat = FORMAT_DATE_LONG Then ret = format_longdate(db2time(data(field))) ElseIf fformat = FORMAT_DATE_TIME Then ret = format_datetime(db2time(data(field))) ElseIf fformat = FORMAT_TIME Then If IsDateFieldType(GetFieldType(field,"")) Then ret = fformat_time(db2time(data(field))) Else numbers = parsenumbers(data(field)) If UBound(numbers) = 0 Then GetData = "" Exit Function End If l = UBound(numbers) While l < 3 ReDim Preserve numbers(l + 1) numbers(l) = 0 l=l+1 Wend arr(0) = 0 arr(1) = 0 arr(2) = 0 arr(3) = numbers(0) arr(4) = numbers(1) arr(5) = numbers(2) ret = fformat_time(arr) End If ElseIf fformat = FORMAT_NUMBER Then ret = FormatNumber(CDbl(data(field))) ElseIf fformat = FORMAT_CURRENCY Then ret = FormatCurrency(CDbl(data(field))) ElseIf fformat = FORMAT_CHECKBOX Then If CStr(data(field)) <> "" And CStr(data(field)) <> "0" Then l = "yes" Else l = "no" End If ret = "" ElseIf fformat = FORMAT_PERCENT Then ret="" if isNumeric(data(field)) or vartype(data(field))=14 then ret = (CDBL(data(field)) * 100) & "%" ElseIf fformat = FORMAT_PHONE_NUMBER Then If Len(ret) = 7 Then ret = Mid(ret, 1, 3) & "-" & Mid(ret, 4) Else If Len(ret) = 10 Then ret = "(" & Mid(ret, 1, 3) & ") " & Mid(ret, 4, 3) & "-" & mid(ret, 7) End If ElseIf fformat = FORMAT_FILE_IMAGE Then If not CheckImageExtension(ret) Then GetData = "" Exit Function End If thumbnailed=false thumbprefix="" if thumbnailed then ' show thumbnail thumbname = thumbprefix & ret if mid(GetLinkPrefix(field,""),1,7)<>"http://" then if not fso.FileExists(server.MapPath(AddLinkPrefix(field,thumbname,""))) then _ thumbname = ret end if ret="" ret= ret & "" else ret = "" end if ElseIf fformat = FORMAT_HYPERLINK Then ret = GetHyperlink(ret, field, data, strTableName) ElseIf fformat = FORMAT_EMAILHYPERLINK Then link = ret title = ret If Mid(ret, 1, 7) = "mailto:" Then title = Mid(ret, 8) Else link = "mailto:" & link End If ret = "" & title & "" ElseIf fformat = FORMAT_FILE Then iquery = "field=" & server.URLEncode(field) If strTableName = "RasBaalbeck" Then iquery = iquery & "&key1=" & server.URLEncode(dbvalue(data("Key"))) End If GetData = "" & ret & "" Exit Function ElseIf GetEditFormat(field,"") = EDIT_FORMAT_CHECKBOX And fformat = FORMAT_NONE Then If ret <> "" And ret <> 0 Then ret="Yes" Else ret="No" End If ElseIf fformat = FORMAT_CUSTOM Then ret = CustomExpression(data, field, strTableName) End If GetData = ret End Function ' return custom expression Function CustomExpression(data, field, table) If table = "" Then table = strTableName strValue = data(field) CustomExpression = strValue End Function Function my_htmlspecialchars(str) Dim ret if IsArray(str) then ret = str(0) else ret=str end if if len(ret)>0 then ret = Replace(ret, "&", "&") ret = Replace(ret, """", """) ret = Replace(ret, "'", "'") ret = Replace(ret, "<", "<") ret = Replace(ret, ">", ">") end if my_htmlspecialchars = ret End Function Function ProcessLargeText(strValue, iquery, table, mode) Dim cNumberOfChars, ret, ind If mode = "" Then mode = MODE_LIST cNumberOfChars = GetNumberOfChars(table) If Mid(strValue, 1, 8) = " 0 And Len(strValue) > cNumberOfChars And (Len(strValue) < 200 Or Len(iquery)=0) And mode = MODE_LIST Then ret = Mid(strValue, 1, cNumberOfChars) ret = my_htmlspecialchars(ret) ret = ret & " "))) & "');" ret=ret & "pwin.document.write('

" & "Close window" & "');" ret=ret & "return false;"">" & "More" & " ..." Elseif cNumberOfChars > 0 And Len(strValue) > cNumberOfChars And mode = MODE_LIST Then table = GetTableURL(table) ret = Mid(strValue, 1, cNumberOfChars) ret = my_htmlspecialchars(ret) ret = ret & " " & "More" & " ..." Elseif cNumberOfChars > 0 And Len(strValue) > cNumberOfChars And mode = MODE_PRINT Then ret = Mid(strValue, 1, cNumberOfChars) If Len(strValue) > cNumberOfChars Then ret = ret & " ..." Else ret = my_htmlspecialchars(strValue) End If if not isnull(ret) then _ ret = replace(ret,vbcrlf,"
") ProcessLargeText = ret End Function ' construct hyperlink Function GetHyperlink(str, field, data, table) Dim ret, title, link, i, target, ttype If Len(table) = 0 Then table = strTableName If Len(str) = 0 Then GetHyperlink = "" Exit Function End If ret = str title = ret link = ret If Mid(ret, Len(ret)) = "#" Then i = InStr(1, ret, "#") if i "mailto:" Then link = prefix & link ret = "" & title & "" GetHyperlink = ret End Function ' add prefix to the URL Function AddLinkPrefix(field, link, table) If InStr(1, link, "://") = 0 And Mid(link, 1, 7) <> "mailto:" Then AddLinkPrefix = GetLinkPrefix(field, table) & link Exit Function End If AddLinkPrefix = link End Function ' return Totals string Function GetTotals(value, stype, iNumberOfRows, sFormat) If stype = "AVERAGE" Then If iNumberOfRows <> 0 Then value = value / iNumberOfRows Else GetTotals = "" Exit Function End If End If If sFormat = FORMAT_CURRENCY Then value = fformat_currency(value) ElseIf sFormat = FORMAT_NUMBER Then value = fformat_number(value) ElseIf sFormat = FORMAT_PERCENT Then value = fformat_number(value*100) & "%" End If If stype = "COUNT" Then GetTotals = iNumberOfRows Exit Function End If If stype = "TOTAL" Then GetTotals = value Exit Function End If If stype = "AVERAGE" Then GetTotals = value Exit Function End If GetTotals = "" End Function '//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'// '// miscellaneous functions '//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'// ' return POST or GET value - single value or array Function postvalue(name) '??? dim value, i dim ret if parse<>1 then if request.form(name)<>"" then value=request.form(name) if request.form(name).Count=0 then postvalue = "" exit function end if if request.form(name).Count=1 then postvalue = value exit function end if redim ret(request.form(name).Count-1) for i=1 to request.form(name).Count ret(i-1)=request.form(name).Item(i) next elseif request.querystring(name)<>"" then value=request.querystring(name) if request.querystring(name).Count=0 then postvalue = "" exit function end if if request.querystring(name).Count=1 then postvalue = value exit function end if redim ret(request.querystring(name).Count-1) for i=1 to request.querystring(name).Count ret(i-1)=request.querystring(name).Item(i) next else postvalue = "" exit function end if postvalue = ret exit function else if getRequestForm(name & "[]")<>"" then name= name & "[]" postvalue=getRequestForm(name) else postvalue=getRequestForm(name) exit function end if end if End Function ' analog of strrpos function Function my_strrpos(haystack, needle) Dim index index = InStrRev(haystack, needle) If index = 0 Then my_strrpos = False Exit Function End If index = Len(haystack) - Len(needle) - index my_strrpos = index End Function ' utf-8 analog of strlen function Function strlen_utf8(str) Dim vlen, i, olen, c vlen = 0 i = 0 olen = Len(str) While i < olen c = Asc(Mid(str, i + 1, 1)) If c < 128 Then i = i + 1 Else If i < olen - 1 And c >= 192 And c <= 223 Then i = i + 2 Else If i < olen - 2 And c >= 224 And c <= 239 Then i = i + 3 Else If i < olen - 3 And c >= 240 Then i = i + 4 Else i = olen + 1 End If End If End If End If vlen = vlen + 1 Wend strlen_utf8 = vlen End Function ' utf-8 analog of substr function Function substr_utf8(str, index, strlen) Dim vlen, olen, oindex, c, i If strlen <= 0 Then substr_utf8 = "" Exit Function End If vlen = 0 i = 0 olen = Len(str) oindex = -1 While i < olen If vlen = index Then oindex = i c = Asc(Mid(str, i + 1, 1)) If c < 128 Then i = i + 1 Else If i < olen - 1 And c >= 192 And c <= 223 Then i = i + 2 Else If i < olen - 2 And c >= 224 And c <= 239 Then i = i + 3 Else If i < olen - 3 And c >= 240 Then i = i + 4 Else c = 200 End If End If End If End If vlen = vlen + 1 If oindex >= 0 And vlen = index + strlen Then substr_utf8 = Mid(str, oindex + 1, i - oindex) Exit Function End If Wend If oindex > 0 Then substr_utf8 = Mid(str, oindex + 1, olen - oindex) substr_utf8 = "" End Function ' read the whole file and return contents Function myfile_get_contents(filename) Dim fso, handle, contents, fsize, f Set fso = CreateObject("Scripting.FileSystemObject") If Not fso.FileExists(filename) Then myfile_get_contents = False Exit Function End If f = fso.GetFile(filename) fsize = f.Size handle = fso.OpenTextFile(filename, 1, True) If handle Is Nothing Then myfile_get_contents = False Exit Function End If If fsize > 0 Then contents = fso.read(fsize) Else contents = "" End If fso.Close myfile_get_contents = contents End Function ' construct "good" field name Function GoodFieldName(field) Dim i, t, ffield ffield=field For i = 0 To Len(ffield) - 1 t = Asc(Mid(ffield, i + 1, 1)) If (t < Asc("a") Or t > Asc("z")) And (t < Asc("A") Or t > Asc("Z")) And (t < Asc("0") Or t > Asc("9")) Then If i > 0 Then ffield = Left(ffield, i) & "_" & Mid(ffield, i + 2) Else ffield = "_" & Mid(ffield, i + 2) End If End If Next GoodFieldName = ffield End Function Function LogInfo(sql) dSQL = sql If dDebug Then response.Write dSQL & "
" End Function ' suggest image type by extension Function SupposeImageType(file) If LenB(file) > 1 And MidB(file, 1, 2) = chrb(asc("B")) & chrb(asc("M")) Then SupposeImageType = "image/bmp" Exit Function End If If LenB(file) > 2 And MidB(file, 1, 3) = chrb(asc("G")) & chrb(asc("I"))& chrb(asc("F")) Then SupposeImageType = "image/gif" Exit Function End If if LenB(file) > 3 and MidB(file, 1, 3) = chrb(&Hff) & chrb(&Hd8) & chrb(&Hff) then SupposeImageType = "image/jpeg" Exit Function End If if LenB(file) > 8 and MidB(file, 1, 8) = chrb(&H89) & chrb(&H50) & chrb(&H4e) & chrb(&H47) _ & chrb(&H0d) & chrb(&H0a) & chrb(&H1a) & chrb(&H0a) then SupposeImageType = "image/png" Exit Function End If SupposeImageType="" End Function ' check if file extension is image extension Function CheckImageExtension(filename) Dim ext If Len(filename) < 4 or isnull(filename) Then CheckImageExtension = false Exit Function End If ext = UCase(right(filename,4)) If ext = ".GIF" Or ext = ".JPG" Or ext = "JPEG" Or ext = ".PNG" Or ext = ".BMP" Then CheckImageExtension = True Exit Function End If CheckImageExtension = False End Function Function RTESafe(strText) Dim tmpString ' returns safe code for preloading in the RTE tmpString = "" tmpString = Trim(strText) If tmpString = "" Then RTESafe = "" ' convert all types of single quotes tmpString = Replace(tmpString, Chr(145), Chr(39)) tmpString = Replace(tmpString, Chr(146), Chr(39)) tmpString = Replace(tmpString, "'", "'") ' convert all types of double quotes tmpString = Replace(tmpString, Chr(147), Chr(34)) tmpString = Replace(tmpString, Chr(148), Chr(34)) ' replace carriage returns & line feeds tmpString = Replace(tmpString, Chr(10), " ") tmpString = Replace(tmpString, Chr(13), " ") RTESafe = tmpString End Function Function tnow() tnow = Year(Now) & "-" & Month(Now) & "-" & Day(Now) & " " & Hour(Time) & ":" & Minute(Time) & ":" & Second(Now) End Function Function html_special_decode(str) Dim ret ret = str ret = Replace(ret, "&", "&") ret = Replace(ret, """", """) ret = Replace(ret, "'", "'") ret = Replace(ret, "<", "<") ret = Replace(ret, ">", ">") html_special_decode = ret End Function ''//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'// '// database and SQL related functions '//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'// ' add WHERE clause to SQL string Function AddWhere(strSQL, sWhere) if sWhere="" or InStr(strSQL, sWhere)>0 then AddWhere = strSQL Exit Function end if n = InStrRev(LCase(strSQL), " where ") n1 = InStrRev(LCase(strSQL), " group by ") if n1=0 then n1=len(strSQL) if n > 0 then AddWhere = Left(strSQL, n-1+Len(" where ")) & "(" & Mid(strSQL, n+Len(" where ")) & ") and (" & sWhere & ") " else AddWhere = Left(strSQL,n1) & " where (" & sWhere & ") " & Mid(strSQL,n1+1) end if End Function ' construct WHERE clause with key values Function KeyWhere(keys(), table) Dim StrWhere, value If table = "" Then table = strTableName StrWhere = "" ' RasBaalbeck If table = "RasBaalbeck" Then value = make_db_value("Key", keys("Key"),"","") If IsNull(value) Then StrWhere = StrWhere & GetFullFieldName("Key","") & " is null" Else StrWhere = StrWhere & GetFullFieldName("Key","") & "=" & make_db_value("Key", keys("Key"),"","") End If End If KeyWhere = StrWhere End Function ' consctruct SQL WHERE clause for simple search Function StrWhere(strField, SearchFor, strSearchOption, SearchFor2) Dim ttype, strQuote, sSearchFor, sSearchFor2, ttime, ret ttype = GetFieldType(strField,"") If strSearchOption = "Empty" Then If IsCharType(ttype) Then StrWhere = "(" & GetFullFieldName(strField,"") & " is null or " & GetFullFieldName(strField,"") & "='')" Exit Function Else StrWhere = GetFullFieldName(strField,"") & " is null" Exit Function End If End If strQuote = "" If NeedQuotes(ttype) Then strQuote = "'" ' return none if trying to compare numeric field and string value sSearchFor = SearchFor sSearchFor2 = SearchFor2 If IsBinaryType(ttype) or ttype=13 Then StrWhere = "" Exit Function End If If IsDateFieldType(ttype) And strSearchOption <> "Contains" And strSearchOption <> "Starts with ..." Then ttime = localdatetime2db(SearchFor,"") If IsNull(ttime) Then StrWhere = "" Exit Function End If sSearchFor = db_datequotes(ttime) If strSearchOption = "Between" Then ttime = localdatetime2db(SearchFor2,"") If IsNull(Time) Then sSearchFor2 = "" Else sSearchFor2 = db_datequotes(ttime) End If End If End If If strQuote = "" And Not IsNumeric(sSearchFor) And Not IsNumeric(sSearchFor) Then StrWhere = "" Exit Function Elseif strQuote = "" And strSearchOption <> "Contains" And strSearchOption <> "Starts with ..." Then sSearchFor = my_numeric(sSearchFor) sSearchFor2 = my_numeric(sSearchFor2) Elseif Not IsDateFieldType(ttype) And strSearchOption <> "Contains" And strSearchOption <> "Starts with ..." Then If IsTextType(ttype) Then sSearchFor = strQuote & db_addslashes(sSearchFor) & strQuote If strSearchOption = "Between" And sSearchFor2<>"" Then sSearchFor2 = strQuote & db_addslashes(sSearchFor2) & strQuote Else sSearchFor = db_upper(strQuote & db_addslashes(sSearchFor) & strQuote) If strSearchOption = "Between" And sSearchFor2<>"" Then sSearchFor2 = db_upper(strQuote & db_addslashes(sSearchFor2) & strQuote) End If Elseif Not IsDateFieldType(ttype) Then sSearchFor = db_addslashes(sSearchFor) End If if IsCharType(ttype) and not IsTextType(ttype) then strField=db_upper(GetFullFieldName(strField,"")) else strField=GetFullFieldName(strField,"") end if ret = "" If strSearchOption = "Contains" Then if IsCharType(ttype) and not IsTextType(ttype) then StrWhere = strField & " like " & db_upper("'%" & sSearchFor & "%'") Exit Function Else StrWhere = strField & " like '%" & sSearchFor & "%'" Exit Function End If Elseif strSearchOption = "Equals" Then StrWhere = strField & "=" & sSearchFor Exit Function ElseIf strSearchOption = "Starts with ..." Then if IsCharType(ttype) and not IsTextType(ttype) then StrWhere = strField & " like " & db_upper("'" & sSearchFor & "%'") Else StrWhere = strField & " like '" & sSearchFor & "%'" End If exit function Elseif strSearchOption = "More than ..." Then StrWhere = strField & ">" & sSearchFor Exit Function Elseif strSearchOption = "Less than ..." Then StrWhere = strField & "<" & sSearchFor Exit Function Elseif strSearchOption = "Equal or more than ..." Then StrWhere = strField & ">=" & sSearchFor Exit Function Elseif strSearchOption = "Equal or less than ..." Then StrWhere = strField & "<=" & sSearchFor Exit Function Elseif strSearchOption = "Between" Then ret = strField & ">=" & sSearchFor If sSearchFor2 <> "" Then ret = ret & " and " & strField & "<=" & sSearchFor2 StrWhere = ret Exit Function End If StrWhere = "" End Function ' construct SQL WHERE clause for Advanced search Function StrWhereAdv(strField, SearchFor, strSearchOption, SearchFor2, etype) Dim ttype, ret, value, aSearchFor, i ttype = GetFieldType(strField,"") If IsBinaryType(ttype) Then StrWhereAdv = "" Exit Function End If If strSearchOption = "Empty" Then If IsCharType(ttype) Then StrWhereAdv = "(" & GetFullFieldName(strField,"") & " is null or " & GetFullFieldName(strField,"") & "='')" Exit Function Else StrWhereAdv = GetFullFieldName(strField,"") & " is null" Exit Function End If End If If GetEditFormat(strField,"") = EDIT_FORMAT_LOOKUP_WIZARD Then aSearchFor = splitvalues(SearchFor) ret = "" For i = 0 To UBound(aSearchFor) - 1 If Not (aSearchFor(i) = "null" Or aSearchFor(i) = "Null" Or aSearchFor(i) = "") Then If Len(ret) <> 0 Then ret = ret & " or " If strSearchOption = "Equals" Then aSearchFor(i) = make_db_value(strField, aSearchFor(i),"","") If Not (aSearchFor(i) = "null" Or aSearchFor(i) = "Null") Then ret = ret & GetFullFieldName(strField,"") & "=" & aSearchFor(i) Else ret = ret & GetFullFieldName(strField,"") & " like '%" & aSearchFor(i) & "%'" End If End If Next If Len(ret) <> 0 Then ret = "(" & ret & ")" StrWhereAdv = ret exit function End If value1 = make_db_value(strField, SearchFor, etype,"") value2 = False If strSearchOption = "Between" Then value2 = make_db_value(strField, SearchFor2, etype,"") If strSearchOption <> "Contains" And strSearchOption <> "Starts with ..." And (IsNull(value1) Or IsNull(value2) or value1="null" or value2="null") Then StrWhereAdv = "" Exit Function End If if ischartype(ttype) and not IsTextType(ttype) then value1 = db_upper(value1) value2 = db_upper(value2) strField = db_upper(GetFullFieldName(strField,"")) else strField=GetFullFieldName(strField,"") end if ret = "" If strSearchOption = "Contains" Then if ischartype(ttype) and not IsTextType(ttype) then StrWhereAdv = strField & " like " & db_upper("'%" & db_addslashes(SearchFor) & "%'") Exit Function Else StrWhereAdv = strField & " like '%" & db_addslashes(SearchFor) & "%'" Exit Function End If Else If strSearchOption = "Equals" Then StrWhereAdv = strField & "=" & value1 Exit Function Else If strSearchOption = "Starts with ..." Then if ischartype(ttype) and not IsTextType(ttype) then StrWhereAdv = strField & " like " & db_upper("'" & db_addslashes(SearchFor) & "%'") Exit Function Else StrWhereAdv = strField & " like '" & db_addslashes(SearchFor) & "%'" Exit Function End If Else If strSearchOption = "More than ..." Then StrWhereAdv = strField & ">" & value1 Exit Function Else If strSearchOption = "Less than ..." Then StrWhereAdv = strField & "<" & value1 Exit Function Else If strSearchOption = "Equal or more than ..." Then StrWhereAdv = strField & ">=" & value1 Exit Function Else If strSearchOption = "Equal or less than ..." Then StrWhereAdv = strField & "<=" & value1 exit function Else If strSearchOption = "Between" Then ret = strField & ">=" & value1 ret = ret & " and " & strField & "<=" & value2 StrWhereAdv = ret Exit Function End If End If End If End If End If End If End If End If StrWhereAdv = "" End Function ' get count of rows from the query Function GetRowCount(strSQL) strSQL=replace(strSQL,vbcrlf," ") strSQL=replace(strSQL,vblf," ") tstr = ucase(strSQL) ind1 = instr(tstr,"SELECT ") ind2 = instr(tstr," FROM ") ind3 = instr(tstr," GROUP BY ") if ind3=0 then ind3 = instr(tstr," ORDER BY ") if ind3=0 then ind3=len(strSQL) end if countstr=mid(strSQL,1,ind1+6) & " count(*) " & mid(strSQL,ind2+1,ind3-ind2) Set rc = server.CreateObject("ADODB.Recordset") rc.Open countstr,dbConnection cc=rc(0) rc.Close GetRowCount=CLng(cc) End Function ' add MSSQL Server TOP clause Function AddTop(strSQL, n) Dim tstr, ind1 tstr = UCase(strSQL) ind1 = InStr(tstr, "SELECT") AddTop = Mid(strSQL, 1, ind1 + 6) & " top " & n & Mid(strSQL, ind1 + 6) End Function ' add Oracle ROWNUMBER checking Function AddRowNumber(strSQL, n) AddRowNumber = "select * from (" & strSQL & ") where rownum<" & (n + 1) End Function ' test database type if values need to be quoted Function NeedQuotesNumeric(ttype) If ttype = 203 Or ttype = 8 Or ttype = 129 Or ttype = 130 Or _ ttype = 7 Or ttype = 133 Or ttype = 134 Or ttype = 135 Or _ ttype = 201 Or ttype = 205 Or ttype = 200 Or ttype = 202 Or ttype = 72 Or ttype = 13 Then NeedQuotesNumeric = True Else NeedQuotesNumeric = False End If End Function ' using ADO DataTypeEnum constants ' the full list available at: ' http://msdn.microsoft.com/library/default.asp?url=/library/en-us/ado270/htm/mdcstdatatypeenum.asp Function IsNumberType(ttype) If ttype = 20 Or ttype = 6 Or ttype = 14 Or ttype = 5 Or ttype = 10 _ Or ttype = 3 Or ttype = 131 Or ttype = 4 Or ttype = 2 Or ttype = 16 _ Or ttype = 21 Or ttype = 19 Or ttype = 18 Or ttype = 17 Or ttype = 139 or ttype=11 Then IsNumberType = True Exit Function End If IsNumberType = False End Function Function NeedQuotes(ttype) NeedQuotes = Not IsNumberType(ttype) End Function Function IsBinaryType(ttype) If ttype = 128 Or ttype = 205 Or ttype = 204 Then IsBinaryType = True Exit Function End If IsBinaryType = False End Function Function IsDateFieldType(ttype) If ttype = 7 Or ttype = 133 Or ttype = 135 Then IsDateFieldType = True Exit Function End If IsDateFieldType = False End Function Function IsCharType(ttype) If IsTextType(ttype) Or ttype = 8 Or ttype = 129 Or ttype = 200 Or ttype = 202 Or ttype = 130 Then IsCharType = True Exit Function End If IsCharType = False End Function Function IsTextType(ttype) If ttype = 201 Or ttype = 203 Then IsTextType = True Exit Function End If IsTextType = False End Function ' check whether field is viewable function CheckFieldPermissions(field, table) CheckFieldPermissions = GetFieldData(table,field,"FieldPermissions",false) end function ' function CheckSecurity(strVal, strAction) CheckSecurity = true end function ' add security WHERE clause to SELECT SQL command function SecuritySQL(strAction) dim ownerid, ret, strPerm end function '////////////////////////////////////////////////////////////////////////////// '// editing functions '//////////////////////////////////////////////////////////////////////////////// function make_db_value(field,value,controltype,postfilename) dim ret ret=prepare_for_db(field,value,controltype,postfilename) if vartype(ret)=11 then if ret=false then make_db_value=ret exit function end if end if make_db_value=add_db_quotes(field,ret) end function function add_db_quotes(field,value) dim ttype, strvalue ttype=GetFieldType(field,"") if IsBinaryType(ttype) then add_db_quotes = db_addslashesbinary(value) exit function end if if IsNull(value) then add_db_quotes = "null" exit function end if if (CStr(value)="" or vartype(value)=11 and CStr(value)="False") and not ischartype(ttype) then add_db_quotes = "null" exit function end if if NeedQuotes(ttype) then if not IsDateFieldType(ttype) then add_db_quotes="'" & db_addslashes(value) & "'" Else add_db_quotes=db_datequotes(value) end if Else strvalue = cstr(value) strvalue = replace(strvalue,",",".") add_db_quotes=my_numeric(strvalue) end if end function function prepare_for_db(field,value,controltype,postfilename) dim ttype, ttime filename="" ttype=GetFieldType(field,"") if controltype="" then if isArray(value) then value=combinevalues(value) if (CStr(value)="" or vartype(value)=11 and CStr(value)="False") and not ischartype(ttype) then prepare_for_db = "" exit function end if prepare_for_db = value exit function elseif mid(controltype,1,4)="file" then if (trim(value)="" or isnull(value)) and mid(controltype,1,5)<>"file1" then prepare_for_db=false else prepare_for_db="" end if if trim(postfilename)<> "" then filename=trim(postfilename) exit function elseif mid(controltype,1,6)="upload" then if mid(controltype,6,1)="0" then prepare_for_db = false exit function end if prepare_for_db = value exit function elseif controltype="time" then if isnull(value) then prepare_for_db="" exit function end if if value="" then prepare_for_db="" exit function end if vtime=localtime2db(value) if IsDateFieldType(GetFieldType(field,"")) then _ vtime="2000-01-01 " & vtime prepare_for_db=vtime exit function elseif mid(controltype,1,4)="date" then dformat=cint(mid(controltype,5)) if dformat=EDIT_DATE_SIMPLE or dformat=EDIT_DATE_SIMPLE_DP then ttime=localdatetime2db(value,"") if ttime="null" then prepare_for_db = "" exit function end if prepare_for_db = ttime exit function elseif dformat=EDIT_DATE_DD or dformat=EDIT_DATE_DD_DP then dim a a=split(value,"-") if ubound(a)<2 then prepare_for_db = null exit function Else y=a(0) m=a(1) d=a(2) end if if y<100 then if y<70 then y=y+2000 Else y=y+1900 end if end if prepare_for_db = cstr(y) & "-" & cstr(m) & "-" & cstr(d) exit function Else prepare_for_db = "" exit function end if elseif mid(controltype,1,8)="checkbox" then if value="on" then ret=1 else ret=0 end if prepare_for_db = ret exit function Else prepare_for_db = false exit function end if end function ' combine checked values from multi-select list box function combinevalues(arr()) dim ret ret="" for i=0 to ubound(arr) if instr(1,arr(i),",")=0 and instr(1,arr(i),"""")=0 then ret = ret & arr(i) Else val = replace(arr(i),"""","""""") ret = ret & """ & val & """ end if if i"," then val = mid(str,start,i-start+1) else val=mid(str,start,i-start) end if start=i+1 if len(val) and left(val,1)="""" then val=mid(val,2,len(val)-2) val=replace(val,"""""","""") end if arr2(x) = val x=x+1 end if i=i+1 wend splitvalues = arr2 end function '//////////////////////////////////////////////////////////////////////////////// '// edit controls creation functions '//////////////////////////////////////////////////////////////////////////////// ' ' write days dropdown function WriteDays(d) ret="" for i=1 to 31 s="" if cstr(i)=cstr(d) then s="selected" ret=ret & "" next WriteDays = ret end function ' write months dropdown function WriteMonths(m) dim monthnames(13) monthnames(1)="January" monthnames(2)="February" monthnames(3)="March" monthnames(4)="April" monthnames(5)="May" monthnames(6)="June" monthnames(7)="July" monthnames(8)="August" monthnames(9)="September" monthnames(10)="October" monthnames(11)="November" monthnames(12)="December" ret="" for i=1 to 12 s="" if cstr(i)=cstr(m) then s="selected" ret=ret & "" next WriteMonths = ret end function ' write years dropdown function WriteYears(y) ret="" firstyear=year(now)-10 if y<>0 then if firstyear>y-5 then firstyear=y-10 end if lastyear=year(now)+10 if y<>0 then if lastyear" & i & "" next WriteYears = ret end function ' returns HTML code that represents required Date edit control function GetDateEdit(field, value, ttype, secondfield,search) if secondfield="" then secondfield=false if search="" then search=MODE_EDIT cfieldname=GoodFieldName(field) cfield="value_" & GoodFieldName(field) ctype="type_" & GoodFieldName(field) if secondfield then cfield="value1_" & GoodFieldName(field) ctype="type1_" & GoodFieldName(field) end if iname=cfield tvalue=value dim ttime ttime=db2time(tvalue) if CStr(ttime(0))="" then ttime(0)=0 ttime(1)=0 ttime(2)=0 ttime(3)=0 ttime(4)=0 ttime(5)=0 end if dp=0 select case ttype Case EDIT_DATE_SIMPLE_DP ovalue=value if locale_info("LOCALE_IDATE")=1 then fmt="dd" & locale_info("LOCALE_SDATE") & "MM" & locale_info("LOCALE_SDATE") & "yyyy" sundayfirst="false" else if locale_info("LOCALE_IDATE")=0 then fmt="MM" & locale_info("LOCALE_SDATE") & "dd" & locale_info("LOCALE_SDATE") & "yyyy" sundayfirst="true" Else fmt="yyyy" & locale_info("LOCALE_SDATE") & "MM" & locale_info("LOCALE_SDATE") & "dd" sundayfirst="false" end if end if if DateEditShowTime(field,"") then if ttime(5)<>0 then fmt=fmt & " HH:mm:ss" else if ttime(3)<>0 or ttime(4)<>0 then fmt=fmt & " HH:mm" end if end if end if if ttime(0)>0 then ovalue=format_datetime_custom(ttime,fmt) ovalue1=ttime(2) & "-" & ttime(1) & "-" & ttime(0) showtime="false" if DateEditShowTime(field,"") then showtime="true" ovalue1=ovalue1 & " " & ttime(3) & ":" & ttime(4) & ":" & ttime(5) end if onblur="var dt=parse_datetime(this.value," & locale_info("LOCALE_IDATE") & "); if(dt!=null) editform.ts" & iname & ".value=print_datetime(dt,-1," & showtime & "); else editform.ts" & iname & ".value='';" ret="" ret=ret & "  " ret=ret & "" ret=ret & "" ret=ret & "" response.Write ret exit function Case EDIT_DATE_DD,EDIT_DATE_DD_DP if ttype=EDIT_DATE_DD_DP then dp=1 else dp=0 end if ovalue=value if ttime(0)>0 then ovalue=format_datetime_custom(ttime,"yyyy-MM-dd") retday="" retmonth="" retyear="" sundayfirst="false" if locale_info("LOCALE_ILONGDATE")=1 then ret=retday & " " & retmonth & " " & retyear else if locale_info("LOCALE_ILONGDATE")=0 then ret=retmonth & " " & retday & " " & retyear sundayfirst="true" Else ret=retyear & " " & retmonth & " " & retday end if end if if dp<>0 then ret=ret & " " ret=ret & "" ret=ret & "" end if if ttime(0)>0 then ret=ret & "" Else ret=ret & "" end if ret=ret & "" response.Write ret exit function Case EDIT_DATE_SIMPLE ovalue=value if ttime(0)>0 then if ttime(3)<>0 or ttime(4)<>0 or ttime(5)<>0 then ovalue=format_datetime(ttime) Else ovalue=format_shortdate(ttime) end if end if response.Write "" case else ovalue=value if ttime(0)>0 then if ttime(3)<>0 or ttime(4)<>0 or ttime(5)<>0 then ovalue=format_datetime(ttime) Else ovalue=format_shortdate(ttime) end if end if response.Write "" end select end function ' create javascript array with values for dependent dropdowns sub BuildSecondDropdownArray(arrName, strSQL) dim i response.Write arrName & "=new Array();" & vbcrlf i=0 Set rs2 = server.CreateObject("ADODB.Recordset") rs2.Open strSQL,dbConnection while not rs2.EOF response.Write arrName & "[" & (i*3) & "]='" & jsreplace(dbvalue(rs2(0))) & "';" & vbcrlf response.Write arrName & "[" & (i*3 + 1) & "]='" & jsreplace(dbvalue(rs2(1))) & "';" & vbcrlf response.Write arrName & "[" & (i*3 + 2) & "]='" & jsreplace(dbvalue(rs2(2))) & "';" & vbcrlf i=i+1 rs2.movenext wend rs2.Close end sub ' create Lookup wizard control function BuildSelectControl(field, value, values, secondfield, mode) dim i if secondfield="" then secondfield=false LookupSQL ="" strSize = 1 cfieldname=GoodFieldName(field) cfield="value_" & GoodFieldName(field) ctype="type_" & GoodFieldName(field) if secondfield then cfield="value1_" & GoodFieldName(field) ctype="type1_" & GoodFieldName(field) end if Set arr = CreateObject("Scripting.Dictionary") d=0 if values<>"" then arr.add d,values d=d+1 end if addnewitem=false script="" ' multi-select multiple="" postfix="" dim res dim avalue if strSize>1 then avalue=splitvalues(value) multiple=" multiple" postfix="[]" Else redim avalue(0) avalue(0)=value end if if LookupSQL<>"" then LogInfo(LookupSQL) Set rse = server.CreateObject("ADODB.Recordset") rse.open LookupSQL,dbConnection onchange="" if onchange<>"" then onchange="onchange=""" & onchange & """" response.Write "" ' add new item if addnewitem and mode<>MODE_SEARCH then response.Write "" & "Add new" & "" end if rse.close Else response.Write "" end if end function function BuildRadioControl(field, value,secondfield) if secondfield="" then secondfield=false dim cfieldname,cfield,ctype cfieldname=GoodFieldName(field) cfield="value_" & GoodFieldName(field) ctype="type_" & GoodFieldName(field) if secondfield then cfield="value1_" & GoodFieldName(field) ctype="type1_" & GoodFieldName(field) end if LookupSQL ="" if len(LookupSQL)>1 then LogInfo(LookupSQL) Set rst = server.CreateObject("ADODB.Recordset") rst.open LookupSQL,dbConnection if rst.eof then BuildRadioControl = "" exit function end if response.Write "" while not rst.eof if not isnull(rst(0)) and CStr(rst(0))=value then response.Write "" & my_htmlspecialchars(rst(1)) & "
" Else response.Write "" & my_htmlspecialchars(rst(1)) & "
" end if rst.movenext wend rst.close Else response.Write "" for each opt in arr if arr.Item(opt)=value then response.Write "" & my_htmlspecialchars(arr.Item(opt)) & "
" Else response.Write "" & my_htmlspecialchars(arr.Item(opt)) & "
" end if next end if BuildRadioControl = "" end function function BuildEditControl(field , value, fformat, edit, secondfield) if secondfield="" then secondfield=false cfieldname=GoodFieldName(field) cfield="value_" & GoodFieldName(field) ctype="type_" & GoodFieldName(field) if secondfield then cfield="value1_" & GoodFieldName(field) ctype="type1_" & GoodFieldName(field) end if ttype=GetFieldType(field,"") arr="" if fformat=EDIT_FORMAT_FILE and edit=MODE_SEARCH then fformat="" if fformat=EDIT_FORMAT_TEXT_FIELD then if IsDateFieldType(ttype) then response.Write "" & GetDateEdit(field,value,0,secondfield,edit) Else response.Write "" end if elseif fformat=EDIT_FORMAT_TIME then response.write "" if IsDateFieldType(ttype) then dbtime=db2time(value) if ubound(dbtime)>0 then val=fformat_time(dbtime) else val="" end if else arr=parsenumbers(value) if ubound(arr)>0 then dim dbtime(6) dbtime(0)=0 dbtime(1)=0 dbtime(2)=0 dbtime(3)=0 dbtime(4)=0 dbtime(5)=0 dim i for i=0 to 2 if ubound(arr)>i then dbtime(i+3)=arr(i) next val=fformat_time(dbtime) else val="" end if end if response.write "" elseif fformat=EDIT_FORMAT_TEXT_AREA then nWidth = GetNCols(field, strTableName) nHeight = GetNRows(field, strTableName) if UseRTE(field, strTableName) then value = RTESafe(value) Else response.Write "" end if elseif fformat=EDIT_FORMAT_PASSWORD then response.Write "" elseif fformat=EDIT_FORMAT_DATE then response.Write "" & GetDateEdit(field,value,DateEditType(field,""),secondfield,edit) elseif fformat=EDIT_FORMAT_RADIO then a=BuildRadioControl(field,value,secondfield) elseif fformat=EDIT_FORMAT_CHECKBOX then if edit=MODE_ADD or edit=MODE_EDIT then ch="" if isNumeric(value) then if value<>0 then ch="checked" else if value<>"" and value<>"False" then ch="checked" end if response.Write "" Else response.Write "" response.Write "" end if elseif fformat=EDIT_FORMAT_DATABASE_IMAGE or fformat=EDIT_FORMAT_DATABASE_FILE then iquery="field=" & server.urlencode(field) keylink="" if strTableName="RasBaalbeck" then keylink=keylink & "&key1=" & server.urlencode(keys("Key")) iquery=iquery & keylink end if disp="" strfilename="" onchangefile="" if edit=MODE_EDIT then if lenb(rs(field))>0 then dim pict pict=rs(field).GetChunk(20000000) if lenb(rs(field))>100 then value=db_stripslashesbinary(midb(pict,1,100)) else value=db_stripslashesbinary(pict) end if else value="" end if itype=SupposeImageType(value) thumbnailed=false thumbfield="" if itype<>"" then if thumbnailed then disp = "" disp = disp & "" disp = disp & "" else disp="" end if Else if len(value)>0 then disp="" Else disp="" end if end if ' filename if fformat=EDIT_FORMAT_DATABASE_FILE and itype="" and len(value)>0 then filename=rs(GetFilenameField(field,"")) if filename="" then filename="file.bin" disp="" & disp & "" end if ' filename edit if fformat=EDIT_FORMAT_DATABASE_FILE and GetFilenameField(field,"")<>"" then filename=rs(GetFilenameField(field,"")) if filename="" then filename="" strfilename="
" & "Filename" & "  " onchangefile=onchangefile & "var path=this.form.elements['" & addslashes(cfield) & "'].value; var wpos=path.lastIndexOf('\\'); var upos=path.lastIndexOf('/'); var pos=wpos; if(upos>wpos) pos=upos; this.form.elements['filename_" & addslashes(cfieldname) & "'].value=path.substr(pos+1);" end if strtype="
" & "Keep" if len(value)>0 and not IsRequired(field,"") then strtype=strtype & "" & "Delete" onchangefile=onchangefile & "this.form.elements['" & addslashes(ctype) & "'][2].checked=true;" Else onchangefile=onchangefile & "this.form.elements['" & addslashes(ctype) & "'][1].checked=true;" end if strtype=strtype & "" & "Update" Else strtype="" if fformat=EDIT_FORMAT_DATABASE_FILE and GetFilenameField(field,"")<>"" then strfilename="
" & "Filename" & "  " onchangefile=onchangefile & "var path=this.form.elements['" & addslashes(cfield) & "'].value; var wpos=path.lastIndexOf('\\'); var upos=path.lastIndexOf('/'); var pos=wpos; if(upos>wpos) pos=upos; this.form.elements['filename_" & addslashes(cfieldname) & "'].value=path.substr(pos+1);" end if end if maxsize="" if max_filesize_set=0 then maxsize="" max_filesize_set=1 end if if onchangefile<>"" then onchangefile="onChange=""" & onchangefile & """" response.Write disp & strtype & maxsize & "
" & strfilename elseif fformat=EDIT_FORMAT_LOOKUP_WIZARD then BuildSelectControl field, value, arr, secondfield, edit elseif fformat=EDIT_FORMAT_HIDDEN then response.Write "" elseif fformat=EDIT_FORMAT_READONLY then response.Write "" elseif fformat=EDIT_FORMAT_FILE then disp="" strfilename="" onchangefile="" ffunction="" if edit=MODE_EDIT then ' show current file if Format(field,"")=FORMAT_FILE or Format(field,"")=FORMAT_FILE_IMAGE then disp=GetData(rs,field,Format(field,"")) & "
" filename=value ffunction="" & vbcrlf ' filename edit filename_size=30 if UseTimestamp(field,"") then filename_size=50 strfilename="
" & "Filename" & "  " onchangefile=onchangefile & "var path=this.form.file_" & cfieldname & ".value; var wpos=path.lastIndexOf('\\'); var upos=path.lastIndexOf('/'); var pos=wpos; if(upos>wpos) pos=upos; controlfilename" & cfieldname & "(true);" if UseTimestamp(field,"") then onchangefile=onchangefile & "this.form." & cfield & ".value=addTimestamp(path.substr(pos+1)); " Else onchangefile=onchangefile & "this.form." & cfield & ".value=path.substr(pos+1); " end if strtype="
" & "Keep" if len(value)>0 and not IsRequired(field,"") then strtype=strtype & "" & "Delete" onchangefile=onchangefile & "this.form." & ctype & "[2].checked=true;" Else onchangefile=onchangefile & "this.form." & ctype & "[1].checked=true;" end if strtype=strtype & "" & "Update" Else filename_size=30 if UseTimestamp(field,"") then filename_size=50 strtype="" strfilename="
" & "Filename" & "  " onchangefile=onchangefile & "var path=this.form.file_" & cfieldname & ".value; var wpos=path.lastIndexOf('\\'); var upos=path.lastIndexOf('/'); var pos=wpos; if(upos>wpos) pos=upos;" if UseTimestamp(field,"") then onchangefile=onchangefile & " this.form." & cfield & ".value=addTimestamp(path.substr(pos+1));" Else onchangefile=onchangefile & " this.form." & cfield & ".value=path.substr(pos+1);" end if end if maxsize="" if max_filesize_set=0 then maxsize="" max_filesize_set=1 end if if onchangefile<>"" then onchangefile="onChange=""" & onchangefile & """" response.Write ffunction & disp & strtype & maxsize & "
" & strfilename end if end function Function pg_escape_string(name) name = Replace(name, "\", "\\") name = Replace(name, "'", "\'") return name End Function Function my_numeric(strName) If IsNumeric(strName) Then my_numeric = strName Else my_numeric = 0 End If End Function Sub DoEvent(strEvent) On Error Resume Next Execute strEvent If Err.Number <> 13 Then strMoreInfo = "Event: " & strEvent ReportError End If On Error GoTo 0 End Sub Function ParseMultiPartForm if Request.TotalBytes = 0 then ParseMultiPartForm = false Exit Function end if ParseMultiPartForm = true Dim postData postData = Request.BinaryRead(Request.TotalBytes) contentType = Request.ServerVariables( "HTTP_CONTENT_TYPE") ctArray = split( contentType, ";") if trim(ctArray(0)) = "multipart/form-data" then errMsg = "" ' grab the form boundry... bArray = split( trim( ctArray(1)), "=") boundry = Unicode2Bytes("--" & trim( bArray(1))) currentPos = 1 inStrByte = 1 While inStrByte > 0 inStrByte = InStrB(currentPos, postData, boundry) m = inStrByte - currentPos If m > 1 Then val = MidB(postData, currentPos, m) infoEnd = instrB( val, chrb(13) & chrb(10) & chrb(13) & chrb(10) ) if infoEnd > 0 then varInfo = Bytes2String(midb( val , 1, infoEnd - 1)) varValue = midb( val , infoEnd + 4, lenb(val) - infoEnd - 5) if InStr(1, varInfo, "Content-Type") < 1 then varValue=Bytes2String(varValue) strField = getFieldName(varInfo) if myRequest.exists(strField) then myRequest(strField) = myRequest(strField) & "," & varValue else myRequest.add strField, varValue end if end if end if currentPos = lenb(boundry) + inStrByte wend else errMsg = "Wrong encoding type!" end if End Function ' This function retreives a field's name function getFieldName( infoStr) sPos = inStr( infoStr, "name=") endPos = inStr( sPos + 6, infoStr, chr(34) & ";") if endPos = 0 then endPos = inStr( sPos + 6, infoStr, chr(34)) end if getFieldName = mid( infoStr, sPos + 6, endPos - (sPos + 6)) end function ' This function retreives a file field's filename function getFileName( infoStr) sPos = inStr( infoStr, "filename=") endPos = inStr( infoStr, chr(34) & crlf) getFileName = mid( infoStr, sPos + 10, endPos - (sPos + 10)) end function ' This function retreives a file field's mime type function getFileType( infoStr) sPos = inStr( infoStr, "Content-Type: ") getFileType = mid( infoStr, sPos + 14) end function Function GetRequestForm(key) if isEmpty(myRequest) then GetRequestForm="" Exit Function end if if myRequest.Exists(key) then GetRequestForm = myRequest(key) else GetRequestForm = Request.QueryString(key) end if End Function Function Unicode2Bytes(str) For ind = 1 To len(str) Unicode2Bytes = Unicode2Bytes& ChrB(Asc(Mid(str, ind, 1))) Next End Function function addslashes(str) str = replace(str,"'","\'") str = replace(str,"""","\""") addslashes = replace(str,"/","\/") end function Sub sendmail(email, subject, message) Dim i if email="" or isnull(email) then strMessage = "Email address is empty. Cannot send email." Exit Sub end if 'On Error Resume Next Version = Request.ServerVariables("SERVER_SOFTWARE") If InStr(Version, "Microsoft-IIS") > 0 Then i = InStr(Version, "/") If i > 0 Then IISVer = Trim(Mid(Version, i+1)) End If End If If IISVer <= "5.0" Then ' Windows NT / 2000 Set myMail = Server.CreateObject("CDONTS.NewMail") myMail.From = cfrom myMail.To = email myMail.Subject = subject myMail.Body = message myMail.Send Set myMail = Nothing Else ' Windows XP / 2003 Set myMail=CreateObject("CDO.Message") myMail.Subject = subject myMail.From=cfrom myMail.To=email myMail.TextBody= message myMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing")=2 'Name or IP of remote SMTP server myMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver")=csmtpserver 'Server port myMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport")=csmtpport ' SMTP username and passwords myMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = csmtppassword myMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = csmtpuser myMail.Configuration.Fields.Update myMail.Send Set myMail = Nothing End If if Err.Number<>0 then strMessage = "Error happened sending email to " & email & "
" & Err.Source & "
" & Err.Number & "
" & Err.Description Err.Clear end if End Sub Function IsFloat(nType) IsFloat = false if nType=14 or nType=5 or nType=131 then IsFloat=true end if End Function Function Bytes2String(bytes) Dim i, byteord, nextbyteord For i = 1 to LenB(bytes) byteord = AscB(MidB(bytes, i, 1)) If session.codepage<>65001 or byteord < &H80 Then ' Ascii Bytes2String= Bytes2String& Chr(byteord) Else ' Double-byte characters? if byteord >= &HC2 and byteord <= &HDF and i < LenB(bytes) then byteord2 = AscB(MidB(bytes, i+1, 1)) On Error Resume Next charindex = (byteord-192)*64 + (byteord2-128) Bytes2String= Bytes2String& ChrW(charindex) If Err.Number <> 0 Then On Error GoTo 0 Bytes2String= Bytes2String& Chr(byteord) & Chr(byteord2) End If i = i + 1 elseif byteord >= 112 and byteord < 240 and i+1 < LenB(bytes) then byteord2 = AscB(MidB(bytes, i+1, 1)) byteord3 = AscB(MidB(bytes, i+2, 1)) On Error Resume Next charindex = (byteord-224)*4096 + (byteord2-128)*64 + (byteord3-128) Bytes2String= Bytes2String& ChrW(charindex) If Err.Number <> 0 Then On Error GoTo 0 Bytes2String= Bytes2String& Chr(byteord) & Chr(byteord2) & Chr(byteord3) End If i = i + 2 elseif i+2 < LenB(bytes) then byteord2 = AscB(MidB(bytes, i+1, 1)) byteord3 = AscB(MidB(bytes, i+2, 1)) byteord4 = AscB(MidB(bytes, i+3, 1)) On Error Resume Next charindex = (byteord-240)*262144 + (byteord2-128)*4096 + (byteord3-128)*64 + (byteord4-128) Bytes2String= Bytes2String& ChrW(charindex) If Err.Number <> 0 Then On Error GoTo 0 Bytes2String= Bytes2String& Chr(byteord) & Chr(byteord2) & Chr(byteord3) & Chr(byteord4) End If i = i + 3 Else Bytes2String= Bytes2String& Chr(byteord) end if End If Next End Function Function CSmartDbl(strValue) On Error Resume Next CSmartDbl = CDbl(strValue) if Err.Number<>0 then Err.Clear if InStr(strValue, ".")>0 then CSmartDbl = CDbl(Replace(strValue, ".", ",")) elseif InStr(strValue, ",")>0 then CSmartDbl = CDbl(Replace(strValue, ",", ".")) end if Err.Clear end if On Error Goto 0 End Function sub DeleteFile(strFileName) Set fso = CreateObject("Scripting.FileSystemObject") if fso.FileExists(strFileName) then fso.DeleteFile(strFileName) end if set fso = Nothing end sub sub WriteToFile(strFileName, binData) Dim rsT Set rsT = Server.CreateObject("ADODB.Recordset") rsT.Fields.Append "File", 205, LenB(binData) rsT.Open rsT.AddNew rsT.Fields("File").AppendChunk binData rsT.Update Dim stream Set stream = Server.CreateObject("ADODB.Stream") stream.Type = 1 stream.Open stream.Write rsT.Fields("File").GetChunk(LenB(binData)) stream.SaveToFile strFileName, 2 stream.Close Set stream = Nothing rsT.Close Set rsT = Nothing end sub Function SafeURLEncode(str) if IsNULL(str) then str = "" SafeURLEncode = Server.URLEncode(CStr(str)) End Function function dbvalue(value) if isnull(value) then dbvalue="" exit function end if if vartype(value)=7 then dbvalue=year(value) & "-" & month(value) & "-" & day(value) & " " & hour(value) & ":" & minute(value) & ":" & second(value) exit function end if dbvalue=value exit function end function Function SafeIsEmpty(str) if IsArray(str) then SafeIsEmpty = false Exit Function end if SafeIsEmpty = (str="") End Function sub ReportError if Err.number<>0 then response.flush Set objXML = Server.CreateObject("Microsoft.XMLDOM") Set objLst = Server.CreateObject("Microsoft.XMLDOM") Set objSlt = Server.CreateObject("Microsoft.XMLDOM") objXML.async = False objXML.Load (Server.MapPath("include/errors.xml")) If objXML.parseError.errorCode <> 0 Then Response.Write "error occurs
error message: " & objXML.parseError.reason & "
in the line " & objXML.parseError.line & "
line of XML that contains the error" & objXML.parseError.srcText End If Set objLst = objXML.getElementsByTagName("Keywords") Set objSlt = objXML.getElementsByTagName("Solution") dim flag, noOfHeadlines, i, j, Description noOfHeadlines = objLst.length Dim ar Dim kwords Description = lcase(err.Description) flag = 1 i=0 while flag and i

ASP <%="error happened"%>

<% if strSQL<>"" then %> <% end if %> <% if strMoreInfo<>"" then %> <% end if %>
<%="Technical information" %>
Error number<%=Err.Number%>
<%="Error description" %><%=Err.Description%>
<%="URL" %><%=Request.ServerVariables("URL")%>
<%="SQL query" %><%=strSQL%>
Additional info<%=strMoreInfo%>
Solution<%=Solution%>

More info on this error

<% Response.End end if end sub sub AddDict(dict,key, value) if dict.Exists(key) then dict(key)=value else dict.add key,value end if end sub function jsreplace(str) jsreplace = replace(str,"\","\\") jsreplace = replace(jsreplace,vbcr,"\r") jsreplace = replace(jsreplace,vblf,"\n") jsreplace = replace(jsreplace,"'","\'") end function Sub DeleteUploadedFiles(where) dim i set rsTmp = Server.CreateObject("ADODB.Recordset") rsTmp.Open "select * from " & strOriginalTableName & " where " & where, dbConnection if not rsTmp.Eof then for i=0 to rsTmp.Fields.Count-1 if GetEditFormat(rsTmp.Fields(i).Name, strTableName)=EDIT_FORMAT_FILE then DeleteFile Server.MapPath(GetUploadFolder(rsTmp.Fields(i).Name, strTableName) & rsTmp(rsTmp.Fields(i).Name)) end if next rsTmp.Close set rsTmp = Nothing end if End Sub Function IsUpdatable(Field) if Field.Attributes and 4 or Field.Attributes and 8 then IsUpdatable=true else IsUpdatable=false end if End Function Function FormExists(Name) for x = 1 to Request.Form.count() if Request.Form.key(x) = Name then FormExists = True Exit Function end if next FormExists = False End Function function CreateThumbnail(value, size, ext) dim jpeg SafeCreateObject "Persits.Jpeg", jpeg if isnull(jpeg) then CreateThumbnail=value exit function end if on error resume next Jpeg.OpenBinary value if err.number<>0 then CreateThumbnail=value on error goto 0 exit function end if on error goto 0 dim sx,sy sx = Jpeg.OriginalWidth sy = Jpeg.OriginalHeight if sx<=size and sy<=size or sx=0 or sy=0 then CreateThumbnail=value exit function end if if sx>=sy then jpeg.Height=sy*size/sx jpeg.Width=size else jpeg.Width=sx*size/sy jpeg.Height=size end if dim ret CreateThumbnail=Jpeg.Binary end function sub SafeCreateObject(name,object) on error resume next set object = server.CreateObject(name) if err.Number<>0 then object=null end if on error goto 0 end sub %> <% strConnection = "DRIVER={Microsoft Access Driver (*.mdb)};DBQ=" & server.mappath("db\rasbaalbeck.mdb") & ";UID=;PWD=" %> <% Const FORMAT_NONE = "" Const FORMAT_DATE_SHORT = "Short Date" Const FORMAT_DATE_LONG = "Long Date" Const FORMAT_DATE_TIME = "Datetime" Const FORMAT_TIME = "Time" Const FORMAT_CURRENCY = "Currency" Const FORMAT_PERCENT = "Percent" Const FORMAT_HYPERLINK = "Hyperlink" Const FORMAT_EMAILHYPERLINK = "Email Hyperlink" Const FORMAT_FILE_IMAGE = "File-based Image" Const FORMAT_DATABASE_IMAGE = "Database Image" Const FORMAT_DATABASE_FILE = "Database File" Const FORMAT_FILE = "Document Download" Const FORMAT_LOOKUP_WIZARD = "Lookup wizard" Const FORMAT_PHONE_NUMBER = "Phone Number" Const FORMAT_NUMBER = "Number" Const FORMAT_HTML = "HTML" Const FORMAT_CHECKBOX = "Checkbox" Const FORMAT_CUSTOM = "Custom" Const EDIT_FORMAT_NONE = "" Const EDIT_FORMAT_TEXT_FIELD = "Text field" Const EDIT_FORMAT_TEXT_AREA = "Text area" Const EDIT_FORMAT_PASSWORD = "Password" Const EDIT_FORMAT_DATE = "Date" Const EDIT_FORMAT_TIME = "Time" Const EDIT_FORMAT_RADIO = "Radio button" Const EDIT_FORMAT_CHECKBOX = "Checkbox" Const EDIT_FORMAT_DATABASE_IMAGE = "Database image" Const EDIT_FORMAT_DATABASE_FILE = "Database file" Const EDIT_FORMAT_FILE = "Document upload" Const EDIT_FORMAT_LOOKUP_WIZARD = "Lookup wizard" Const EDIT_FORMAT_HIDDEN = "Hidden field" Const EDIT_FORMAT_READONLY = "Readonly" Const EDIT_DATE_SIMPLE = 0 Const EDIT_DATE_SIMPLE_DP = 11 Const EDIT_DATE_DD = 12 Const EDIT_DATE_DD_DP = 13 Const MODE_ADD = 0 Const MODE_EDIT = 1 Const MODE_SEARCH = 2 Const MODE_LIST = 3 Const MODE_PRINT = 4 Const MODE_VIEW = 5 Const LOGIN_HARDCODED = 0 Const LOGIN_TABLE = 1 Const ADVSECURITY_ALL = 0 Const ADVSECURITY_VIEW_OWN = 1 Const ADVSECURITY_EDIT_OWN = 2 Const ADVSECURITY_NONE = 3 Const ACCESS_LEVEL_ADMIN = "Admin" Const ACCESS_LEVEL_USER = "User" Const ACCESS_LEVEL_GUEST = "Guest" Const DATABASE_MySQL = "MYSQL" Const DATABASE_Oracle = "ORACLE" Const DATABASE_MSSQLServer = "MS SQL SERVER" Const DATABASE_Access = "ACCESS" Const RTE_BASIC = "BASIC" Const RTE_FCK = "FCK" Const RTE_INNOVA = "INNOVA" strLeftWrapper="[" strRightWrapper="]" cLoginTable = "" cUserNameField = "" cPasswordField = "" cUserGroupField = "" cEmailField = "" cFrom = "" cSmtpServer = "" cSmtpPort = "" cSMTPUser = "" cSMTPPassword = "" function db_connect() set dbConnection = server.CreateObject("ADODB.Connection") dbConnection.ConnectionString = strConnection dbConnection.Open end function function AddTableWrappers(strName) if mid(strName,1,1)=strLeftWrapper then AddTableWrappers = strName exit function end if dim arr arr=split(strName,".") ret=strLeftWrapper & arr(0) & strRightWrapper if ubound(arr)>0 then ret=ret & "." & strLeftWrapper & arr(1) & strRightWrapper AddTableWrappers = ret end function function db_upper(dbval) db_upper = "ucase(" & dbval & ")" end function function AddFieldWrappers(strName) if mid(strName,1,1)=strLeftWrapper then AddFieldWrappers = strName else AddFieldWrappers = strLeftWrapper & strName & strRightWrapper end if end function function FieldNeedQuotes(rs,field) ttype=db_fieldtype(rs,field) if ttype=20 or ttype=128 or ttype=11 or ttype=6 or ttype=14 or ttype=5 or ttype=3 or ttype=131 _ or ttype=4 or ttype=2 or ttype=16 or ttype=21 or ttype=19 or ttype=18 or ttype=17 or ttype=139 then FieldNeedQuotes = false else FieldNeedQuotes = true end if end function function db_addslashes(str) db_addslashes = replace(str,"'","''") end function function db_datequotes(val) db_datequotes = "#" & val & "#" end function function db_stripslashesbinary(str) '// try to remove ole header for BMP pictures pos = instrb(str,unicode2bytes(".Picture")) if pos=0 or pos>300 then db_stripslashesbinary = str exit function end if pos1=instrb(pos,str,unicode2bytes("BM")) if pos1=0 or pos1>300 then db_stripslashesbinary = str exit function end if db_stripslashesbinary = midb(str,pos1) end function function db_fieldtype(lhandle,fname) Dim i for i=0 to db_numfields(lhandle)-1 if db_fieldname(lhandle,i)=fname then ttype=db_fieldtypen(lhandle,i) db_fieldtype = ttype exit function end if next db_fieldtype = "" end function function db_numfields(lhandle) db_numfields = lhandle.Fields.Count end function function db_fieldname(lhandle,fnumber) db_fieldname = lhandle.Fields(fnumber).Name end function function db_fieldtypen(lhandle,fnumber) db_fieldtypen = lhandle.Fields(fnumber).Type end function function date2str(val) if isnull(val) then date2str="" exit function end if if isdate(val) then date2str = CStr(year(val)) & "-" & CStr(month(val)) & "-" & CStr(day(val)) & _ " " & CStr(hour(val)) & ":" & CStr(minute(val)) & ":" & CStr(second(val)) exit function end if date2str="" end function %> <% strTableName="RasBaalbeck" strOriginalTableName="RasBaalbeck" gPageSize=20 gstrOrderBy="" if len(gstrOrderBy)>0 and lcase(mid(gstrOrderBy,1,8))<>"order by" then gstrOrderBy="order by " & gstrOrderBy gstrSQL = "select [Key], [Religion Liste], [Sexe], [Famille], [Nom], [Pere], [Record] From [RasBaalbeck]" '// thumbnails Set thumbnail_fields = CreateObject("Scripting.Dictionary") Set thumbnail_prefixes = CreateObject("Scripting.Dictionary") thumbnail_fields.Add 0,"Field1" thumbnail_fields.Add 1,"Field2" '// field names are case-sensitive! dim thumbnail_prefixes thumbnail_prefixes.Add "Field1","t1_" thumbnail_prefixes.Add "Field2","t2_" thumbnail_maxsize = 150 ColumnsCount = 1 %> <% Set tdata = CreateObject("Scripting.Dictionary") tdata.Add ".NumberOfChars",80 tdata.Add ".ShortName","RasBaalbeck" tdata.Add ".OwnerID","" ' Key set fdata = CreateObject("Scripting.Dictionary") fdata.Add "FieldType", 3 fdata.Add "EditFormat", "Text field" fdata.Add "ViewFormat", "" fdata.Add "GoodName", "Key" fdata.Add "FullName", "[RasBaalbeck].[Key]" fdata.Add "IsRequired",true fdata.Add "Index", 1 fdata.Add "EditParams","" fdata.Add "FieldPermissions",true tdata.Add "Key",fdata ' Religion Liste set fdata = CreateObject("Scripting.Dictionary") fdata.Add "FieldType", 200 fdata.Add "EditFormat", "Text field" fdata.Add "ViewFormat", "" fdata.Add "GoodName", "Religion_Liste" fdata.Add "FullName", "[RasBaalbeck].[Religion Liste]" fdata.Add "Index", 2 fdata.Add "EditParams","" fdata("EditParams") = fdata("EditParams") & " maxlength=255" fdata.Add "FieldPermissions",true tdata.Add "Religion Liste",fdata ' Sexe set fdata = CreateObject("Scripting.Dictionary") fdata.Add "FieldType", 200 fdata.Add "EditFormat", "Text field" fdata.Add "ViewFormat", "" fdata.Add "GoodName", "Sexe" fdata.Add "FullName", "[RasBaalbeck].[Sexe]" fdata.Add "Index", 3 fdata.Add "EditParams","" fdata("EditParams") = fdata("EditParams") & " maxlength=255" fdata.Add "FieldPermissions",true tdata.Add "Sexe",fdata ' Famille set fdata = CreateObject("Scripting.Dictionary") fdata.Add "FieldType", 200 fdata.Add "EditFormat", "Text field" fdata.Add "ViewFormat", "" fdata.Add "GoodName", "Famille" fdata.Add "FullName", "[RasBaalbeck].[Famille]" fdata.Add "Index", 4 fdata.Add "EditParams","" fdata("EditParams") = fdata("EditParams") & " maxlength=255" fdata.Add "FieldPermissions",true tdata.Add "Famille",fdata ' Nom set fdata = CreateObject("Scripting.Dictionary") fdata.Add "FieldType", 200 fdata.Add "EditFormat", "Text field" fdata.Add "ViewFormat", "" fdata.Add "GoodName", "Nom" fdata.Add "FullName", "[RasBaalbeck].[Nom]" fdata.Add "Index", 5 fdata.Add "EditParams","" fdata("EditParams") = fdata("EditParams") & " maxlength=255" fdata.Add "FieldPermissions",true tdata.Add "Nom",fdata ' Pere set fdata = CreateObject("Scripting.Dictionary") fdata.Add "FieldType", 200 fdata.Add "EditFormat", "Text field" fdata.Add "ViewFormat", "" fdata.Add "GoodName", "Pere" fdata.Add "FullName", "[RasBaalbeck].[Pere]" fdata.Add "Index", 6 fdata.Add "EditParams","" fdata("EditParams") = fdata("EditParams") & " maxlength=255" fdata.Add "FieldPermissions",true tdata.Add "Pere",fdata ' Record set fdata = CreateObject("Scripting.Dictionary") fdata.Add "FieldType", 2 fdata.Add "EditFormat", "Text field" fdata.Add "ViewFormat", "" fdata.Add "GoodName", "Record" fdata.Add "FullName", "[RasBaalbeck].[Record]" fdata.Add "Index", 7 fdata.Add "EditParams","" fdata.Add "FieldPermissions",true tdata.Add "Record",fdata tables_data.Add "RasBaalbeck", tdata %> <% %> <% %> <% function process_tag(str) Dim i ' remove {} str=mid(str,2,len(str)-2) str=trim(str) process_tag="" fore="" if len(str)=0 then exit function if mid(str,1,1)="$" then if instr(1,str,".")=0 then process_tag = "response.write smarty(""" & mid(str,2) & """)" else item="" p=instr(1,str,".") item=mid(str,p+1) process_tag = "response.write smarty(""" & session("fore") & """)(dd)(""" & item & """)" end if elseif mid(str,1,2)="if" then expr=trim(mid(str,3)) expr=mid(expr,2) var=expr for i=1 to len(expr) c = asc(mid(expr,i,1)) if not ( c>=asc("a") and c<=asc("z") or c>=asc("0") and c<=asc("9") or c>=asc("A") and c<=asc("Z") or c=asc("_") or c=asc(".")) then var=left(expr,i-1) exit for end if next oper="" if len(expr)>len(var) then oper=mid(expr,len(var)+1) oper=replace(oper,"!=","<>") oper=replace(oper,"==","=") end if p=instr(1,var,".") if p>0 then item=mid(var,p+1) var="smarty(""" & session("fore") & """)(dd)(""" & item & """)" else var="smarty(""" & var & """)" end if process_tag=" if " & var & oper & " then " elseif mid(str,1,3)="/if" then process_tag="end if" elseif mid(str,1,7)="foreach" then p1=instr(1,str,"$") p2=instr(p1,str," ") session("fore")=mid(str,p1+1,p2-p1-1) process_tag="for each dd in smarty(""" & session("fore") & """)" elseif mid(str,1,8)="/foreach" then dd=0 process_tag="next" elseif mid(str,1,17)="include_if_exists" then p=instr(1,str,"file=") if p>0 then process_tag= "set fs=Server.CreateObject(""Scripting.FileSystemObject"") : if fs.FileExists(Server.Mappath(""" & mid(str,p+6,len(str)-p-6) & """))=true then Server.Execute(""" & mid(str,p+6,len(str)-p-6) & """)" end if elseif mid(str,1,7)="include" then p=instr(1,str,"file=") if p>0 then smart_smarty_display(smarty(mid(str,p+7,len(str)-p-7))) end if elseif mid(str,1,18)="build_edit_control" then str2=mid(str,20) str2=replace(str2,"field=",vbcrlf & "bec_field=") str2=replace(str2,"mode=",vbcrlf & "bec_mode=") str2=replace(str2,"second=",vbcrlf & "bec_second=") str2=replace(str2,"value=",vbcrlf & "bec_value=") str2 = "bec_second=false" & vbcrlf & str2 & vbcrlf p1=instr(1,str2,"$") do while p1>0 p2=instr(p1,str2,vbcrlf) str2 = left(str2,p1-1) & "smarty.item(""" & trim(mid(str2,p1+1,p2-p1-1)) & """)" & mid(str2,p2) p1=instr(1,str2,"$") loop process_tag = str2 & "smarty_function_build_edit_control()" elseif mid(str,1,13)="mlang_message" then p=instr(1,str,"tag=") if p>0 then process_tag="smarty_function_mlang_message(" & mid(str,p+4) & ")" end if elseif mid(str,1,7)="doevent" then p=instr(1,str,"name=") if p>0 then process_tag="DoEvent ""Call " & mid(str,p+6) & "" end if end if end function ' creates temporary file, returns filename function process_file(filename) Dim FSO set FSO = server.createObject("Scripting.FileSystemObject") Dim Filepath Filepath = Server.MapPath("templates\" & Filename) Dim file Set file=FSO.GetFile(Filepath) Dim TextStream Set TextStream = file.OpenAsTextStream(1, 0) ' create output string Dim res res="" ' Read the file line by line Do While Not TextStream.AtEndOfStream Dim Line Line = TextStream.readline ' Process SMARTY tags dim pos,opos pos=1 opos=1 do pos=InStr(opos,Line,"{") if pos>0 then if pos>opos then _ res=res & "response.write """ & replace(Mid(Line,opos,pos-opos),"""","""""") & """" & vbcrlf opos=pos pos=InStr(opos,Line,"}") if pos=0 then res=res & "response.write """ & replace(Mid(Line,opos),"""","""""") & """ & vbcrlf" & vbcrlf exit do end if res=res & process_tag(Mid(Line,opos,pos-opos+1)) & vbcrlf opos=pos+1 else res=res & "response.write """ & replace(Mid(Line,opos),"""","""""") & """ & vbcrlf" & vbcrlf exit do end if loop Loop set FSO=nothing process_file=res end function function smarty_function_build_edit_control() dim mode dim fformat if bec_mode="edit" then mode=MODE_EDIT else if bec_mode="add" then mode=MODE_ADD else mode=MODE_SEARCH end if end if fformat=GetEditFormat(bec_field,"") if (mode=MODE_EDIT or mode=MODE_ADD) and fformat=EDIT_FORMAT_READONLY then response.Write readonlyfields(bec_field) end if if mode=MODE_SEARCH then fformat=editformats(bec_field) end if BuildEditControl bec_field,CStr(dbvalue(bec_value)),fformat,mode,bec_second end function function smarty_function_mlang_message(tag) response.Write " " & mlang_message(tag) response.Flush smarty_function_mlang_message = my_htmlspecialchars(mlang_message(tag)) end function sub smarty_display(filename) smart_smarty_display(filename) set smarty=nothing end sub sub smart_smarty_display(filename) dim res res = process_file(filename) ' response.write res execute res end sub Set smarty = CreateObject("Scripting.Dictionary") dd=0 Session("fore")="rowinfo" %> <% on error resume next dbConnection="" db_connect() call ReportError Set rs = server.CreateObject("ADODB.Recordset") Set rss = server.CreateObject("ADODB.Recordset") ' process reqest data, fill session variables if (Request.Form="" and Request.QueryString="") then For Each key in Session.Contents if left(key, len(strTableName)+1 ) = strTableName & "_" and _ InStr(Mid(key, len(strTableName)+2), "_" )<1 then Session.Contents.Remove(key) end if Next set strTableName_asearchnot = CreateObject("Scripting.Dictionary") set strTableName_asearchopt = CreateObject("Scripting.Dictionary") set strTableName_asearchfor = CreateObject("Scripting.Dictionary") set strTableName_asearchfortype = CreateObject("Scripting.Dictionary") set strTableName_asearchfor2 = CreateObject("Scripting.Dictionary") set session(strTableName & "_asearchnot")= strTableName_asearchnot set session(strTableName & "_asearchopt") = strTableName_asearchopt set session(strTableName & "_asearchfor") = strTableName_asearchfor set session(strTableName & "_asearchfor2") = strTableName_asearchfor2 set session(strTableName & "_asearchfortype") = strTableName_asearchfortype end if if REQUEST("a")="showall" then SESSION(strTableName & "_search")=0 elseif REQUEST("a")="search" then SESSION(strTableName & "_searchfield")=postvalue("SearchField") SESSION(strTableName & "_searchoption")=postvalue("SearchOption") SESSION(strTableName & "_searchfor")=postvalue("SearchFor") if postvalue("SearchFor")<>"" or postvalue("SearchOption")="Empty" then SESSION(strTableName & "_search")=1 else SESSION(strTableName & "_search")=0 end if SESSION(strTableName & "_pagenumber")=1 elseif REQUEST("a")="advsearch" then set strTableName_asearchnot = CreateObject("Scripting.Dictionary") set strTableName_asearchopt = CreateObject("Scripting.Dictionary") set strTableName_asearchfor = CreateObject("Scripting.Dictionary") set strTableName_asearchfor2 = CreateObject("Scripting.Dictionary") set strTableName_asearchfortype = CreateObject("Scripting.Dictionary") tosearch=0 asearchfield = postvalue("asearchfield[]") if not isarray(asearchfield) then dim t t=asearchfield redim asearchfield(1) asearchfield(0)=t end if SESSION(strTableName & "_asearchtype") = postvalue("type") if SESSION(strTableName & "_asearchtype")="" then SESSION(strTableName & "_asearchtype")="and" for field=0 to ubound(asearchfield) gfield=asearchfield(field) asopt=postvalue("asearchopt_" & GoodFieldName(asearchfield(field))) value1=postvalue("value_" & GoodFieldName(asearchfield(field))) if value1="" then value1=postvalue("value_" & GoodFieldName(asearchfield(field)) & "[]") ttype=postvalue("type_" & GoodFieldName(asearchfield(field))) value2=postvalue("value1_" & GoodFieldName(asearchfield(field))) if value2="" then value2=postvalue("value_1" & GoodFieldName(asearchfield(field)) & "[]") nnot=postvalue("not_" & GoodFieldName(asearchfield(field))) if not SafeIsEmpty(value1) or asopt="Empty" then tosearch=1 strTableName_asearchopt.Add gfield,asopt if not isArray(value1) then strTableName_asearchfor.Add gfield,value1 else strTableName_asearchfor.Add gfield,combinevalues(value1) end if strTableName_asearchfortype.Add gfield,ttype if not SafeIsEmpty(value2) then strTableName_asearchfor2.Add gfield,value2 strTableName_asearchnot.Add gfield,nnot end if next set SESSION(strTableName & "_asearchnot")= strTableName_asearchnot set SESSION(strTableName & "_asearchfortype")= strTableName_asearchfortype set SESSION(strTableName & "_asearchopt") = strTableName_asearchopt set SESSION(strTableName & "_asearchfor") = strTableName_asearchfor set SESSION(strTableName & "_asearchfor2") = strTableName_asearchfor2 if tosearch<>0 then SESSION(strTableName & "_search")=2 else SESSION(strTableName & "_search")=0 end if SESSION(strTableName & "_pagenumber")=1 end if ' process masterkey value dim mastertable mastertable=postvalue("mastertable") if mastertable<>"" then SESSION(strTableName & "_mastertable")=mastertable ' copy keys to session i=1 while REQUEST("masterkey" & i)<>"" SESSION(strTableName & "_masterkey" & i)=REQUEST("masterkey" & i) i=i+1 wend ' reset search and page number SESSION(strTableName & "_search")=0 SESSION(strTableName & "_pagenumber")=1 else mastertable=SESSION(strTableName & "_mastertable") end if smarty.Add "mastertable",mastertable smarty.Add "mastertable_short",GetTableURL(mastertable) if REQUEST("orderby")<> "" then SESSION(strTableName & "_orderby")=REQUEST("orderby") if REQUEST("pagesize")<>"" then SESSION(strTableName & "_pagesize")=REQUEST("pagesize") SESSION(strTableName & "_pagenumber")=1 end if if REQUEST("goto")<>"" then SESSION(strTableName & "_pagenumber")=REQUEST("goto") ' process reqest data - end smarty.Add "includes","" ' process session variables ' order by strOrderBy="" order_ind=-1 smarty.Add "order_dir_Key","a" smarty.Add "order_dir_Religion_Liste","a" smarty.Add "order_dir_Sexe","a" smarty.Add "order_dir_Famille","a" smarty.Add "order_dir_Nom","a" smarty.Add "order_dir_Pere","a" smarty.Add "order_dir_Record","a" if SESSION(strTableName & "_orderby")<> "" then order_field=mid(SESSION(strTableName & "_orderby"),2) order_dir=mid(SESSION(strTableName & "_orderby"),1,1) order_ind=GetFieldIndex(order_field,"") AddDict smarty,"order_dir_Key","a" if order_field="Key" then if order_dir="a" then AddDict smarty,"order_dir_Key","d" img="up" else img="down" end if AddDict smarty,"order_image_Key","" end if AddDict smarty,"order_dir_Religion_Liste","a" if order_field="Religion Liste" then if order_dir="a" then AddDict smarty,"order_dir_Religion_Liste","d" img="up" else img="down" end if AddDict smarty,"order_image_Religion_Liste","" end if AddDict smarty,"order_dir_Sexe","a" if order_field="Sexe" then if order_dir="a" then AddDict smarty,"order_dir_Sexe","d" img="up" else img="down" end if AddDict smarty,"order_image_Sexe","" end if AddDict smarty,"order_dir_Famille","a" if order_field="Famille" then if order_dir="a" then AddDict smarty,"order_dir_Famille","d" img="up" else img="down" end if AddDict smarty,"order_image_Famille","" end if AddDict smarty,"order_dir_Nom","a" if order_field="Nom" then if order_dir="a" then AddDict smarty,"order_dir_Nom","d" img="up" else img="down" end if AddDict smarty,"order_image_Nom","" end if AddDict smarty,"order_dir_Pere","a" if order_field="Pere" then if order_dir="a" then AddDict smarty,"order_dir_Pere","d" img="up" else img="down" end if AddDict smarty,"order_image_Pere","" end if AddDict smarty,"order_dir_Record","a" if order_field="Record" then if order_dir="a" then AddDict smarty,"order_dir_Record","d" img="up" else img="down" end if AddDict smarty,"order_image_Record","" end if if order_ind<>"" then if order_dir="a" then strOrderBy="order by " & (order_ind) & " asc" else strOrderBy="order by " & (order_ind) & " desc" end if end if end if if strOrderBy="" then strOrderBy=gstrOrderBy ' page number mypage=cint(SESSION(strTableName & "_pagenumber")) if mypage=0 then mypage=1 ' page size PageSize=cint(SESSION(strTableName & "_pagesize")) if PageSize=0 then PageSize=gPageSize s="" if PageSize=10 then s="selected" smarty.Add "rpp10_selected",s s="" if PageSize=20 then s="selected" smarty.Add "rpp20_selected",s s="" if PageSize=30 then s="selected" smarty.Add "rpp30_selected",s s="" if PageSize=50 then s="selected" smarty.Add "rpp50_selected",s s="" if PageSize=100 then s="selected" smarty.Add "rpp100_selected",s s="" if PageSize=500 then s="selected" smarty.Add "rpp500_selected",s ' delete record if request("mdelete[]").Count>0 then set keys = CreateObject("Scripting.Dictionary") for ind=1 to request("mdelete[]").Count AddDict keys,"Key",request("mdelete1[]").Item(request("mdelete[]").Item(ind)) strSQL="delete from " & AddTableWrappers(strOriginalTableName) & " where " & KeyWhere(keys,"") retval=true where = mid(strSQL,len("delete from " & AddTableWrappers(strOriginalTableName) & " where ")) DoEvent "retval = BeforeDelete(""" & replace(where,"""","""""") & """)" if retval then LogInfo(strSQL) dbConnection.Execute strSQL DoEvent "AfterDelete()" end if next DoEvent "AfterMassDelete()" end if ' make sql "select" string strSQL = gstrSQL ' add search params if SESSION(strTableName & "_search")=1 then ' regular search strSearchFor=trim(SESSION(strTableName & "_searchfor")) strSearchOption=trim(SESSION(strTableName & "_searchoption")) if SESSION(strTableName & "_searchfield")<> "" then strSearchField = SESSION(strTableName & "_searchfield") where = StrWhere(strSearchField, strSearchFor, strSearchOption, "") if where <>"" then strSQL = AddWhere(strSQL,where) else strSQL = AddWhere(strSQL,"1=0") end if else sstrWhere = "1=0" where=StrWhere("Key", strSearchFor, strSearchOption, "") if where<>"" then sstrWhere=sstrWhere & " or " & where where=StrWhere("Religion Liste", strSearchFor, strSearchOption, "") if where<>"" then sstrWhere=sstrWhere & " or " & where where=StrWhere("Sexe", strSearchFor, strSearchOption, "") if where<>"" then sstrWhere=sstrWhere & " or " & where where=StrWhere("Famille", strSearchFor, strSearchOption, "") if where<>"" then sstrWhere=sstrWhere & " or " & where where=StrWhere("Nom", strSearchFor, strSearchOption, "") if where<>"" then sstrWhere=sstrWhere & " or " & where where=StrWhere("Pere", strSearchFor, strSearchOption, "") if where<>"" then sstrWhere=sstrWhere & " or " & where where=StrWhere("Record", strSearchFor, strSearchOption, "") if where<>"" then sstrWhere=sstrWhere & " or " & where strSQL = AddWhere(strSQL,sstrWhere) end if else if SESSION(strTableName & "_search")=2 then ' advanced search set strTableName_asearchfortype = SESSION(strTableName & "_asearchfortype") set strTableName_asearchnot = SESSION(strTableName & "_asearchnot") set strTableName_asearchopt = SESSION(strTableName & "_asearchopt") set strTableName_asearchfor = SESSION(strTableName & "_asearchfor") set strTableName_asearchfor2 = SESSION(strTableName & "_asearchfor2") sWhere="" for each f in strTableName_asearchfor strSearchFor=trim(strTableName_asearchfor.item(f)) strSearchFor2="" ttype=strTableName_asearchfortype.item(f) for each i in strTableName_asearchfor2 if f=i then strSearchFor2=trim(strTableName_asearchfor2.item(i)) next if strSearchFor<>"" or true then if sWhere="" then if session(strTableName & "_asearchtype")="and" then sWhere="1=1" else sWhere="1=0" end if end if snot=strTableName_asearchnot.item(f) strSearchOption=trim(strTableName_asearchopt.Item(f)) where="" where=StrWhereAdv(f, strSearchFor, strSearchOption, strSearchFor2,ttype) if where<>"" then if snot<>"" then where="not (" & where & ")" if SESSION(strTableName & "_asearchtype")="and" then sWhere=sWhere & " and " & where else sWhere=sWhere & " or " & where end if end if end if next strSQL = AddWhere(strSQL,sWhere) end if end if if mastertable="RasBaalbeck" then where ="" where=where & GetFullFieldName("Key","") & "=" & make_db_value("Key",SESSION(strTableName & "_masterkey1"),"","") strSQL = AddWhere(strSQL,where) end if ' order by strSQL=strSQL & " " & trim(strOrderBy) ' save SQL for use in "Export" and "Printer-friendly" pages SESSION(strTableName & "_sql") = strSQL LogInfo(strSQL) ' select and display records if CheckSecurity(SESSION("OwnerID"),"Search") then ' Pagination: numrows=GetRowCount(strSQL) if numrows=0 then smarty.Add "rowsfound",false smarty.Add "message", "No records found" else smarty.Add "rowsfound",true smarty.Add "records_found",numrows maxRecords = numrows maxpages=int(maxRecords/PageSize) if maxRecords mod PageSize <> 0 then maxpages=maxpages+1 if mypage > maxpages then mypage = maxpages if mypage<1 then mypage=1 maxrecs=PageSize smarty.Add "page",mypage smarty.Add "maxpages",maxpages ' write pagination smarty.Add "pagination","" strSQL = AddTop(strSQL, mypage*PageSize) end if rs.Open strSQL, dbConnection,1,2 call ReportError if not rs.EOF then rs.Move(PageSize*(mypage-1)) ' hide colunm headers if needed recordsonpage=numrows-(mypage-1)*PageSize if recordsonpage>PageSize then _ recordsonpage=PageSize if recordsonpage>=1 then smarty.Add "column1show",true else smarty.Add "column1show",false end if Set totals = CreateObject("Scripting.Dictionary") totals.Add "Religion Liste",0 Set rowinfo = CreateObject("Scripting.Dictionary") shade=false recno=1 editlink="" copylink="" ri=0 Set fso = CreateObject("Scripting.FileSystemObject") while not rs.eof and recno<=PageSize Set row = CreateObject("Scripting.Dictionary") if not shade then row.Add "shadeclass","class=""shade""" row.Add "shadeclassname","shade" shade=true else row.Add "shadeclass","" row.Add "shadeclassname","" shade=false end if col=0 while not rs.EOF and recno<=PageSize and col<1 col=col+1 totals("Religion Liste") = totals("Religion Liste")+CSmartDbl(rs("Religion Liste")) ' key fields row.Add col & "id1",my_htmlspecialchars(dbvalue(rs("Key"))) recno=recno+1 ' detail tables masterquery="mastertable=RasBaalbeck" masterquery=masterquery & "&masterkey1=" & SafeURLEncode(dbvalue(rs("Key"))) row.Add col & "RasBaalbeck_masterkeys",masterquery ' edit page link editlink="" editlink=editlink & "editid1=" & my_htmlspecialchars(SafeURLEncode(dbvalue(rs("Key")))) row.Add col & "editlink",editlink copylink="" copylink=copylink & "copyid1=" & my_htmlspecialchars(SafeURLEncode(dbvalue(rs("Key")))) row.Add col & "copylink",copylink keylink="" keylink=keylink & "&key1=" & my_htmlspecialchars(SafeURLEncode(dbvalue(rs("Key")))) ' Key - value="" value = ProcessLargeText(GetData(rs,"Key", ""),"field=Key" & keylink,"",MODE_LIST) row.Add col & "Key_value",value ' Nom - value="" value = ProcessLargeText(GetData(rs,"Nom", ""),"field=Nom" & keylink,"",MODE_LIST) row.Add col & "Nom_value",value ' Pere - value="" value = ProcessLargeText(GetData(rs,"Pere", ""),"field=Pere" & keylink,"",MODE_LIST) row.Add col & "Pere_value",value ' Famille - value="" value = ProcessLargeText(GetData(rs,"Famille", ""),"field=Famille" & keylink,"",MODE_LIST) row.Add col & "Famille_value",value ' Sexe - value="" value = ProcessLargeText(GetData(rs,"Sexe", ""),"field=Sexe" & keylink,"",MODE_LIST) row.Add col & "Sexe_value",value ' Record - value="" value = ProcessLargeText(GetData(rs,"Record", ""),"field=Record" & keylink,"",MODE_LIST) row.Add col & "Record_value",value ' Religion Liste - value="" value = ProcessLargeText(GetData(rs,"Religion Liste", ""),"field=Religion+Liste" & keylink,"",MODE_LIST) row.Add col & "Religion_Liste_value",value row.Add col & "show",true rs.MoveNext wend rowinfo.add ri,row ri=ri+1 wend smarty.Add "rowinfo",rowinfo rs.Close end if ' show totals smarty.Add "showtotal_Religion_Liste", GetTotals(totals("Religion Liste"),"COUNT",recno-1,"") if CheckSecurity(SESSION("OwnerID"),"Search") then if SESSION(strTableName & "_search")=1 then onload = "onLoad=""if(document.getElementById('SearchFor')) document.getElementById('ctlSearchFor').focus();""" smarty.Add "onload",onload ' fill in search variables ' // field selection if SESSION(strTableName& "_searchfield")="Key" then smarty.Add "search_Key","selected" if SESSION(strTableName& "_searchfield")="Religion Liste" then smarty.Add "search_Religion_Liste","selected" if SESSION(strTableName& "_searchfield")="Sexe" then smarty.Add "search_Sexe","selected" if SESSION(strTableName& "_searchfield")="Famille" then smarty.Add "search_Famille","selected" if SESSION(strTableName& "_searchfield")="Nom" then smarty.Add "search_Nom","selected" if SESSION(strTableName& "_searchfield")="Pere" then smarty.Add "search_Pere","selected" if SESSION(strTableName& "_searchfield")="Record" then smarty.Add "search_Record","selected" ' // search type selection if SESSION(strTableName & "_searchoption")="Contains" then smarty.Add "search_contains_option_selected","selected" if SESSION(strTableName & "_searchoption")="Equals" then smarty.Add "search_equals_option_selected","selected" if SESSION(strTableName & "_searchoption")="Starts with ..." then smarty.Add "search_startswith_option_selected","selected" if SESSION(strTableName & "_searchoption")="More than ..." then smarty.Add "search_more_option_selected","selected" if SESSION(strTableName & "_searchoption")="Less than ..." then smarty.Add "search_less_option_selected","selected" if SESSION(strTableName & "_searchoption")="Equal or more than ..." then smarty.Add "search_equalormore_option_selected","selected" if SESSION(strTableName & "_searchoption")="Equal or less than ..." then smarty.Add "search_equalorless_option_selected","selected" if SESSION(strTableName & "_searchoption")="Empty" then smarty.Add "search_empty_option_selected","selected" smarty.Add "search_searchfor","value=""" & my_htmlspecialchars(SESSION(strTableName & "_searchfor")) & """" end if end if smarty.Add "displayheader","" strSQL=SESSION(strTableName & "_sql") smarty_display("RasBaalbeck_list.htm") %>