<%
Function CheckForErrors(errNum, addDetails)
'Turn on page buffering
Response.Buffer = True
'Error Handler
If errNum <> 0 Then
'Clear response buffer
Response.Clear
'Display Error Message to user
%>
Error Handler
An error (<%= errNum %>) has occurred. Details: <%= addDetails %>
Please contact the Web developer if this error persists.
<% End If
End Function
Function DLookup(fieldName, tableName, whereCriteria)
On Error Resume Next
Err.Clear
connStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath(".") & "\db\ZipCode.mdb;"
'create and open the connection object.
Set dbConnObj= Server.CreateObject("ADODB.Connection")
dbConnObj.Open connStr
CheckForErrors Err.Number, "Database connection in Common.asp failed"
If whereCriteria = "" Then
sqlString = "SELECT " & fieldName & " FROM " & tableName
Else
sqlString = "SELECT " & fieldName & " FROM " & tableName & " WHERE " & whereCriteria
End If
Set rstLookup = dbConnObj.Execute(sqlString)
CheckForErrors Err.Number, "Database query in Common.asp failed. SQL: " & sqlString
If rstLookup.RecordCount = 0 or Err.Number <> 0 or rstLookup.EOF Then
DLookup = ""
Else
DLookup = rstLookup(fieldName)
If Len(DLookup) = 0 Or IsNull(DLookup) Then
DLookup = ""
End If
End If
rstLookup.Close()
dbConnObj.Close()
set rstLookup = nothing
set dbConnObj = nothing
End Function
Function DMax(fieldName, tableName, whereCriteria)
On Error Resume Next
Err.Clear
connStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath(".") & "\db\ZipCode.mdb;"
'create and open the connection object.
Set dbConnObj= Server.CreateObject("ADODB.Connection")
dbConnObj.Open connStr
CheckForErrors Err.Number, "Database connection in Common.asp failed"
If whereCriteria = "" Then
sqlString = "SELECT MAX(" & fieldName & ") AS MXVAL FROM " & tableName
Else
sqlString = "SELECT MAX(" & fieldName & ") AS MXVAL FROM " & tableName & " WHERE " & whereCriteria
End If
Set rstLookup = dbConnObj.Execute(sqlString)
CheckForErrors Err.Number, "Database query in Common.asp failed. SQL: " & sqlString
If rstLookup.RecordCount = 0 Then
DMax = ""
Else
DMax = rstLookup("MXVAL").Value
End If
CheckForErrors Err.Number, "MAX Record Lookup in Common.asp failed"
rstLookup.Close()
dbConnObj.Close()
set rstLookup = nothing
set dbConnObj = nothing
End Function
Function RunSQL(sqlStatement)
On Error Resume Next
Err.Clear
connStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath(".") & "\db\ZipCode.mdb;"
'create and open the connection object.
Set dbConnObj= Server.CreateObject("ADODB.Connection")
dbConnObj.Open connStr
CheckForErrors Err.Number, "Database connection in Common.asp failed"
dbConnObj.Execute(sqlStatement)
CheckForErrors Err.Number, "SQL Query in Common.asp Failed: " & sqlStatement
dbConnObj.Close()
set dbConnObj = nothing
End Function
Function BuildDropDownList(fieldName, valueFieldName, tableName, whereCriteria, ddlName, ddlSize, defaultItem)
On Error Resume Next
Err.Clear
connStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath(".") & "\db\ZipCode.mdb;"
'create and open the connection object.
Set dbConnObj= Server.CreateObject("ADODB.Connection")
dbConnObj.Open connStr
CheckForErrors Err.Number, "Database connection in Common.asp failed"
If whereCriteria <> "" Then
whereCriteria = "WHERE " & whereCriteria
End If
If fieldName = "FULLNAME" Then
fieldName = "LNAME,FNAME"
End If
If valueFieldName = "" Then
sqlString = "SELECT " & fieldName & " FROM " & tableName & whereCriteria & " ORDER BY " & fieldName
valueFieldName = fieldName
Else
sqlString = "SELECT " & fieldName & "," & valueFieldName & " FROM " & tableName & whereCriteria & " ORDER BY " & fieldName
End If
Set rstBuild = dbConnObj.Execute(sqlString)
CheckForErrors Err.Number, "Database query in Common.asp failed SQL: " & sqlString
If rstBuild.RecordCount = 0 Then
ddHtml = ""
Else
ddHtml = ""
End If
CheckForErrors Err.Number, "Build Drop Down List in Common.asp failed " & sqlString
BuildDropDownList = ddHtml
rstBuild.Close()
dbConnObj.Close()
set rstBuild = nothing
set dbConnObj = nothing
End Function
Function CalcDistance(latA, longA, latB, longB)
On Error Resume Next
Err.Clear
returnDistance = Sin(Deg2Rad(latA)) * Sin(Deg2Rad(latB)) + Cos(Deg2Rad(latA)) * Cos(Deg2Rad(latB)) * Cos(Deg2Rad(longA - longB))
returnDistance = (Rad2Deg(ArcCos(returnDistance))) * 69.09
CalcDistance = returnDistance
Err.Clear
End Function
Function ArcCos(y)
On Error Resume Next
ArcCos = Atn(-y / Sqr(-y * y + 1)) + 2 * Atn(1)
Err.Clear
End Function
Function Deg2Rad(Deg)
On Error Resume Next
Err.Clear
Deg2Rad = Deg / 57.2957795130823
Err.Clear
End Function
Function Rad2Deg(Rad)
On Error Resume Next
Err.Clear
Rad2Deg = 57.2957795130823 * Rad
Err.Clear
End Function
Function DateFormatting(dateStr)
If IsDate(dateStr) Then
DateFormatting= FormatDateTime(dateStr,0)
End If
End Function
Class Loader
Private dict
Private Sub Class_Initialize
Set dict = Server.CreateObject("Scripting.Dictionary")
End Sub
Private Sub Class_Terminate
If IsObject(intDict) Then
intDict.RemoveAll
Set intDict = Nothing
End If
If IsObject(dict) Then
dict.RemoveAll
Set dict = Nothing
End If
End Sub
Public Property Get Count
Count = dict.Count
End Property
Public Sub Initialize
If Request.TotalBytes > 0 Then
Dim binData
binData = Request.BinaryRead(Request.TotalBytes)
getData binData
End If
End Sub
Public Function getFileData(name)
If dict.Exists(name) Then
getFileData = dict(name).Item("Value")
Else
getFileData = ""
End If
End Function
Public Function getValue(name)
Dim gv
If dict.Exists(name) Then
gv = CStr(dict(name).Item("Value"))
gv = Left(gv,Len(gv)-2)
getValue = gv
Else
getValue = ""
End If
End Function
Public Function saveToFile(name, path)
If dict.Exists(name) Then
Dim temp
temp = dict(name).Item("Value")
Dim fso
Set fso = Server.CreateObject("Scripting.FileSystemObject")
Dim file
Set file = fso.CreateTextFile(path)
For tPoint = 1 to LenB(temp)
file.Write Chr(AscB(MidB(temp,tPoint,1)))
Next
file.Close
saveToFile = True
Else
saveToFile = False
End If
End Function
Public Function getFileName(name)
If dict.Exists(name) Then
Dim temp, tempPos
temp = dict(name).Item("FileName")
tempPos = 1 + InStrRev(temp, "\")
getFileName = Mid(temp, tempPos)
Else
getFileName = ""
End If
End Function
Public Function getFilePath(name)
If dict.Exists(name) Then
Dim temp, tempPos
temp = dict(name).Item("FileName")
tempPos = InStrRev(temp, "\")
getFilePath = Mid(temp, 1, tempPos)
Else
getFilePath = ""
End If
End Function
Public Function getFilePathComplete(name)
If dict.Exists(name) Then
getFilePathComplete = dict(name).Item("FileName")
Else
getFilePathComplete = ""
End If
End Function
Public Function getFileSize(name)
If dict.Exists(name) Then
getFileSize = LenB(dict(name).Item("Value"))
Else
getFileSize = 0
End If
End Function
Public Function getFileSizeTranslated(name)
If dict.Exists(name) Then
temp = LenB(dict(name).Item("Value"))
If temp <= 1024 Then
getFileSizeTranslated = temp & " bytes"
Else
temp = FormatNumber((temp / 1024), 2)
getFileSizeTranslated = temp & " kilobytes"
End If
Else
getFileSizeTranslated = ""
End If
End Function
Public Function getContentType(name)
If dict.Exists(name) Then
getContentType = dict(name).Item("ContentType")
Else
getContentType = ""
End If
End Function
Private Sub getData(rawData)
Dim separator
separator = MidB(rawData, 1, InstrB(1, rawData, ChrB(13)) - 1)
Dim lenSeparator
lenSeparator = LenB(separator)
Dim currentPos
currentPos = 1
Dim inStrByte
inStrByte = 1
Dim value, mValue
Dim tempValue
tempValue = ""
While inStrByte > 0
inStrByte = InStrB(currentPos, rawData, separator)
mValue = inStrByte - currentPos
If mValue > 1 Then
value = MidB(rawData, currentPos, mValue)
Dim begPos, endPos, midValue, nValue
Dim intDict
Set intDict = Server.CreateObject("Scripting.Dictionary")
begPos = 1 + InStrB(1, value, ChrB(34))
endPos = InStrB(begPos + 1, value, ChrB(34))
nValue = endPos
Dim nameN
nameN = MidB(value, begPos, endPos - begPos)
Dim nameValue, isValid
isValid = True
If InStrB(1, value, stringToByte("Content-Type")) > 1 Then
begPos = 1 + InStrB(endPos + 1, value, ChrB(34))
endPos = InStrB(begPos + 1, value, ChrB(34))
If endPos = 0 Then
endPos = begPos + 1
isValid = False
End If
midValue = MidB(value, begPos, endPos - begPos)
intDict.Add "FileName", trim(byteToString(midValue))
begPos = 14 + InStrB(endPos + 1, value, stringToByte("Content-Type:"))
endPos = InStrB(begPos, value, ChrB(13))
midValue = MidB(value, begPos, endPos - begPos)
intDict.Add "ContentType", trim(byteToString(midValue))
begPos = endPos + 4
endPos = LenB(value)
nameValue = MidB(value, begPos, ((endPos - begPos) - 1))
Else
nameValue = trim(byteToString(MidB(value, nValue + 5)))
End If
If isValid = True Then
intDict.Add "Value", nameValue
intDict.Add "Name", nameN
dict.Add byteToString(nameN), intDict
End If
End If
currentPos = lenSeparator + inStrByte
Wend
End Sub
End Class
Private Function stringToByte(toConv)
Dim tempChar
For i = 1 to Len(toConv)
tempChar = Mid(toConv, i, 1)
stringToByte = stringToByte & chrB(AscB(tempChar))
Next
End Function
Private Function byteToString(toConv)
For i = 1 to LenB(toConv)
byteToString = byteToString & Chr(AscB(MidB(toConv,i,1)))
Next
End Function
%>
Scorpyd Crossbows-Technology Beyond Evolution