حتى اكون موضوعى فى عرض مشكلتى
انا استخدم ويندوز سفن 64 بت
شغلت iis
عملت قاعدة mdb
اشتغلت ببرنامج asprunner
كله تمام ما عدا
صفحة اللوجن عند عمل تسجيل لعضو جديد يقوم بالتسجيل فعلا عند الضغط على submit ولكن المفروض ينقل بعد كدة لصفحة اللوجن تانى
لكن يظهر هذا الكود مش فاهم ليه
Microsoft VBScript runtime error '800a000d' Type mismatch: 'keys' /tawg/include/aspfunctions.asp, line 1740
والمفروض انا عامل ارسال رسالة للايميل الذى قام بالتسجبل بس مش عارف لية مش بيرسل مع ان جميع الاعدادات مظبوطة تبع الجىميل ارجو الافادة من اصحاب الخبرات
لبحث الخطأ بطريقة اكثر الكود الخطأ فى هذا السطر
keys(tkeys(k)) = dbvalue(rs(tkeys(k)))
ودة الكود الكامل
<!--#include file="json.asp"--><%sortgroup=0sortorder="a"output_buffer=""ob_enabled=falseset included_files = CreateDictionary()errorhappened = falsesub sendmail(email, subject, message) dim tmpDict set tmpDict = CreateObject("Scripting.Dictionary") tmpDict("to")=email tmpDict("subject")=subject tmpDict("body")=message runner_mail tmpDictend sub' ASPRunnerPro mail function.' "params" is a Scripting.Dictionary object with input parameters.' The following parameters are supported:' "from" - Sender email address. If none specified an email address from the wizard will be used.' "to" - Receiver email address.' "body" - Plain text message body.' "htmlbody" - Html message body (do not use 'body' parameter in this case).' Setting character set is not supported.'' Returns a Scripting.Dictionary object with the following data:' "mailed" - indicates wheter mail sent or not' "source" - error source (a COM object usually)' "number" - error number' "description" - error description' "message" - formatted message with information aboveFunction runner_mail(params) On Error Resume Next Dim email_from, email_to, email_body, email_htmlbody, email_charset, email_ishtml, email_cc, email_bcc, csmtpserver, csmtpport, csmtppassword, csmtpuser csmtpserver = "localhost" csmtpport = 25 csmtppassword = "" csmtpuser = "" If VarType(params("from")) = vbEmpty or VarType(params("from")) = vbNull Then email_from = "" Else email_from = params("from") End If If VarType(params("to")) = vbEmpty or VarType(params("to")) = vbNull Then strMessage = "Email address is empty. Cannot send email." Exit Function Else email_to = params("to") End If email_cc="" If VarType(params("cc")) <> vbEmpty and VarType(params("cc")) <> vbNull Then email_cc = params("cc") End If email_bcc="" If VarType(params("bcc")) <> vbEmpty and VarType(params("bcc")) <> vbNull Then email_bcc = params("bcc") End If email_ishtml = false email_subject = params("subject") email_body = "" If VarType(params("body")) = vbEmpty or VarType(params("body")) = vbNull Then If Not (VarType(params("htmlbody")) = vbEmpty or VarType(params("htmlbody")) = vbNull) Then email_body = params("htmlbody") End If email_ishtml = true Else email_body = params("body") End If 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 Err.Clear dim myMail' Roadmap for CDO library' http://msdn.microsoft.com/en-us/library/ms978698.aspx Set myMail=CreateObject("CDO.Message") If err.Number=0 Then myMail.Subject = email_subject myMail.From = email_from myMail.To = email_to if email_cc<>"" then _ myMail.Cc = email_cc if email_bcc<>"" then _ myMail.Bcc = email_bcc If email_ishtml Then myMail.HTMLBody = email_body Else myMail.TextBody = email_body End If 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 if csmtpuser<>"" then _ myMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 myMail.Configuration.Fields.Update myMail.Send Set myMail = Nothing Else Set myMail = Server.CreateObject("CDONTS.NewMail") myMail.From = email_from myMail.To = email_to if email_cc<>"" then _ myMail.Cc = email_cc if email_bcc<>"" then _ myMail.Bcc = email_bcc myMail.Subject = email_subject myMail.Body = email_body If email_ishtml Then myMail.BodyFormat = 0 Else myMail.BodyFormat = 1 End If myMail.Send Set myMail = Nothing End If dim result set result = CreateObject("Scripting.Dictionary") if Err.Number<>0 then result("mailed") = False result("source") = Err.Source result("number") = Err.Number result("description") = Err.Description result("message") = "Error happened sending email to " & email_to & "<br>" & Err.Source & "<br>" & Err.Number & "<br>" & Err.Description Set runner_mail = result Err.Clear Else result("mailed") = True end if Set runner_mail = result on error goto 0End Function'//// TEST CODE'Dim csmtpserver, csmtpport, csmtppassword, csmtpuser'csmtpserver = "localhost"'csmtpport = 25'csmtppassword = "123"'csmtpuser = "user"'Dim dicTest'Set dicTest = CreateObject("Scripting.Dictionary")'dicTest.Add "from", "user@test.com"'dicTest.Add "to", "to@test.com"'dicTest.Add "htmlbody", "<html><body>??? ?????</body></html>"'dicTest.Add "subject", "Hello"'runner_mail(dicTest)'///////////////////////////////////////////////////////////////////////////////Sub printfile(filename) if instr(filename,"\")=0 then filename=getabspath(filename) end if Dim objStream set objStream = Server.CreateObject("ADODB.Stream") objStream.Type = 1 objStream.Open objStream.LoadFromFile filename Response.BinaryWrite objStream.Read set objStream = NothingEnd Sub'///////////////////////////////////////////////////////////////////////////////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.Binaryend functionsub SafeCreateObject(name,object) on error resume next set object = server.CreateObject(name) if err.Number<>0 then object=null end if on error goto 0end sub'///////////////////////////////////////////////////////////////////////////////Function myfile_get_contents(filename,p) myfile_get_contents="" dim stream set stream=Server.CreateObject("ADODB.Stream") stream.CharSet=cCharset stream.type=2 on error resume next stream.Open if err.Number<>0 then err.Clear set stream=nothing on error goto 0 exit function end if on error goto 0 stream.LoadFromFile Filename myfile_get_contents = stream.ReadText stream.Close set stream=nothingEnd FunctionSub myfile_put_contents(filename, contents) Const adTypeBinary = 1 Const adSaveCreateOverWrite = 2 'Create Stream object Dim BinaryStream Set BinaryStream = CreateObject("ADODB.Stream") 'Specify stream type - we want To save binary data. BinaryStream.Type = adTypeBinary 'Open the stream And write binary data To the object BinaryStream.Open BinaryStream.Write ByteArray 'Save binary data To disk BinaryStream.SaveToFile FileName, adSaveCreateOverWrite Set BinaryStream = NothingEnd Sub'///////////////////////////////////////////////////////////////////////////////Function myfile_exists(filename) Set fso = CreateObject("Scripting.FileSystemObject") myfile_exists = fso.FileExists(server.MapPath(filename)) set fso = NothingEnd Function'///////////////////////////////////////////////////////////////////////////////Sub myunlink(strFileName) Set fso = CreateObject("Scripting.FileSystemObject") if fso.FileExists(server.MapPath(strFileName)) then fso.DeleteFile(server.MapPath(strFileName)) end if set fso = NothingEnd Sub'///////////////////////////////////////////////////////////////////////////////Function mysprintf(format, params) Dim c, informat, formatchar, intzerobegin, intdecimals, formatnum, out informat = false intzerobegin = false intdecimals = 0 formatnum = 0 out = "" For i = 1 To Len(format) c = Mid(format, i, 1) Select Case c Case "%" If informat Then ' error Response.Write "Invalid character in format" Response.End Else informat = true End If Case "s" If informat Then out = out & params(formatnum) informat = false intzerobegin = false intdecimals = 0 formatnum = formatnum + 1 Else out = out & "s" End If Case "d" If informat Then If intdecimals > 0 And Not intzerobegin Then ' error ' format "%4d" (for example) is wrong ' (should be "%04d") Response.Write "Wrong decimal format" Response.End End If Dim s, ndot s = CStr(params(formatnum)) ndot = InStr(1, s, ".") If ndot > 0 Then s = Mid(s, 1, ndot - 1) End If If intdecimals > 0 And Len(s) < intdecimals Then s = String(intdecimals - Len(s), "0") & s End If out = out & s informat = false intzerobegin = false intdecimals = 0 formatnum = formatnum + 1 Else out = out & "d" End If Case Else If informat Then If c = "0" Then intzerobegin = true ElseIf c = "1" Or c = "2" Or c = "3" Or c = "4" Or c = "5" _ Or c = "6" Or c = "7" Or c = "8" Or c = "9" Then intdecimals = CLng(c) Else ' error Response.Write "Invalid character in format" Response.End End If Else out = out & c End If End Select Next mysprintf = outEnd Function'//// TEST CODE'Response.Write mysprintf("%d", Array(1)) & "<br/>"'Response.Write mysprintf("%05d", Array(1)) & "<br/>"'Response.Write mysprintf("%04d-%02d-%02d %02d:%02d:%02d", Array(2000, 2, 1, 13, 11, 59)) & "<br/>"'Response.Write mysprintf("s%sss", Array("Hello")) & "<br/>"'Response.Write mysprintf("s-%s..%s-s", Array("Hello", "again")) & "<br/>"'Response.Write mysprintf("s-%%s..%s-s", Array("Hello", "again")) & "<br/>"'Response.Write mysprintf("%5d", Array(1)) & "<br/>"function GetRequestValue(byref arr,byval key) if typename(arr)="IRequest" then doAssignment GetRequestValue,GetRequestValue(request.QueryString,key) if vartype(GetRequestValue)=vbEmpty then doAssignment GetRequestValue,GetRequestValue(RequestForm(),key) end if exit function end if if vartype(arr(key))=vbEmpty then if vartype(arr(key & "[]"))<>vbEmpty then doAssignment GetRequestValue,arr(key & "[]") exit function end if end if GetRequestValue=arr(key)end functionfunction RequestForm() if left(request.ServerVariables("CONTENT_TYPE"),9)="multipart" then if formParsed<>1 then if ParseMultiPartForm()=true then _ formParsed=1 end if end if if formParsed<>1 then set RequestForm=request.form else set RequestForm=myRequest end ifend functionfunction GetCollectionBounds(byref arr, byref first, byref last) if IsDictionary(arr) then first=0 last=arr.count-1 exit function end if if IsArray(arr) then first=lbound(arr) last=ubound(arr) exit function end if if typename(arr)="IRequestDictionary" or typename(arr)="IStringList" then first=1 last=arr.count exit function end if if typename(arr)="ISessionObject" then first=1 last=arr.contents.count exit function end ifend functionfunction GetCollectionKey(byref arr,byval index) if IsDictionary(arr) then GetCollectionKey = arr.keys()(index) exit function end if if typename(arr)="IRequestDictionary" then GetCollectionKey = arr.key(index) exit function end if if typename(arr)="IStringList" then GetCollectionKey=index exit function end if if typename(arr)="ISessionObject" then GetCollectionKey = arr.contents.key(index) exit function end ifend functionFunction Unicode2Bytes(str) dim ind For ind = 1 To len(str) Unicode2Bytes = Unicode2Bytes& ChrB(Asc(Mid(str, ind, 1))) Next End FunctionFunction 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 Functionfunction bValue(ByVal val) if VarType(val)=vbEmpty or VarType(val)=vbNull then bValue=false elseif VarType(val)=vbBoolean then bValue=val elseif VarType(val)=vbString then bValue=(Len(val)>0 and val<>"0") elseif IsNumeric(val) then bValue=CBool(val) elseif VarType(val)=vbObject then if IsDictionary(val) then if val.Count>0 then bValue=true else bValue=false end if exit function end if bValue=true else bValue=true end ifend functionfunction doAssignment(ByRef var,ByRef value) if not isobject(value) then var=value doAssignment=value elseif IsDictionary(value) then copyDictionary value,var set doAssignment=var else set var=value set doAssignment=value end ifend functionfunction doAssignmentByRef(ByRef var,ByRef value) if not isobject(value) then var=value doAssignmentByRef=value else set var=value set doAssignmentByRef=value end ifend functionfunction setArrElement(ByRef arr,ByVal key,ByRef value) if not isobject(arr) then _ set arr=CreateDictionary() dim tval doAssignment tval,value if vartype(key)=vbString then if IsNumeric(key) then key=CLng(key) end if end if if not IsObject(value) then arr(key)=tval setArrElement=tval else set arr(key)=tval setArrElement=bValue(tval) end ifend functionfunction setArrElementByRef(ByRef arr,Byval key,ByRef value) if isempty(arr) then _ set arr=CreateDictionary() if vartype(key)=vbString then if IsNumeric(key) then key=CLng(key) end if end if if not IsObject(value) then arr(key)=value setArrElementByRef=value else set arr(key)=value setArrElementByRef=bValue(value) end ifend functionfunction doClassAssignmentByRef(ByRef obj,ByVal key,ByRef value) dim str1,str2 str1="" str2="" if IsObject(value) then str1="Set " str2="Set " end if str1=str1 & "obj." & key & " = value" str2=str2 & "doClassAssignmentByRef = value" Execute str1 Execute str2end functionfunction doClassAssignment(ByRef obj,ByVal key,ByRef value) dim str1,str2,tval doAssignment tval,value str1="" str2="" if IsObject(value) then str1="Set " str2="Set " end if str1=str1 & "obj." & key & " = tval" str2=str2 & "doClassAssignment = tval" Execute str1 Execute str2end functionfunction setArrElementN_Int(ByRef arr,byref pkeys,ByRef value,byreference) dim tarr,i ensureArrayCreated arr,pkeys(0) set tarr=arr(pkeys(0)) for i=1 to pkeys.count-2 ensureArrayCreated tarr,pkeys(i) set tarr=tarr(pkeys(i)) next lastkey = pkeys(pkeys.count-1) if isEmpty(lastkey) then lastkey=asp_count(tarr) end if if byreference then setArrElementByRef tarr,lastkey,value else setArrElement tarr,lastkey,value end if doAssignmentByRef setArrElementN_Int,valueend functionfunction setArrElementByRefN(ByRef arr,byref pkeys,ByRef value) doAssignmentByRef setArrElementByRefN,setArrElementN_Int(arr,pkeys,value,true)end functionfunction setArrElementN(ByRef arr,byref pkeys,ByRef value) doAssignmentByRef setArrElementN,setArrElementN_Int(arr,pkeys,value,false)end functionfunction ensureArrayCreated(byref arr, byval key) if not IsObject(arr) then _ set arr=CreateDictionary if isobject(arr(key)) then exit function end if set arr(key) = CreateDictionary()end functionfunction postInc(ByRef var) postInc=var var=var+1end functionfunction postDec(ByRef var) postDec=var var=var-1end functionfunction preInc(ByRef var) var=var+1 preInc=varend functionfunction preDec(ByRef var) var=var-1 preDec=varend function' array function routinesfunction CreateDictionary() set CreateDictionary=Server.CreateObject("Scripting.Dictionary")end functionfunction GetCreateDictionaryString(n,numeric) dim body dim funcname if not numeric then funcname="CreateDictionary"&n else funcname="CreateArray"&n end if body = "set "&funcname&"=Server.CreateObject(""Scripting.Dictionary"")" & vbcrlf body = body & "dim counter" & vbcrlf body = body & "counter=0" & vbcrlf dim i,params for i=1 to n if i>1 then _ params= params & "," if not numeric then params = params & "name" &i & ",param" & i body = body & " if not isEmpty(name"&i&") then "&vbcrlf &_ "setArrElement "&funcname&",name"&i&",param"&i&vbcrlf &_ "else "&vbcrlf else params = params & "param" & i end if body = body & "setArrElement "&funcname&",counter,param"&i&vbcrlf &_ "counter=counter+1" & vbcrlf if not numeric then body = body & "end if"&vbcrlf end if next GetCreateDictionaryString = "function "&funcname&"("¶ms&")"&vbcrlf & body & vbcrlf & "end function"end functiondim arrsizes(6)arrsizes(0)=1arrsizes(1)=2arrsizes(2)=3arrsizes(3)=4arrsizes(4)=5arrsizes(5)=6dim dictsizes(13)dictsizes(0)=1dictsizes(1)=2dictsizes(2)=3dictsizes(3)=4dictsizes(4)=5dictsizes(5)=6dictsizes(6)=7dictsizes(7)=8dictsizes(8)=9dictsizes(9)=12dictsizes(10)=16dictsizes(11)=24dictsizes(12)=42for nCDF=0 to ubound(arrsizes) execute GetCreateDictionaryString(arrsizes(nCDF),true)nextfor nCDF=0 to ubound(dictsizes) execute GetCreateDictionaryString(dictsizes(nCDF),false)nextfunction CreateClass(classname,pcount,param1,param2,param3,param4,param5,param6,param7)dim str,i str="set CreateClass = new " & classname & vbcrlf str=str+"CreateClass.init_" & classname if pcount>0 then _ str=str & "_p" & pcount for i = 1 to pcount str=str+" param" & i if i<pcount then str=str+"," end if next execute strend functionfunction IIF(ByVal cond,ByRef expr1,ByRef expr2) if bValue(cond) then if vartype(expr1)=vbObject then set iif=expr1 else iif=expr1 end if else if vartype(expr2)=vbObject then set iif=expr2 else iif=expr2 end if end ifend functionfunction IsSet(ByRef var) if VarType(var)=vbEmpty or VarType(var)=vbNull then IsSet=false elseif VarType(var)=vbBoolean then IsSet=var end ifend functionfunction asp_stripos(str,substr,start) asp_stripos=asp_strpos(lcase(str),lcase(substr),start)end functionfunction asp_strpos(str,substr,start) dim pos if isEmpty(start) then start=0 pos=instr(start+1,str,substr) if isEmpty(pos) then asp_strpos=false exit function end if if pos=0 then asp_strpos=false exit function end if asp_strpos=pos-1end functionfunction asp_strrpos(str,substr,a) dim pos pos=instrrev(str,substr) if isEmpty(pos) then asp_strrpos=false exit function end if if pos=0 then asp_strrpos=false exit function end if asp_strrpos=pos-1end functionfunction asp_array_splice(p_arr,offset,length) if offset>=0 and length>=0 then dim tmpDict, i, l l=0 set tmpDict=CreateObject("Scripting.Dictionary") for each i in p_arr.keys if i<offset or i>=offset+length then setArrElement tmpDict,l,ArrayElement(p_arr,i) l=l+1 end if next set p_arr=tmpDict end ifend functionfunction asp_unsetElement(ByRef p_arr,ByVal p_key) if IsDictionary(p_arr) then if vartype(p_key)=vbString then if IsNumeric(p_key) then _ p_key=CLng(p_key) end if if p_arr.exists(p_key) then _ p_arr.remove p_key exit function end if if TypeName(p_arr)="ISessionObject" then Session.contents.remove p_key exit function end if if TypeName(p_arr)="IRequestDictionary" then p_arr(p_key)=empty end ifend functionfunction asp_array_key_exists(ByVal p_key,ByRef p_arr) if IsDictionary(p_arr) then if vartype(p_key)=vbString then if IsNumeric(p_key) then _ p_key=CLng(p_key) end if if p_arr.Exists(p_key) then asp_array_key_exists=true exit function else asp_array_key_exists=false exit function end if end if if TypeName(p_arr)="IRequest" then asp_array_key_exists = vartype(Request.QueryString(p_key))<>vbEmpty or vartype(RequestForm()(p_key))<>vbEmpty exit function else on error resume next asp_array_key_exists = false asp_array_key_exists = vartype(p_arr(p_key))<>vbEmpty exit function end if asp_array_key_exists=falseend functionfunction asp_array_unique(p_arr) dim tmpDict, key, nkey, flag set tmpDict=CreateObject("Scripting.Dictionary") for each key in p_arr flag=0 for each nkey in tmpDict if cstr(p_arr(key))=cstr(tmpDict(nkey)) then flag=1 end if next if flag=0 then setArrElement tmpDict,key,p_arr(key) end if next set asp_array_unique=tmpDictend functionfunction asp_is_array(p_arr) if IsObject(p_arr) then if IsDictionary(p_arr) then asp_is_array=true exit function end if if TypeName(p_arr)="IStringList" then asp_is_array=true exit function end if end if asp_is_array=falseend functionfunction asp_array_keys(p_arr, p_search) dim key, tmpDict set tmpDict=CreateObject("Scripting.Dictionary") for each key in p_arr.Keys if key=p_search or isEmpty(p_search) then tmpDict(tmpDict.Count)=key end if next set asp_array_keys=tmpDictend functionfunction asp_count(byref p_arr) if not IsObject(p_arr) then if isArray(p_arr) then asp_count=ubound(p_arr) else if not isnull(p_arr) and not IsEmpty(p_arr) then asp_count=1 else asp_count=0 end if end if else if IsDictionary(p_arr) then asp_count=p_arr.Count exit function end if dim tname tname=typename(p_arr) if tname="ISessionObject" then asp_count=p_arr.Contents.Count elseif tname="IRequestDictionary" or tname="IStringList" or tname="IRequest" then asp_count=p_arr.Count end if end ifend functionfunction asp_strlen(str) asp_strlen=len(CSmartStr(str))end functionfunction asp_substr(str,start,slen) if IsNull(str) or isEmpty(str) then asp_substr=false exit function end if dim tmpstr if isEmpty(slen) or slen>=0 then if len(str)<=start then asp_substr=false exit function end if if start>=0 then if not isEmpty(slen) and start+1+slen<=len(str) then asp_substr=mid(str,start+1,slen) else asp_substr=mid(str,start+1) end if exit function else dim tstart tstart=len(str)+start+1 if tstart<1 then tstart=1 end if if not isEmpty(slen) and slen<=abs(start) then asp_substr=mid(str,tstart,slen) else asp_substr=mid(str,tstart) end if exit function end if else slen=abs(slen) if start>=0 then tmpstr=mid(str,start+1) else start=abs(start) tmpstr=right(str,start) end if if len(tmpstr)<slen then asp_substr=false exit function end if asp_substr=left(tmpstr,len(tmpstr)-slen) exit function end ifend functionfunction asp_is_numeric(val) asp_is_numeric=isnumeric(val)end functionfunction asp_strtolower(str) asp_strtolower=LCase(str)end functionfunction asp_strtoupper(str) asp_strtoupper=UCase(str)end functionfunction asp_strrev(str) dim i, newstr for i=1 to len(str) newstr=mid(str,i,1) & newstr next asp_strrev=newstrend functionfunction asp_nl2br(str) if IsNull(str) or isEmpty(str) then asp_nl2br="" exit function end if asp_nl2br=replace(str,vbcrlf,"<br />")end function function asp_rawurlencode(str) asp_rawurlencode=SafeURLEncode(str)end function function asp_rawurldecode(str) if IsNull(str) or isEmpty(str) then asp_rawurldecode="" exit function end if str = Replace(str, "+", " ") For i = 1 To Len(str) sT = Mid(str, i, 1) If sT = "%" Then If i+2 <= Len(str) Then sR = sR & Chr(CLng("&H" & Mid(str, i+1, 2))) i = i+2 End If Else sR = sR & sT End If Next asp_rawurldecode = sR end functionfunction asp_substr_replace(str, str_replace, start, length) dim tstr if IsNull(str) or isEmpty(str) then asp_substr_replace="" exit function end if if isEmpty(length) then _ length=len(str) if len(str)=0 then asp_substr_replace=str_replace exit function end if if start>=0 and start+1>len(str) or start<0 and abs(start)>len(str) then asp_substr_replace=str exit function end if if start>=0 and length>=0 then asp_substr_replace=left(str,start) & str_replace & mid(str,start+length+1) exit function elseif start<0 and length>=0 then asp_substr_replace=mid(str,1,len(str)+start) & str_replace & mid(str,-start+length) exit function elseif start>=0 and length<0 then asp_substr_replace=left(str,start) & str_replace & right(str,abs(length)) exit function elseif start<0 and length<0 then asp_substr_replace=mid(str,1,len(str)+start) & str_replace & right(str,abs(length)) exit function end ifend functionfunction asp_str_replace(str_search,str_replace,str) dim i, val, str_val if VarType(str)<>vbObject then str=CSmartStr(str) if VarType(str_search)=vbString and VarType(str_replace)=vbString and VarType(str)=vbString then asp_str_replace=replace(str,str_search,str_replace) exit function elseif VarType(str_search)=vbString and VarType(str_replace)=vbString and VarType(str)=vbObject then for each val in str.Keys str(val)=replace(str(val),str_search,str_replace) next set asp_str_replace=str exit function elseif VarType(str_search)=vbObject and VarType(str_replace)=vbString and VarType(str)=vbString then for each val in str_search.Keys str=replace(str,str_search(val),str_replace) next asp_str_replace=str exit function elseif VarType(str_search)=vbObject and VarType(str_replace)=vbString and VarType(str)=vbObject then for each str_val in str.Keys for each val in str_search.Keys str(str_val)=replace(str(str_val),str_search(val),str_replace) next next set asp_str_replace=str exit function elseif VarType(str_search)=vbObject and VarType(str_replace)=vbObject and VarType(str)=vbString then for i=0 to str_search.Count if i<=str_replace.Count then str=replace(str,str_search.Item(i),str_replace.Item(i)) else str=replace(str,str_search.Item(i),"") end if next asp_str_replace=str exit function elseif VarType(str_search)=vbObject and VarType(str_replace)=vbObject and VarType(str)=vbObject then for each val in str.Keys for i=0 to str_search.Count if i<=str_replace.Count then val=replace(val,str_search.Item(i),str_replace.Item(i)) else val=replace(val,str_search.Item(i),"") end if next next set asp_str_replace=str exit function end ifend functionfunction asp_sizeof(p_arr) asp_sizeof=asp_count(p_arr)end functionfunction asp_dirname(str) dim p1, p2, s if instr(1,str,"/")=0 and instr(1,str,"\")=0 then asp_dirname="." else if right(str,1)="/" or right(str,1)="\" then str=left(str,len(str)-1) p1=instrrev(str,"/") p2=instrrev(str,"\") if p1=0 and p2=0 then asp_dirname=str elseif p1>p2 then str=left(str,p1-1) else str=left(str,p2-1) end if asp_dirname=str end ifend functionfunction asp_file_exists(filename) Dim fso Set fso = CreateObject("Scripting.FileSystemObject") If fso.FileExists(filename) Then asp_file_exists=true Else If fso.FolderExists(filename) Then asp_file_exists=true else asp_file_exists=false end if End If set fso = Nothingend functionfunction asp_header(str) dim p p=instr(1,str,":") if lcase(trim(left(str,p-1)))="location" then response.Redirect trim(mid(str,p+1)) elseif lcase(trim(left(str,p-1)))="content-type" then response.ContentType=trim(mid(str,p+1)) else Response.AddHeader trim(left(str,p-1)),trim(mid(str,p+1)) end ifend functionfunction explode(patt,str) set explode=asp_split(patt,str)end functionfunction asp_split(patt,str) dim arr, i set dict=CreateObject("Scripting.Dictionary") arr=split(str,patt) for i=0 to ubound(arr) setArrElement dict,i,arr(i) next set asp_split=dictend functionfunction asp_ceil(val) if val=int(val) then asp_Ceil=val else asp_Ceil=int(val)+1 end ifend functionfunction asp_floor(val) asp_floor=int(val)end functionfunction asp_urldecode(sConvert) if IsNull(sConvert) or isEmpty(sConvert) then asp_urldecode="" exit function end if Dim aSplit Dim sOutput Dim I ' convert all pluses to spaces sOutput = REPLACE(sConvert, "+", " ") ' next convert %hexdigits to the character aSplit = Split(sOutput, "%") If IsArray(aSplit) Then sOutput = aSplit(0) For I = 0 to UBound(aSplit) - 1 sOutput = sOutput & _ Chr("&H" & Left(aSplit(i + 1), 2)) &_ Right(aSplit(i + 1), Len(aSplit(i + 1)) - 2) Next End If asp_urldecode = sOutputend functionfunction db_close(conn) conn.Close Set conn = Nothingend functionfunction db_exec(sSQL,conn) if IsIdentical(dDebug,true) then response.write sSQL & "<br>" conn.Execute sSQL call ReportErrorend functionfunction db_query(sSQL,conn) dim asp_rs if IsIdentical(dDebug,true) then response.write sSQL & "<br>" Set asp_rs = server.CreateObject("ADODB.Recordset") asp_rs.Open sSQL,conn call ReportError set db_query=asp_rsend functionfunction db_query_direct(sSQL,conn,a) set db_query_direct=db_query(sSQL,conn)end functionfunction db_fetch_array(asp_rs) doAssignmentByRef db_fetch_array,db_fetch_array_int(asp_rs,true)end functionfunction db_fetch_numarray(asp_rs) doAssignmentByRef db_fetch_numarray,db_fetch_array_int(asp_rs,false)end functionfunction NumberWithZero(n) if n<10 then NumberWithZero="0" & n else NumberWithZero=n end ifend functionfunction db_fetch_array_int(asp_rs,byname) dim field, tdate if asp_rs.EOF then db_fetch_array_int=false exit function end if dim rsDict dim i,value i=0 set rsDict=CreateObject("Scripting.Dictionary") For Each field in asp_rs.Fields value=asp_rs.Fields(field.Name).Value if isnull(value) then value=null elseif IsTimeType(field.type) then tdate=asp_rs.Fields(field.Name).Value value=NumberWithZero(hour(tdate)) & ":" & NumberWithZero(minute(tdate)) & ":" & NumberWithZero(second(tdate)) elseif IsDateFieldType(asp_rs.Fields(field.Name).Type) then tdate=asp_rs.Fields(field.Name).Value if hour(tdate)=0 and minute(tdate)=0 and second(tdate)=0 then value=year(tdate) & "-" & NumberWithZero(month(tdate)) & "-" & NumberWithZero(day(tdate)) elseif year(tdate)=1899 and month(tdate)=12 and day(tdate)=30 then value=NumberWithZero(hour(tdate)) & ":" & NumberWithZero(minute(tdate)) & ":" & NumberWithZero(second(tdate)) else value=year(tdate) & "-" & NumberWithZero(month(tdate)) & "-" & NumberWithZero(day(tdate)) & " " & NumberWithZero(hour(tdate)) & ":" & NumberWithZero(minute(tdate)) & ":" & NumberWithZero(second(tdate)) end if elseif vartype(value)=14 then value=CDbl(value) end if if byname then rsDict(field.Name)=value else rsDict(i)=value end if i=i+1 next asp_rs.Movenext set db_fetch_array_int=rsDictend functionfunction asp_session_unset() session.Abandonend function function asp_function_exists(str) if arrAvailableEvents.Exists(str) then asp_function_exists=true else asp_function_exists=null end ifend functionFunction CSmartDbl(strValue) if vartype(strValue)=vbBoolean then if strValue=true then CSmartDbl=1 exit function end if end if 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 0End FunctionFunction CSmartLng(strValue) if strValue=true then CSmartLng=1 exit function end if On Error Resume Next CSmartLng = CLng(strValue) if Err.Number<>0 then Err.Clear CSmartLng=0 Err.Clear end if On Error Goto 0End FunctionFunction CSmartLng(strValue) On Error Resume Next CSmartLng = CLng(strValue) if Err.Number<>0 then Err.Clear CSmartLng = 0 end if On Error Goto 0End FunctionFunction CSmartStr(Value) if vartype(Value)=vbBoolean then if value then CSmartStr="-1" else CSmartStr="" end if exit function end if if vartype(Value)=vbDate then CSmartStr = dbvalue(Value) exit function end if On Error Resume Next CSmartStr = CStr(Value) if Err.Number<>0 then Err.Clear CSmartStr ="" end if if vartype(CSmartStr)=vbEmpty then _ CSmartStr="" On Error Goto 0End Functionfunction CSmartDate(value) On Error Resume Next CSmartDate=CDate(value) if Err.Number<>0 then Err.Clear CSmartDate =null end if if vartype(CSmartDate)=vbEmpty then _ CSmartDate=null On Error Goto 0end functionfunction db_pageseek(qhandle,pagesize,page) db_dataseek qhandle,(page-1)*pagesizeend functionfunction db_dataseek(qhandle,row) dim i i=0 while i<row qhandle.movenext i=i+1 wendend functionfunction asp_in_array(p_val,p_arr,p_strict) dim ret ret=asp_array_search(p_val, p_arr, p_strict) if IsIdentical(ret,false) then asp_in_array=false else asp_in_array=true end ifend functionfunction asp_array_search(p_val, p_arr, p_strict) dim key on error resume next for each key in p_arr.keys if not p_strict then if IsEqual(p_arr(key),p_val) then asp_array_search=key exit function end if else if IsIdentical(p_arr(key),p_val) then asp_array_search=key exit function end if end if next on error goto 0 asp_array_search=falseend functionsub ReportErrorif Err.number<>0 then response.flush%></form><p align=center><font size=+2>ASP <%="error happened"%></font></p><table border="0" cellpadding="3" cellspacing="1" width="700" bgcolor="#000000" align="center"><tr><td bgcolor="#ccccff" colspan=2 align=middle><font size=+1><b><%="Technical information" %></b></font></td></tr><tr bgcolor="#cccccc"><td width=130 bgcolor="#ccccff"><b>Error number</b></td><td align="left"><%=Err.Number%></td></tr><tr bgcolor="#cccccc"><td bgcolor="#ccccff"><b><%="Error description" %></b></td><td align="left"><font color=#cc3300><%=Err.Description%></font></td></tr><tr bgcolor="#cccccc"><td bgcolor="#ccccff"><b><%="URL" %></b></td><td align="left"><%=htmlspecialchars(Request.ServerVariables("URL"))%></td></tr><% if strSQL<>"" then %><tr bgcolor="#cccccc"><td bgcolor="#ccccff" ><b><%="SQL query" %></b></td><td align="left"><%=strSQL%></td></tr><% end if %><% if strMoreInfo<>"" then %><tr bgcolor="#cccccc"><td bgcolor="#ccccff" ><b>Additional info</b></td><td align="left"><%=strMoreInfo%></td></tr><% end if %></table> <form target=_new action="http://www.xlinesoft.com/asprunner/errors/default.asp" method="post" name="frmerror"> <input type='hidden' name='ErrorNumber' value="<%=Err.Number%>" /> <input type='hidden' name='Description' value="<%=Err.Description%>" /> <input type='hidden' name='SQL' value="<%=dSQL%>" /> </form><p align=center><a href="#" onClick="document.forms.frmerror.submit();return false;"><font size=3><b>More info on this error</b></font></a></p><% Response.Endend ifend subFunction SafeURLEncode(str) if IsNull(str) or isEmpty(str) then SafeURLEncode="" exit function end if SafeURLEncode = replace(server.urlencode(CStr(str)),"+","%20")End FunctionFunction htmlspecialchars(str) Dim ret if asp_is_array(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 htmlspecialchars = retEnd Functionfunction asp_number_format(n,d,a,b) asp_number_format = FormatNumber(CSmartDbl(n),d,0,0,0)end functionfunction asp_setcookie(name,val,ttime) Response.Cookies(name)=val Response.Cookies(name).Expires = DateAdd("yyyy", 1, Now())end functionfunction isFalse(str) isFalse=false if vartype(str)=vbBoolean then isFalse=not str end ifend functionfunction asp_join(term, arr) dim k, str str="" for each k in arr.keys str=str & arr(k) & term next if len(str)>0 then _ str=left(str,len(str)-len(term)) asp_join=strend functionfunction GetUploadedFileContents(name) GetUploadedFileContents = GetRequestForm(name)end functionfunction GetUploadedFileName(name) GetUploadedFileName = ""end functionfunction asp_intval(val) asp_intval=CSmartLng(val)end function function asp_array_splice(ByRef p_arr,offset,length) if offset>=0 and length>=0 then dim tmpDict, i, l l=0 set tmpDict=CreateObject("Scripting.Dictionary") for each i in p_arr.keys if i<offset or i>=offset+length then setArrElement tmpDict,l,p_arr(i) l=l+1 end if next set p_arr=tmpDict end ifend functionfunction DoUpdateRecord(byval table,byref evalues,byref blobfields,byval strWhereClause, byval pageid) if SQLUpdateMode then DoUpdateRecord = DoUpdateRecordSQL(table,evalues, blobfields,strWhereClause, pageid) end if dim rs,strSQL,status Set rs = server.CreateObject("ADODB.Recordset") strSQL=gSQLWhere(strWhereClause,"") LogInfo(strSQL) on error resume next rs.Open strSQL, conn, 1,2 call report_edit_error dim fields,keys,editformat,ftype set keys = GetTableKeys("") fields=evalues.keys for each f in fields editformat = GetEditFormat(f,"") ftype=GetFieldType(f,"") if IsFalse(asp_array_search(f,keys,false)) or IsUpdatable(rs(f)) then' update field strValue = evalues.Item(f) if errorhappened then _ exit for if isnull(strValue) then _ strValue="" ctype = GetRequestForm("type_" & GoodFieldName(f) & "_" & pageid) if editformat=EDIT_FORMAT_FILE then If ctype = "upload1" Then ' delete file rs(f)& "_1" = Null myunlink GetUploadFolder(f,"") & GetRequestForm("filename_" & GoodFieldName(f) & "_" & pageid) if GetCreateThumbnail(f,"") then _ myunlink GetUploadFolder(f,"") & GetThumbnailPrefix(f,"") & GetRequestForm("filename_" & GoodFieldName(f) & "_" & pageid) end if If ctype = "upload2" Then ' write file rs(f)= strValue if strValue<>"" then dim contents contents = GetRequestForm("value_" & GoodFieldName(f) & "_" & pageid) if ResizeOnUpload(f,"") then contents = CreateThumbnail(contents,GetNewImageSize(f,""),CheckImageExtension(strValue)) end if WriteToFile Server.MapPath(GetUploadFolder(f,"") & strValue), contents end if end if else if IsBinaryType(ftype) then rs(f).AppendChunk strValue elseif IsFloatType(ftype) then if strValue<>"" then rs(f) = CSmartDbl(strValue) else rs(f) = null end if elseif IsNumberType(ftype) then if strValue<>"" and IsNumeric(strValue) then rs(f) = CLng(strValue) else rs(f) = null end if elseif ischartype(ftype) then rs(f) = strValue elseif IsDateFieldType(ftype) then rs(f) = CSmartDate(strValue) else if strValue="" then rs(f)=null else rs(f)=strValue end if end if end if call report_edit_error end if next if not errorhappened then rs.Update call report_edit_error end if rs.Close if errorhappened then DoUpdateRecord=false exit function end if' save files ProcessFiles if inlineedit then status="UPDATED" message="" & "Record updated" & "" IsSaved = true else message="<div class=message><<< " & "Record updated" & " >>></div>" end if if usermessage<>"" then _ message=usermessage DoUpdateRecord=trueend functionfunction DoInsertRecord(byval table,byref avalues,byref blobfields, byval pageid) dim rs,status Set rs = server.CreateObject("ADODB.Recordset") on error resume next rs.Open "select * from " & AddTableWrappers(table) & " where 1=0", conn, 1,2 rs.Addnew call report_add_error dim fields,tkeys,editformat,ftype set tkeys = GetTableKeys("") fields=avalues.keys for each f in fields if errorhappened then _ exit for editformat = GetEditFormat(f,"") ftype=GetFieldType(f,"") if IsFalse(asp_array_search(f,tkeys,false)) or IsUpdatable(rs(f)) then' insert field strValue = avalues.Item(f) if isnull(strValue) then _ strValue="" ctype = GetRequestForm("type_" & GoodFieldName(f) & "_" & pageid) if editformat=EDIT_FORMAT_FILE then If ctype = "upload2" Then' write file rs(f)= strValue if strValue<>"" then dim contents contents = GetRequestForm("value_" & GoodFieldName(f) & "_" & pageid) if ResizeOnUpload(f,"") then contents = CreateThumbnail(contents,GetNewImageSize(f,""),CheckImageExtension(strValue)) end if WriteToFile Server.MapPath(GetUploadFolder(f,"") & strValue), contents end if end if else if IsBinaryType(ftype) then rs(f).AppendChunk strValue elseif IsFloatType(ftype) then if strValue<>"" then rs(f) = CSmartDbl(strValue) else rs(f) = null end if elseif IsNumberType(ftype) then if strValue<>"" and IsNumeric(strValue) then rs(f) = CLng(strValue) else rs(f) = null end if elseif ischartype(ftype) then rs(f) = strValue elseif IsDateFieldType(ftype) then rs(f) = CSmartDate(strValue) else if strValue="" then rs(f)=null else rs(f)=strValue end if end if end if call report_add_error end if next if errorhappened then DoInsertRecord=false exit function end if rs.Update call report_add_error on error goto 0 if errorhappened then DoInsertRecord=false exit function end if' save files ProcessFiles if inlineadd=ADD_INLINE then status="ADDED" message="" & "Record was added" & "" IsSaved = true else message="<div class=message><<< " & "Record was added" & " >>></div>" end if if usermessage<>"" then _ message=usermessage' get new key values failed_inline_add = false dim kk,k kk=tkeys.keys for each k in kk keys(tkeys(k)) = dbvalue(rs(tkeys(k))) next rs.Close DoInsertRecord=trueend functionFunction IsUpdatable(Field) if Field.Attributes and 4 or Field.Attributes and 8 then IsUpdatable=true else IsUpdatable=false end if End Functionfunction 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 functionend functionfunction GetCurrentYear() GetCurrentYear=year(now)end functionFunction 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) else if lenb(varValue) mod 2 then varValue = varValue & chrb(0) end if 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 FunctionFunction 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 NextEnd Functionfunction 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 filenamefunction 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 typefunction getFileType( infoStr) sPos = inStr( infoStr, "Content-Type: ") getFileType = mid( infoStr, sPos + 14)end functionFunction 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 ifEnd FunctionFunction Unicode2Bytes(str) For ind = 1 To len(str) Unicode2Bytes = Unicode2Bytes& ChrB(Asc(Mid(str, ind, 1))) Next End Functionfunction prepare_file(value,field,controltype,postfilename,id) if (trim(value)="" or isnull(value)) and mid(controltype,1,5)<>"file1" then prepare_file=false else prepare_file=value end if if trim(postfilename)<> "" then _ filename=trim(postfilename)end functionfunction prepare_upload(field,controltype,postfilename,value,table,id) if mid(controltype,7,1)="0" then prepare_upload = false exit function end if prepare_upload = valueend functionfunction FieldSubmitted(field) FieldSubmitted = myRequest.Exists("value_" & GoodFieldName(field)) or myRequest.Exists("value_" & GoodFieldName(field) & "[]") or myRequest.Exists("type_" & GoodFieldName(field))end function sub report_edit_error if Err.number<>0 then if inlineedit then message ="" & "Record was NOT edited" & ". " & Err.Description else message = "<div class=message><<< " & "Record was NOT edited" & " >>><br><br>" & Err.Description & "</div>" end if readevalues=true errorhappened=true err.clear end ifend subfunction asp_implode(p_str, p_arr) dim str str="" for each v in p_arr.keys str=str & p_arr(v) & p_str next if len(str)>0 then _ str=left(str,len(str)-len(p_str)) asp_implode=strend functionfunction asp_strcmp(str1, str2) if str1<str2 then asp_strcmp=-1 elseif str1>str2 then asp_strcmp=1 else asp_strcmp=0 end ifend functionfunction copyDictionary(byref from,byref out) dim k, d,ks,td Set d = CreateDictionary() ks=from.keys for each k in ks if IsDictionary(from(k)) then copyDictionary from(k),td set d(k)=td elseif Isobject(from(k)) then set d(k)=from(k) else d(k)=from(k) end if next set out=dend functionsub OrderTables(ByRef tables)' order tables by tables(i)(0)end subfunction getReportArray(name) getReportArray=CreateDictionary()end functionfunction getChartArray(name) getChartArray=CreateDictionary()end functionfunction asp_sort(arr) dim d, k, s, m Set d = CreateDictionary() for k=0 to asp_count(arr)-1 s=arr(k) for m=k+1 to asp_count(arr)-1 if arr(m)<k then _ s=arr(m) next d(d.count)=s next set arr=dend functionFunction postvalue(ByVal name) Dim var_POST,value,var_GET,ret,key,val if bValue(asp_array_key_exists(name & "[]",RequestForm())) then doAssignment value,GetRequestValue(RequestForm(),name) elseif bValue(asp_array_key_exists(name,RequestForm())) then doAssignment value,GetRequestValue(RequestForm(),name) elseif bValue(asp_array_key_exists(name & "[]",Request.QueryString)) then doAssignment value,GetRequestValue(Request.QueryString,name) elseif bValue(asp_array_key_exists(name,Request.QueryString)) then doAssignment value,GetRequestValue(Request.QueryString,name) else postvalue = "" Exit Function end if if not bValue(asp_is_array(value)) then doAssignment postvalue,value Exit Function end if Set ret = CreateDictionary() GetCollectionBounds value,loopIdx157,loopMax157 do while loopIdx157<=loopMax157 key = GetCollectionKey(value,loopIdx157) doAssignment val,value(key) setArrElement ret,key,val loopIdx157=loopIdx157+1 loop doAssignment postvalue,ret Exit FunctionEnd Function' Functions to provide encoding/decoding of strings with Base64.' ' Encoding: myEncodedString = base64_encode( inputString )' Decoding: myDecodedString = base64_decode( encodedInputString )'' Programmed by Markus Hartsmar for ShameDesigns in 2002. ' Email me at: mark@shamedesigns.com' Visit our website at: http://www.shamedesigns.com/' Dim Base64Chars Base64Chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" & _ "abcdefghijklmnopqrstuvwxyz" & _ "0123456789" & _ "+/" ' Functions for encoding string to Base64 Public Function base64_encode( byVal strIn ) Dim c1, c2, c3, w1, w2, w3, w4, n, strOut For n = 1 To Len( strIn ) Step 3 c1 = Asc( Mid( strIn, n, 1 ) ) c2 = Asc( Mid( strIn, n + 1, 1 ) + Chr(0) ) c3 = Asc( Mid( strIn, n + 2, 1 ) + Chr(0) ) w1 = Int( c1 / 4 ) : w2 = ( c1 And 3 ) * 16 + Int( c2 / 16 ) If Len( strIn ) >= n + 1 Then w3 = ( c2 And 15 ) * 4 + Int( c3 / 64 ) Else w3 = -1 End If If Len( strIn ) >= n + 2 Then w4 = c3 And 63 Else w4 = -1 End If strOut = strOut + mimeencode( w1 ) + mimeencode( w2 ) + _ mimeencode( w3 ) + mimeencode( w4 ) Next base64_encode = strOut End Function Private Function mimeencode( byVal intIn ) If intIn >= 0 Then mimeencode = Mid( Base64Chars, intIn + 1, 1 ) Else mimeencode = "" End If End Function ' Function to decode string from Base64 Public Function base64_decode( byVal strIn ) Dim w1, w2, w3, w4, n, strOut For n = 1 To Len( strIn ) Step 4 w1 = mimedecode( Mid( strIn, n, 1 ) ) w2 = mimedecode( Mid( strIn, n + 1, 1 ) ) w3 = mimedecode( Mid( strIn, n + 2, 1 ) ) w4 = mimedecode( Mid( strIn, n + 3, 1 ) ) If w2 >= 0 Then _ strOut = strOut + _ Chr( ( ( w1 * 4 + Int( w2 / 16 ) ) And 255 ) ) If w3 >= 0 Then _ strOut = strOut + _ Chr( ( ( w2 * 16 + Int( w3 / 4 ) ) And 255 ) ) If w4 >= 0 Then _ strOut = strOut + _ Chr( ( ( w3 * 64 + w4 ) And 255 ) ) Next base64_decode = strOut End Function Private Function mimedecode( byVal strIn ) If Len( strIn ) = 0 Then mimedecode = -1 : Exit Function Else mimedecode = InStr( Base64Chars, strIn ) - 1 End If End Functionfunction sortTables(ByRef tables)end function function sortMembers(ByRef rowinfo) gcount=rowinfo.count dim i dim keys dim gi dim tmp dim mindex,gcount set tmp = CreateObject("Scripting.Dictionary") if rowinfo.count=0 then exit function' find group index gcount=rowinfo(0)("usergroup_boxes")("data").Count gi=gcount for i=0 to gcount-1 if clng(rowinfo(0)("usergroup_boxes")("data")(i)("group"))=cSmartlng(sortgroup) then gi = i exit for end if next' run sorting do while rowinfo.count>0' init values keys=rowinfo.keys mindex=keys(0) for each i in keys if i<>keys(0) then if gi=gcount or ArrayElement(rowinfo(i)("usergroup_boxes")("data")(gi),"checked")=ArrayElement(rowinfo(mindex)("usergroup_boxes")("data")(gi),"checked") then if rowinfo(i)("user")<rowinfo(mindex)("user") then _ mindex=i else if sortorder="a" and not bValue(ArrayElement(rowinfo(i)("usergroup_boxes")("data")(gi),"checked")) then _ mindex=i if sortorder="d" and not bValue(ArrayElement(rowinfo(mindex)("usergroup_boxes")("data")(gi),"checked")) then _ mindex=i end if end if next tmp.Add tmp.Count, rowinfo(mindex) rowinfo.remove mindex loop set rowinfo=tmpend functionfunction report_add_error if Err.number<>0 then if inlineadd=ADD_INLINE then message ="" & "Record was NOT added" & ". " & Err.Description else message = "<div class=message><<< " & "Record was NOT added" & " >>><br><br>" & Err.Description & "</div>" end if readavalues=true errorhappened=true err.clear end ifend functionfunction IsEqual(a1,a2) dim p1,p2 p1=a1 p2=a2 if vartype(p1)=vbNull or vartype(p1)=vbEmpty then IsEqual = CSmartStr(p1)=CSmartStr(p2) exit function end if if vartype(p1) = vartype(p2) then IsEqual=p1=p2 exit function end if if vartype(p1)=vbBool then p2=bValue(p2) elseif vartype(p2)=vbBool then p1=bValue(p2) elseif vartype(p1)=vbInteger or vartype(p1)=vbLong or vartype(p1)=vbByte then p2=CSmartLng(p2) elseif vartype(p2)=vbInteger or vartype(p2)=vbLong or vartype(p2)=vbByte then p1=CSmartLng(p1) elseif vartype(p1)=vbSingle or vartype(p1)=vbDouble or vartype(p1)=vbCurrency then p2=CSmartDbl(p2) elseif vartype(p2)=vbSingle or vartype(p2)=vbDouble or vartype(p2)=vbCurrency then p1=CSmartDbl(p1) else p1=CSmartStr(p1) p2=CSmartStr(p2) end if IsEqual=p1=p2end functionfunction IsIdentical(a1,a2) if vartype(a1)<>vartype(a2) then IsIdentical=false else IsIdentical=IsEqual(a1,a2) end ifend functionsub print_r(ByRef var) print_r_int var,0end subsub print_r_int(ByRef var,ByVal indent) if not isObject(var) then if vartype(var)=vbBoolean then if var then responsewrite 1 end if else ResponseWrite var end if elseif IsDictionary(var) then ResponseWrite "Array" if var.count=0 then ResponseWrite "()" exit sub end if ResponseWrite vbcrlf & space(indent) & "(" & vbcrlf indent=indent+4 dim keys keys=var.keys for each k in keys ResponseWrite space(indent) & "["&k&"] => " print_r_int var(k),indent+4 ResponseWrite vbcrlf next indent=indent-4 ResponseWrite space(indent) & ")" & vbcrlf else ResponseWrite "["& typename(var) & "]" end ifend subFunction CustomExpression(ByVal strValue,ByRef data,ByVal field,ByVal table) if not bValue(table) then doAssignment table,strTableName end if dim rs set rs=data doAssignment CustomExpression,strValue Exit FunctionEnd Functionfunction asp_array_unshift(byref arr, byref var) dim tmpDict, i, a set tmpDict = CreateObject("Scripting.Dictionary") setArrElementByRef tmpDict,0,var i=1 for each a in arr.keys setArrElement tmpDict,i,arr(a) i=i+1 next doAssignmentByRef arr,tmpDictEnd Functionfunction asp_array_shift(byref arr) dim i set tmpDict = CreateObject("Scripting.Dictionary") if arr.Count=0 then asp_array_shift=null exit function end if doAssignmentByRef asp_array_shift,arr(0) for i=0 to arr.count-2 setArrElement arr,i,ArrayElement(arr,i+1) next arr.Remove(arr.count-1)End Functionfunction rand(vmin, vmax) randomize rand=rnd(1)*(vmax-vmin)+vminend functionsub 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.Fields("File").AppendChunk "0" 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 = Nothingend sub'// return lookup wizard WHERE expressionfunction LookupWhere(ByVal field,ByVal table) if not bValue(table) then doAssignment table,strTableName end if LookupWhere = ""end functionfunction GetDefaultValue(ByVal field,ByVal table) if not bValue(table) then doAssignment table,strTableName end if if table="tab" and field="full_name" then GetDefaultValue = Session("_" & strTableName &"_OwnerID") exit function end if GetDefaultValue = ""end functionfunction mdeleteIndex(i) mdeleteIndex=iend functionfunction InArray(arr,val) dim i for i=0 to asp_count(arr) if arr(i)=val then InArray=true exit function end if next InArray=falseend functionfunction getabspath(filename) getabspath=Server.MapPath(filename)end functionfunction GetMySQL4RowCount(countstr) dim asp_rs Set asp_rs = server.CreateObject("ADODB.Recordset") asp_rs.Open sSQL,conn,3,1 call ReportError GetMySQL4RowCount = asp_rs.RecordCountend functionfunction serialize(ByRef obj) serialize=obj.ASPserialize()end functionfunction serialize(ByRef obj) dim arr set arr=obj.ASPserialize() arr("ASPclassname")=typename(obj) set serialize=arrend functionfunction unserialize(ByRef arr) dim str str="set unserialize=new " & arr("ASPclassname") Execute str unserialize.ASPunserialize(arr)end functionfunction CreateFCKEditor(cfield,value,nWidth,nHeight) Set CreateFCKEditor = new FCKeditor CreateFCKEditor.BasePath = "plugins/fckeditor/" doClassAssignment CreateFCKEditor,"Value",value doClassAssignment CreateFCKEditor,"Width",nWidth doClassAssignment CreateFCKEditor,"Height",nHeight CreateFCKEditor.Create(cfield)end functionfunction asp_array_slice(ByRef arr, idx,length) dim out,i,keys if idx<0 then idx=asp_count(arr)+idx end if if length<0 then length=asp_count(arr)+length end if keys=arr.keys set out=CreateDictionary() i=0 while (i<length or isempty(length)) and idx+i<asp_count(arr) setArrElement out,keys(i),ArrayElement(arr,idx+i) i=i+1 wend set asp_array_slice=outend functionfunction asp_array_intersect(ByRef arr1, ByRef arr2) set out=CreateDictionary() dim keys1,keys2,i1,i2 keys1=arr1.keys keys2=arr2.keys for each i1 in keys1 for each i2 in keys2 if IsEqual(arr1(i1),arr2(i2)) then setArrElement out,i1,arr1(i1) end if next next set asp_array_intersect=outend functionfunction strcasecmp(ByVal str1,ByVal str2) strcasecmp = asp_strcmp(ucase(str1),ucase(str2))end functionfunction no_output_done() err.clear on error resume next response.addheader "TestHeader","test" if err.number<>0 then err.clear no_output_done=false else no_output_done=true end if on error goto 0end functionsub flush_output() if response.buffer then _ response.flushend subfunction basename(str) basename=strend function function fformat_number(val) fformat_number = str_format_number(val)end functionfunction fformat_currency(val) fformat_currency = str_format_currency(val)end functionfunction format_datetime(ttime()) format_datetime = str_format_datetime(ttime)end functionfunction fformat_time(ttime()) fformat_time = str_format_time(ttime)end functionSub DoEvent(strEvent) On Error Resume Next Execute strEvent If Err.Number <> 13 Then strMoreInfo = "Event: " & strEvent ReportError End If On Error GoTo 0End Subfunction IsDictionary(byref p_arr) if not isobject(p_arr) then IsDictionary=false exit function end if on error resume next err.clear dim ret ret=p_arr.CompareMode if err.Number=0 then IsDictionary=true else IsDictionary=false end if on error goto 0end functionfunction ArrayElement(byref p_arr, byval key) dim status if not IsObject(p_arr) and vartype(p_arr)<>vbString then if isArray(p_arr) then ArrayElement=p_arr(key) exit function end if end if if vartype(key)=vbString then if IsNumeric(key) then key=CLng(key) end if end if if not isobject(p_arr) and vartype(p_arr)=vbString then ArrayElement=mid(p_arr,key+1,1) exit function end if err.clear on error resume next if asp_array_key_exists(key,p_arr) then DoAssignmentByRef ArrayElement,p_arr(key) else ArrayElement=Empty end if status=err.Number on error goto 0 if status<>0 then ArrayElement=Empty end ifend functionfunction asp_array_reverse(arr) dim tmpDict,key set tmpDict = CreateObject("Scripting.Dictionary") set key = CreateObject("Scripting.Dictionary") key = arr.keys for i=ubound(key) to 0 step -1 setArrElement tmpDict,key(i),arr(key(i)) next set asp_array_reverse=tmpDictend functionfunction asp_shl(a, n) asp_shl=CLng(a) for i=1 to n asp_shl=asp_shl*2 nextend functionfunction asp_shl(a, n) asp_shl=CLng(a) for i=1 to n asp_shl=Int(asp_shl/2) nextend functionfunction asp_array_diff(arr1,arr2) dim tmpDict, i, key set tmpDict = CreateObject("Scripting.Dictionary") for each key in arr1.keys if not asp_in_array(arr1(key),arr2,true) then tmpDict(key)=arr1(key) end if next set asp_array_diff=tmpDictend functionfunction asp_array_values(arr) dim tmpDict, i, key set tmpDict = CreateObject("Scripting.Dictionary") i=0 for each key in arr.keys setArrElement tmpDict,i,arr(key) i=i+1 next set asp_array_values=tmpDictend functionfunction asp_array_merge(arr1,arr2) dim tmpDict, i, key set tmpDict = CreateObject("Scripting.Dictionary") i=0 for each key in arr1.keys setArrElement tmpDict,i,arr1(key) i=i+1 next for each key in arr2.keys setArrElement tmpDict,i,arr2(key) i=i+1 next set asp_array_merge=tmpDictend functionfunction asp_preg_match(patt,strng,arr) Dim regEx, Match, Matches, i, sm, p, result, modif if left(patt,1)="/" then patt=mid(patt,2) p=instrrev(patt,"/") if p>0 then modif=mid(patt,p+1) patt=left(patt,p-1) end if Set regEx = New RegExp if instr(1,modif,"i") then regEx.IgnoreCase = True else regEx.IgnoreCase = False end if result=patt if instr(1,modif,"U") then result="" for i=1 to len(patt) if mid(patt,i,1)="*" or mid(patt,i,1)="+" then if i>1 then if mid(patt,i-1,1)="\" then result=result & mid(patt,i,1) else if i<len(patt) then if mid(patt,i+1,1)="?" then result=result & mid(patt,i,1) i=i+1 else result=result & mid(patt,i,1) & "?" end if else result=result & mid(patt,i,1) & "?" end if end if else if mid(patt,i+1,1)="?" then result=result & mid(patt,i,1) i=i+1 else result=result & mid(patt,i,1) & "?" end if end if else result=result & mid(patt,i,1) end if next end if regEx.Pattern = result regEx.Global = True Set Matches = regEx.Execute(strng) if not isnull(arr) then set arr = CreateObject("Scripting.Dictionary") if Matches.Count>0 then Set Match = Matches(0) arr(0)=Match.Value i=1 for each sm in Match.SubMatches arr(i)=sm i=i+1 Next end if end if if Matches.Count>0 then asp_preg_match=1 else asp_preg_match=0 end if end functionFunction asp_preg_replace(patt,repl,strng) Dim regEx,p Set regEx = New RegExp if left(patt,1)="/" then patt=mid(patt,2) p=instrrev(patt,"/") if p>0 then modif=mid(patt,p+1) patt=left(patt,p-1) end if Set regEx = New RegExp if instr(1,modif,"i") then regEx.IgnoreCase = True else regEx.IgnoreCase = False end if regEx.Pattern = patt asp_preg_replace=regEx.Replace(strng, repl)End Functionfunction asp_include(byval filename,once) if instr(filename,"\")=0 then filename=getabspath(filename) end if if once then if included_files.exists(filename) then exit function end if end if included_files(filename)=true ExecuteGlobal readIncludeFile(filename)end functionfunction readIncludeFile(filename) Dim stream,out,pos,start,pos1,start1,textblock,txt,incfile,path pos=instrrev(filename,"\") path=left(filename,pos) set stream=Server.CreateObject("ADODB.Stream") stream.CharSet=cCharset stream.type=2 stream.Open stream.LoadFromFile Filename file = stream.ReadText stream.Close set stream=nothing' cut asp wrappers and include files out="" start=1 do while start<=len(file) pos=instr(start,file,"<%")' add text contents if pos=0 or pos>start then' handle file includes if pos=0 then textblock=mid(file,start) else textblock=mid(file,start,pos-start) end if start1=1 do while start1<len(textblock) pos1=instr(start1,textblock,"<!--#incl"&"ude file=""")' add plain text contents if pos1=0 or pos1>start then if pos1>0 then txt = mid(textblock,start1,pos1-start1) else txt = mid(textblock,start1) end if end if txt=trim(replace(replace(txt,vbcr,""),vblf,"")) if len(txt) then out = out & "ResponseWrite """ out = out & replace(txt,"""","""""") out = out & """" & vbcrlf end if if pos1=0 then exit do end if start1=pos1+len("<!--#incl"&"ude file=""") pos1=instr(start1,textblock,"""-->") if pos1=0 then pos1=len(textblock) end if' do include incfile=path & mid(textblock,start1,pos1-start1) out=out&"asp_include """ & replace(incfile,"""","""""") & """,false" & vbcrlf start1=pos1+len("""-->") loop end if if pos=0 then exit do end if' add code block start=pos+2 pos=instr(start,file,"%" & ">") if pos=0 then pos=len(file) end if out=out & vbcrlf & mid(file,start,pos-start) start=pos+2 loop readIncludeFile=outend function' old style array functionsfunction doArrayAssignment(ByRef arr,ByRef key,ByRef value) dim tval doAssignment tval,value if not IsObject(value) then arr(key)=tval doArrayAssignment=tval else set arr(key)=tval doArrayAssignment=bValue(tval) end ifend functionfunction doArrayAssignmentByRef(ByRef arr,ByRef key,ByRef value) if not IsObject(value) then arr(key)=value doArrayAssignmentByRef=value else set arr(key)=value doArrayAssignmentByRef=bValue(value) end ifend functionfunction doArrayInArrayAssignment(ByRef arr,ByRef key,ByVal key1,ByRef value) ensureArrayCreated arr,key if isEmpty(key1) then key1=asp_count(arr(key)) end if doArrayAssignment arr(key),key1,value doAssignmentByRef doArrayInArrayAssignment,valueend functionfunction doArrayInArrayAssignmentByRef(ByRef arr,ByRef key,ByVal key1,ByRef value) ensureArrayCreated arr,key if isEmpty(key1) then key1=asp_count(arr(key)) end if doArrayAssignmentByRef arr(key),key1,value doAssignmentByRef doArrayInArrayAssignmentByRef,valueend function' end old stylefunction isLess(byval arg1,byval arg2) if IsEmpty(arg2) or IsNull(arg2) then isLess=false exit function end if if IsEmpty(arg1) or IsNull(arg1) then isLess=true exit function end if if IsNumeric(arg1) and IsNumeric(arg2) then isLess=CDbl(arg1)<CDbl(arg2) exit function end if isLess=arg1<arg2end functionfunction isLessOrEqual(arg1,arg2) if isEqual(arg1,arg2) then isLessOrEqual=true exit function end if if isLess(arg1,arg2) then isLessOrEqual=true exit function end if isLessOrEqual=falseend functionfunction callVariableMethod(byref object,byval method,byref params) dim command,i,strParams command="DoAssignmentByRef callVariableMethod,object." & method if not isEmpty(params) then command=command & "_p" & params.Count & "(" for i=0 to params.Count-1 if i>0 then command=command & "," end if command = command & "params("&i&")" next command=command & ")" end if Execute commandend functionfunction db_query_safe(sSQL,conn,byref errstr) dim asp_rs Set asp_rs = server.CreateObject("ADODB.Recordset") err.clear on error resume next asp_rs.Open sSQL,conn errstr=err.description if err.number=0 then set db_query_safe=asp_rs else set db_query_safe=false end if on error goto 0end functionfunction binPrint(byref value, size) response.BinaryWrite valueend functionfunction db_stripslashesbinary(str) if isnull(str) or isempty(str) then db_stripslashesbinary="" exit function end if' 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 functionfunction DisplayNoImage() Response.ContentType = "image/gif" Set fs = CreateObject("Scripting.FileSystemObject") Set a = fs.GetFile(Server.MapPath("images/no_image.gif")) Set b = a.OpenAsTextStream(1,-1) Response.BinaryWrite(b.Read(999999))end functionSub DisplayFileImage Response.ContentType = "image/gif" Set fs = CreateObject("Scripting.FileSystemObject") Set a = fs.GetFile(Server.MapPath("images/file.gif")) Set b = a.OpenAsTextStream(1,-1) Response.BinaryWrite(b.Read(999999))End Subfunction asp_fclose(header) header.closeend function function asp_fopen(spath,iomode) Dim fso, iomode2 Set fso = CreateObject("Scripting.FileSystemObject") spath2=getabspath(spath) if iomode="a" then iomode2=8 elseif iomode="w" then iomode2=2 else iomode2=1 end if If fso.FileExists(spath2) then set asp_fopen = fso.OpenTextFile(spath2, iomode2) else set asp_fopen = fso.CreateTextFile(spath2) end ifend functionfunction fputs(header,str) header.Write(str)end functionfunction filesize(filename) dim fs,ff set fs=Server.CreateObject("Scripting.FileSystemObject") if instr(filename,"\")=0 then filename=getabspath(filename) end if set ff=fs.GetFile(filename) res=ff.Size set ff=nothing set fs=nothing filesize=resend functionfunction session_id() session_id=Session.SessionIDend functionfunction pow(x,y) pow=Exp(y* Log(x))end functionfunction log10(x) log10=Log(x)/Log(10)end functionfunction ob_start() output_buffer="" ob_enabled=trueend functionfunction ob_get_contents() ob_get_contents = output_bufferend functionfunction ob_get_contents() ob_get_contents = output_bufferend functionfunction ob_end_clean() output_buffer="" ob_enabled=falseend functionsub ResponseWrite(str) if vartype(str)=vbBoolean then if(str) then str="1" else str="" end if end if if ob_enabled then output_buffer = output_buffer & str else Response.Write str end ifend subfunction xtempl_call_func(byval func,byref params) Execute func & " params"end functionfunction is_string(byref val) is_string = (not isObject(val)) and vartype(val)=vbStringend functionfunction is_bool(byref val) is_bool = (not isObject(val)) and vartype(val)=vbBooleanend functionfunction is_a(byref val,byval name) is_a = typename(val)=nameend functionfunction PropertyExists(byref obj,byval name) dim str if not isobject(obj) then PropertyExists=false exit function end if on error resume next str = "vartype obj." & name Execute str PropertyExists = err.Number=0 on error goto 0end functionfunction array_pop(byref arr) if not IsDictionary(arr) then array_pop=NULL exit function end if if arr.Count=0 then array_pop=NULL exit function end if DoAssignmentByref array_pop,arr(arr.Count-1) arr.Remove(arr.Count-1)end functionfunction echoBinary(byref value, byval dummy) response.binarywrite valueend functionfunction secondsPassedFrom(datetime) dim arrDateTime arrDateTime=db2time(datetime) secondsPassedFrom = datediff("s",arrDateTime(0) & "-" & arrDateTime(1) & "-" & arrDateTime(2) & " " & arrDateTime(3) & ":" & arrDateTime(4) & ":" & arrDateTime(5),now())end functionfunction setObjectProperty(byref obj,byval key,byref value) on error resume next doClassAssignmentByRef obj, key, valueend functionfunction returnError404() response.Status=404end function' checks if dictionary contains numeric keys 0-N onlyfunction IsArrayDict(byref dict) dim i for i=0 to dict.Count-1 if not asp_array_key_exists(i,dict) then IsArrayDict=false exit function end if next IsArrayDict=trueend functionfunction execute_events(ByRef params) if bValue(asp_function_exists(ArrayElement(params,"custom1"))) then execute ArrayElement(params,"custom1") & "(params)" end ifend functionfunction is_object(byref var) is_object = IsObject(var)end functionfunction PrepareBlobs(byref values, byref blobfields) set PrepareBlobs = CreateDictionary()end functionfunction ExecuteUpdate(strSQL,byref blobs,addMode)' exec SQL and read error message error_happened=false on error resume next conn.Execute strSQL If err.Number=0 Then ExecuteUpdate=true exit function end if ExecuteUpdate=false error_happened = true' adding if addMode then if inlineadd<>ADD_SIMPLE then message="" & "Record was NOT added" & ". " & err.description else message="<<< " & "Record was NOT added" & " >>><br><br>" & err.description end if readavalues=true else if inlineedit then message="" & "Record was NOT edited" & ". " & err.description else message="<<< " & "Record was NOT edited" & " >>><br><br>" & err.description end if readevalues=true end ifend functionfunction ProcessFiles' save files for each file in files_save WriteToFile Server.MapPath(files_save(file)("filename")), files_save(file)("file") nextend functionfunction usort(byref arr, compfuncname) if arr.count>1 then qsort arr,0,arr.count-1,compfuncname end ifend functionfunction qsortcompare(compfuncname,byref arg1,byref arg2) dim str str = "qsortcompare = " & compfuncname & "(arg1,arg2)" execute strend functionfunction swapItems(byref arr, i1, i2) dim temp DoAssignmentByRef temp,arr(i1) setArrElementByRef arr,i1,arr(i2) setArrElementByRef arr,i2,tempend functionfunction qsort(byref arr,loBound,hiBound,compfuncname) Dim pivot,loSwap,hiSwap,temp' two items if hiBound - loBound = 1 then if qsortcompare(compfuncname,arr(loBound),arr(hiBound))>0 then swapItems arr,loBound,hiBound End If End If doAssignmentByRef pivot,arr(int((loBound + hiBound) / 2)) swapItems arr,int((loBound + hiBound) / 2),loBound loSwap = loBound + 1 hiSwap = hiBound do while loSwap < hiSwap and qsortcompare(compfuncname,arr(loSwap),pivot)<=0 loSwap = loSwap + 1 wend while loSwap <= hiSwap and qsortcompare(compfuncname,arr(hiSwap),pivot)>=0 hiSwap = hiSwap - 1 wend if loSwap < hiSwap then swapItems arr,loSwap,hiSwap End If loop while loSwap < hiSwap setArrElementByRef arr,loBound,arr(hiSwap) setArrElementByRef arr,hiSwap, pivot if loBound < (hiSwap - 1) then qsort arr,loBound,hiSwap-1,compfuncname end if if hibound > hiSwap + 1 then qsort arr,hiSwap+1,hiBound,compfuncname end ifEnd functionfunction asp_trim(str) asp_trim = trim(CSmartStr(str))end functionfunction xtempl_include_header(xt,fname,param) if not asp_file_exists(getabspath(param)) then exit function end if if filesize(getabspath(param))>0 then xt.assign_function_p3 fname,"server.Execute",param end ifend functionfunction db_query_safe(sSQL,conn,byref errstr) dim asp_rs Set asp_rs = server.CreateObject("ADODB.Recordset") err.clear on error resume next asp_rs.Open sSQL,conn errstr=err.description if err.number=0 then set db_query_safe=asp_rs else set db_query_safe=false end if on error goto 0end functionfunction binPrint(byref value, size) response.BinaryWrite valueend functionfunction WRGetAbsoluteFileName(filename) WRGetAbsoluteFileName=Server.MapPath(filename)end function%>