<%option Explicit%>
<%
' Generic Database - Edit Record
' Notice: (c) 1998, 1999, 2000 Eli Robillard, All Rights Reserved.
' E-Mail: erobillard@ofifc.org
' URL: http://www.ofifc.org/Eli/ASP/
' Revision History:
' 23 May 2000 - dbUpdateField required that the field to be updated was also displayed, now it doesn't.
' 22 May 2000 - Fixed a ucase reference to "table" which expected it to be "TABLE"
' 22 Mar 2000 - Can now do advanced search on numeric combo/lookup boxes
' 17 Mar 2000 - Preserve dbWhere settings for Lister after viewing the edit screen
' Only update fields specified as editable in dbDispEdit (1)
' Changed default font string from "Verdana, Arial, Helvetica" to "Arial" to cut size
' 13 Mar 2000 - Simplified Search case
' 29 Feb 2000 - Fixed display of null strings
' 17 Feb 2000 - Key fields no longer required to be random autonumber, though this is not advised.
' No support will be provided to people who use this feature.
' 16 Feb 2000 - "true" comparison fixed for bDoValidation
' 07 Feb 2000 - Search on booleans added to Advanced Search by Bill Woodland
' Session("dbBoolean")="CHECKBOX" option added by Bill Woodland, default to radio buttons
' 24 Jan 2000 - Data validation by Grant Wilson added with minor modifications.
' 21 Jan 2000 - OLEDB Connection Support
' Empty numbers now initialized to Null rather than 0, suggested by Trevor Gould
' 9 Sep 1998 - First created or released
' Prevent caching
Response.Buffer = true
Response.ExpiresAbsolute = Now() - 1
Response.AddHeader "cache-control", "must-revalidate"
Response.AddHeader "cache-control", "private"
Response.AddHeader "pragma", "no-cache"
' Var declaration
DIM Action, caseAddValue, caseUpdateValue, formAction, IsSubTable, IsSearch, QUOTE, SubmitValue, tFld, tlkpRs, xconn, xrs, x, y, z
DIM aFields, arrCombo, arrErrMessage, arrFieldNames, arrSubTable
DIM strBorderColor, strCMD, strCombo, strComboTable, strComboDescFldNo, strComboDescDefault, strComboValueDefault, strComboValueFldNo, strConn, strDefault, strDisplay, strFields, strFont, strKey, strKeyField, strMenuColor, strMenuTextColor, strRequiredFields, strTable, strType, strsql
DIM intFontSize, intFieldCount, intdisplayMode
DIM bDoValidation, bError, sErrNText, sErrSText, sErrDText
' Language Translation
if txtUpdate & "x" = "x" then %>
ErrorGenericDB Language File Missing. Find it at: <%
end if
' Set any language defs not defined (i.e. foreign language file needs updationg)
'if txtdontCare & "x" = "x" then ' Mar 22 2000
' Dim txtdontCare, txtSearch
' txtdontCare = "Don't Care"
' txtSearch = "Search"
'end if
' Check for an active session
if Session("dbConn") & "x" = "x" then
Response.Clear
Response.Redirect "GenericError.asp"
end if
' Get info from Session vars (kinda like parameters)
strType = Trim(Ucase(Session("dbType")))
strConn = Session("dbConn")
strTable = Session("dbRs")
strFields = Session("dbFields")
strDisplay = Session("dbDispEdit")
strKeyField = Session("dbKey")
strFont = Session("dbFont")
intFontSize = Session("dbFontSize")
strBorderColor = Session("dbBorderColor")
strMenuColor = Session("dbMenuColor")
strMenuTextColor = Session("dbMenuTextColor")
IsSubTable = Session("dbIsSubTable")
IsSearch = false
QUOTE = chr(34)
formAction = "GenericEdit.asp"
Action = "GET"
' Data validation, init vars
strRequiredFields = Session("dbRequiredFields")
bError = false
sErrNText = "Number required"
sErrSText = "Entry required"
sErrDText = "Date required"
SubmitValue = txtUpdate
caseUpdateValue = Ucase(Left(txtUpdate,3))
caseAddValue = Ucase(Left(txtAdd,3))
' Check and set fonts and colours
if strFont & "x" = "x" then strFont = "Arial"
if Not (intFontSize > 0) then intFontSize = 2
if strBorderColor & "x" = "x" then strBorderColor = "#99CCCC"
if strMenuColor & "x" = "x" then strMenuColor = "#99CCCC"
if strMenuTextColor & "x" = "x" then strMenuTextColor = "Black"
if strFields & "x" = "x"then strFields = "*"
if Request.QueryString("KEY").Count > 0 then
' Quick security check for Edit rights
if Not(Session("dbCanEdit") = 1) then
Response.Clear
Response.Redirect Session("dbViewPage")
end if
strKey = Request.QueryString("KEY")
Session("dbcurKey") = strKey
Action = "GET"
elseif Request.QueryString("CMD").Count > 0 then
strCMD = Request.QueryString("CMD")
' Quick security check for Add rights
select case strCmd
case "NEW"
if (Session("dbCanAdd") = 1) then
Action = "NEW"
if NOT (Session("dbDispNew") & "x" = "x") then strDisplay = Session("dbDispNew")
else
Response.Clear
Response.Redirect Session("dbViewPage")
end if
case "SEARCH"
Action = "SEARCH"
strDisplay = Session("dbSearchFields")
formAction = "GenericSearchResult.asp?SearchAction=FULL"
SubmitValue = txtSearch
strKeyField = ""
IsSearch = true
End Select
else
Action = Left(Ucase(Request.form("Action")),3)
end if
' Open Connection to the database
set xConn = Server.CreateObject("ADODB.Connection")
xConn.Open strConn
' Open Recordset and get the field info
strsql = "select " & strFields & " FROM [" & strTable & "]"
select case strType
case "UDF"
strsql = "select " & strFields & " FROM " & strTable
case "SQL"
strsql = Replace(strsql,"[","")
strsql = Replace(strsql,"]","")
End Select
set xrs = Server.CreateObject("ADODB.Recordset")
xrs.Open strsql, xConn
intFieldCount = xrs.Fields.Count
ReDim aFields(intFieldCount,4)
if Trim(Session("dbFieldNames")) & "x" = "x" then
ReDim arrFieldNames(intFieldCount)
for x = 1 to intFieldCount
aFields(x, 1) = xrs.Fields(x-1).Name
aFields(x, 2) = xrs.Fields(x-1).Type
aFields(x, 3) = xrs.Fields(x-1).DefinedSize
arrFieldNames(x-1) = xrs.Fields(x-1).Name
next
else
for x = 1 to intFieldCount
aFields(x, 1) = xrs.Fields(x-1).Name
aFields(x, 2) = xrs.Fields(x-1).Type
aFields(x, 3) = xrs.Fields(x-1).DefinedSize
next
arrFieldNames = Split(Session("dbFieldNames"), ",")
end if
xrs.Close
Set xrs = Nothing
' If dbDispEdit not set in config file, allow all fields
if strDisplay & "x" = "x" then strDisplay = String(intFieldCount,"1")
' Load the results of the last form view (GET or UPDATE)
for x = 1 to intFieldCount
aFields(x,4) = Request.form(aFields(x,1))
next
select case Action
case caseAddValue ' Insert the new record into the database
' Run through fields and check values
ReDim arrErrMessage(intFieldCount)
for x = 1 to intFieldCount
bDoValidation = false
if Mid(strRequiredFields, x, 1) = "1" then bDoValidation = true
select case aFields(x, 2)
case 2, 3, 4, 5, 6, 17 ' 2 Byte Integer, 4 Byte Integer, Currency, Byte
tFLD = aFields(x,4)
y = Null
' Data validation
if bDoValidation AND ((NOT IsNumeric(tFLD)) OR (tFLD & "x" = "x")) then
bError = true
arrErrMessage(x)=sErrNText
end if
if IsNumeric(tFLD) then
aFields(x,4) = tFLD
else
aFields(x,4) = y
end if
case 11 ' Boolean true/false
if aFields(x,4) = "Yes" then
aFields(x,4) = true
else
aFields(x,4) = false
end if
case 129, 130, 200, 201, 202, 203, 204
' Char, WChar, VarChar, LongVarChar (Memo), VarWChar (Unicode String), LongVarWChar
aFields(x,4) = Replace(aFields(x,4),chr(34),""")
aFields(x,4) = Replace(aFields(x,4),"#include","")
aFields(x,4) = Replace(aFields(x,4),"<","<")
aFields(x,4) = Replace(aFields(x,4),">",">")
tFLD = Trim(aFields(x,4))
' Data validation
if bDoValidation AND (tFLD & "x" = "x") then
bError = true
arrErrMessage(x)=sErrSText
end if
if tFLD & "x" = "x" then tFLD = Null
aFields(x,4) = tFLD
case 7, 135 ' Date / Time Stamp, usually created with the Now() function
tFLD = Trim(aFields(x,4))
' Data validation
if bDoValidation AND ((NOT IsDate(tFld)) OR (tFld & "x" = "x")) then
bError = true
arrErrMessage(x)=sErrDText
end if
if (aFields(x,4) & "x" = "x") OR NOT IsDate(aFields(x,4)) then
aFields(x,4) = Null
else
aFields(x,4) = CDate(aFields(x,4))
end if
End Select
next
if NOT bError then
' if all required fields were entered, insert the record
Set xrs = Server.CreateObject("ADODB.Recordset")
' 2 for Open Dynamic, 3 for Optimistic Locking, 2 for Table
xrs.Open strTable, xConn, 2, 3, 2
xrs.AddNew
' Store the values to the table
for x = 1 to intFieldCount
if CInt(x) = CInt(strKeyField) then
' Do nothing if the key is numeric, it should be a counter field
' Some people insist on using keys which aren't enforceable (char, int, etc.), so let them blow their data up:
Select Case aFields(x,2)
Case 129, 130, 200, 201, 202, 203, 204
xrs.Fields(x-1) = aFields(x,4)
End Select
else
xrs.Fields(x-1) = aFields(x,4)
end if
next
On Error Resume next
xrs.Update
' Call Error Handler if update bombs
if Err.Number <> 0 then
Session("ErrNumber") = 99
Session("ErrDesc") = Err.Description
Session("ErrSource") = Err.Source
Session("ErrLine") = Err.Line
Session("ErrMsg") = "Query: " & strsql
Response.Clear
Response.Redirect "GenericError.asp"
end if
xrs.Close
Set xrs = Nothing
xConn.Close
Set xConn = Nothing
Response.Clear
if Session("dbOnlyAdd") = 1 then Response.Redirect Session("dbExitPage")
Response.Redirect Session("dbViewPage")
else
' Offer an ADD button again
SubmitValue = txtAdd
if Session("dbDispNew") & "x" ="x" then
strDisplay = Session("dbDispEdit")
else
strDisplay = Session("dbDispNew")
end if
end if
case "NEW": ' Load a blank form
SUBMITvalue = txtAdd
' Initialize Fields
for x = 1 to intFieldCount
if strKeyField = aFields(x,1) then
' Don't try to change the counter
else
' Check if a default has been specified
strDefault = "dbDefault" & x
if Session(strDefault) & "x" = "x" then
select case aFields(x, 2)
case 2, 3, 4, 5, 6, 131 ' Numeric types
aFields(x,4) = Null
case 11 ' Boolean true/false
aFields(x,4) = "No"
case 129, 130, 200, 201, 202, 203, 204 ' String types
aFields(x,4) = ""
case 7, 135 ' Date / Time Stamp
aFields(x,4) = ""
End Select
else
aFields(x,4) = Session(strDefault)
end if
if IsSubTable then
arrSubTable = Split(Session("dbSubTableCopy"),",")
' Suggested by Paul Reith:
if Trim(aFields(x,1)) = Trim(arrSubTable(2)) then aFields(x,4) = Session("dbsubkey")
end if
end if
next
case "SEARCH" ' Opening as a search, designed by Grant Wilson
SUBMITvalue = txtSearchSubmit
' Initialise Fields
for x = 1 to intFieldCount
aFields(x,4) = ""
if aFields(x,2) = 11 then aFields(x,4) = "No"
next
case "GET": ' Get a record to display
strsql = "select " & strFields & " FROM [" & strTable & "] WHERE [" & aFields(strKeyField,1) & "]=" & strKey
if strType = "SQL" then
' SQL databases do not allow spaces or brackets in table or field names
strsql = Replace(strsql,"[","")
strsql = Replace(strsql,"]","")
end if
set xrs = Server.CreateObject("ADODB.Recordset")
xrs.Open strsql, xConn
if xrs.EOF then
Response.Clear
if (Session("dbOnlyAdd")=1) OR (Session("dbOnlyEdit")=1) then Response.Redirect Session("dbExitPage")
Response.Redirect Session("dbViewPage")
end if
xrs.MoveFirst
' Get the field contents
for x = 1 to intFieldCount
if aFields(x,2) = 11 then
if xrs(x-1) then
aFields(x,4) = "Yes"
else
aFields(x,4) = "No"
end if
else
aFields(x,4) = xrs(x-1)
end if
next
xrs.Close
Set xrs = Nothing
case caseUpdateValue: ' Update
' Open record
strsql = "select " & strFields & " FROM [" & strTable & "] WHERE [" & aFields(strKeyField,1) & "]=" & Session("dbcurKey")
if strType = "SQL" then
strsql = Replace(strsql,"[","")
strsql = Replace(strsql,"]","")
end if
set xrs = Server.CreateObject("ADODB.Recordset")
xrs.Open strsql, xConn, 1, 2
if xrs.EOF then
Response.Clear
Response.Redirect Session("dbGenericPath") & "GenericList.asp"
end if
ReDim arrErrMessage(intFieldCount)
for x = 1 to intFieldCount
bDoValidation = false
if Mid(strRequiredFields, x, 1) = "1" then bDoValidation = true
' Check if a forced update value has been specified with dbUpdateFieldx
strDefault = "dbUpdateField" & x
' OLD: if Session(strDefault) & "x" = "x" then
' TWG: If no default AND what was entered is different from what was there.
' Response.write aFields(x,4) & " "
' if (Session(strDefault) & "x" = "x") OR Len(aFields(x,4)) > 0) AND (xrs(x-1) & "" <> aFields(x,4) & "") then
if (Session(strDefault) & "x" = "x") then
if strKeyField = x then
' For people who don't use enforceably unique keyfields (bad, very bad)
Select Case aFields(x,2)
Case 129, 130, 200, 201, 202, 203, 204 ' string types
xrs(x-1) = tFLD
End Select
elseif Mid(strDisplay, x, 1) = "1" then ' only bother with the ones we've allowed edits on
select case aFields(x,2)
case 2, 17 ' 2 Byte Integer, 1 Byte Integer
tFLD = aFields(x,4)
if bDoValidation AND (NOT IsNumeric(tFLD) OR Trim(tFLD) & "x" = "x") then ' Data validation
bError = true
arrErrMessage(x)=sErrNText
end if
if IsNumeric(tFLD) then
xrs(x-1) = CInt(tFLD)
else
xrs(x-1) = Null
end if
case 3 ' 4 Byte Integer
tFLD = aFields(x,4)
if bDoValidation AND (NOT IsNumeric(tFLD) OR Trim(tFLD) & "x" = "x") then ' Data validation
bError = true
arrErrMessage(x)=sErrNText
end if
if IsNumeric(tFLD) then
xrs(x-1) = CLng(tFLD)
else
xrs(x-1) = Null
end if
case 4 ' Single-Precision Floating Point
tFLD = aFields(x,4)
if bDoValidation AND (NOT IsNumeric(tFLD) OR Trim(tFLD) & "x" = "x") then ' Data validation
bError = true
arrErrMessage(x)=sErrNText
end if
if IsNumeric(tFLD) then
xrs(x-1) = CSng(tFLD)
else
xrs(x-1) = Null
end if
case 5, 6, 131 ' Double-Precision Floating Point, Currency, adNumeric
tFLD = aFields(x,4)
if bDoValidation AND (NOT IsNumeric(tFLD) OR Trim(tFLD) & "x" = "x") then ' Data validation
bError = true
arrErrMessage(x)=sErrNText
end if
if IsNumeric(tFLD) then
xrs(x-1) = CDbl(tFLD)
else
xrs(x-1) = Null
end if
case 7, 135 ' Date / Time Stamp, usually created with the Now() function
tFLD = Trim(aFields(x,4))
if bDoValidation AND ((NOT IsDate(tFld)) OR (Trim(tFld) & "x" = "x")) then
bError = true
arrErrMessage(x)=sErrDText
end if
if IsDate(aFields(x,4)) then
xrs(x-1) = CDate(aFields(x,4))
else
xrs(x-1) = Null
end if
case 11
' Boolean true/false
tFLD = aFields(x,4)
if tFLD = "Yes" then
xrs(x-1) = true
else
xrs(x-1) = false
end if
case 129, 130, 200, 201, 202, 203, 204
' All string types
tFLD = Trim(aFields(x,4))
tFLD = Replace(tFLD,chr(34),""")
tFLD = Replace(tFLD,"<","<")
tFLD = Replace(tFLD,">",">")
' Data validation
if bDoValidation AND (Trim(tFLD) & "x" = "x") then
bError = true
arrErrMessage(x)=sErrSText
end if
if Trim(tFLD) & "x" = "x" then tFLD = Null
Response.Write aFields(x,1)
xrs(x-1) = tFLD
End Select
end if
else ' dbUpdateFieldx is specified
xrs(x-1) = Session(strDefault)
end if
next
if not bError then ' No trouble with validation
xrs.Update
xrs.Close
Set xrs = Nothing
xConn.Close
Set xConn = Nothing
Response.Clear
if Session("dbOnlyEdit") = 1 then Response.Redirect Session("dbExitPage")
Response.Redirect Session("dbGenericPath") & "GenericList.asp"
else ' Don't save, offer the UPDATE button again with the error messages
SubmitValue = txtUpdate
xrs.Update
xrs.Close
Set xrs = Nothing
' Leave connection open until end of page
end if
End Select
%>
<%=Session("dbTitle")%> - <%=txtEditMode%>
<% If Session("dbBodyTag") & "x" <> "x" Then
Response.Write ""
Else %>
<% if Session("dbHeader") = 1 then %>
<% end if %>