%@ Language=VBScript %>
<%Response.buffer = true%>
<%
'--------------------------------------------------------------------
' Microsoft ADO
'
' (c) 1996 Microsoft Corporation. All Rights Reserved.
'
'
'
' ADO constants include file for VBScript
'
'--------------------------------------------------------------------
'---- CursorTypeEnum Values ----
Const adOpenForwardOnly = 0
Const adOpenKeyset = 1
Const adOpenDynamic = 2
Const adOpenStatic = 3
'---- CursorOptionEnum Values ----
Const adHoldRecords = &H00000100
Const adMovePrevious = &H00000200
Const adAddNew = &H01000400
Const adDelete = &H01000800
Const adUpdate = &H01008000
Const adBookmark = &H00002000
Const adApproxPosition = &H00004000
Const adUpdateBatch = &H00010000
Const adResync = &H00020000
'---- LockTypeEnum Values ----
Const adLockReadOnly = 1
Const adLockPessimistic = 2
Const adLockOptimistic = 3
Const adLockBatchOptimistic = 4
'---- CursorLocationEnum Values ----
Const adUseClient = 1
Const adUseServer = 2
Const adUseClientBatch = 3
'---- DataTypeEnum Values ----
Const adEmpty = 0
Const adTinyInt = 16
Const adSmallInt = 2
Const adInteger = 3
Const adBigInt = 20
Const adUnsignedTinyInt = 17
Const adUnsignedSmallInt = 18
Const adUnsignedInt = 19
Const adUnsignedBigInt = 21
Const adSingle = 4
Const adDouble = 5
Const adCurrency = 6
Const adDecimal = 14
Const adNumeric = 131
Const adBoolean = 11
Const adError = 10
Const adUserDefined = 132
Const adVariant = 12
Const adIDispatch = 9
Const adIUnknown = 13
Const adGUID = 72
Const adDate = 7
Const adDBDate = 133
Const adDBTime = 134
Const adDBTimeStamp = 135
Const adBSTR = 8
Const adChar = 129
Const adVarChar = 200
Const adLongVarChar = 201
Const adWChar = 130
Const adVarWChar = 202
Const adLongVarWChar = 203
Const adBinary = 128
Const adVarBinary = 204
Const adLongVarBinary = 205
'---- ConnectPromptEnum Values ----
Const adPromptAlways = 1
Const adPromptComplete = 2
Const adPromptCompleteRequired = 3
Const adPromptNever = 4
'---- ConnectModeEnum Values ----
Const adModeUnknown = 0
Const adModeRead = 1
Const adModeWrite = 2
Const adModeReadWrite = 3
Const adModeShareDenyRead = 4
Const adModeShareDenyWrite = 8
Const adModeShareExclusive = &Hc
Const adModeShareDenyNone = &H10
'---- IsolationLevelEnum Values ----
Const adXactUnspecified = &Hffffffff
Const adXactChaos = &H00000010
Const adXactReadUncommitted = &H00000100
Const adXactBrowse = &H00000100
Const adXactCursorStability = &H00001000
Const adXactReadCommitted = &H00001000
Const adXactRepeatableRead = &H00010000
Const adXactSerializable = &H00100000
Const adXactIsolated = &H00100000
'---- XactAttributeEnum Values ----
Const adXactPollAsync = 2
Const adXactPollSyncPhaseOne = 4
Const adXactCommitRetaining = &H00020000
Const adXactAbortRetaining = &H00040000
Const adXactAbortAsync = &H00080000
'---- FieldAttributeEnum Values ----
Const adFldBookmark = &H00000001
Const adFldMayDefer = &H00000002
Const adFldUpdatable = &H00000004
Const adFldUnknownUpdatable = &H00000008
Const adFldFixed = &H00000010
Const adFldIsNullable = &H00000020
Const adFldMayBeNull = &H00000040
Const adFldLong = &H00000080
Const adFldRowID = &H00000100
Const adFldRowVersion = &H00000200
Const adFldCacheDeferred = &H00001000
'---- EditModeEnum Values ----
Const adEditNone = &H0000
Const adEditInProgress = &H0001
Const adEditAdd = &H0002
'---- RecordStatusEnum Values ----
Const adRecOK = &H0000000
Const adRecNew = &H0000001
Const adRecModified = &H0000002
Const adRecDeleted = &H0000004
Const adRecUnmodified = &H0000008
Const adRecInvalid = &H0000010
Const adRecMultipleChanges = &H0000040
Const adRecPendingChanges = &H0000080
Const adRecCanceled = &H0000100
Const adRecCantRelease = &H0000400
Const adRecConcurrencyViolation = &H0000800
Const adRecIntegrityViolation = &H0001000
Const adRecMaxChangesExceeded = &H0002000
Const adRecObjectOpen = &H0004000
Const adRecOutOfMemory = &H0008000
Const adRecPermissionDenied = &H0010000
Const adRecSchemaViolation = &H0020000
Const adRecDBDeleted = &H0040000
'---- GetRowsOptionEnum Values ----
Const adGetRowsRest = -1
'---- PositionEnum Values ----
Const adPosUnknown = -1
Const adPosBOF = -2
Const adPosEOF = -3
'---- AffectEnum Values ----
Const adAffectCurrent = 1
Const adAffectGroup = 2
Const adAffectAll = 3
'---- FilterGroupEnum Values ----
Const adFilterNone = 0
Const adFilterPendingRecords = 1
Const adFilterAffectedRecords = 2
Const adFilterFetchedRecords = 3
'---- PropertyAttributesEnum Values ----
Const adPropNotSupported = &H0000
Const adPropRequired = &H0001
Const adPropOptional = &H0002
Const adPropRead = &H0200
Const adPropWrite = &H0400
'---- ErrorValueEnum Values ----
Const adErrInvalidArgument = &Hbb9
Const adErrNoCurrentRecord = &Hbcd
Const adErrIllegalOperation = &Hc93
Const adErrInTransaction = &Hcae
Const adErrFeatureNotAvailable = &Hcb3
Const adErrItemNotFound = &Hcc1
Const adErrObjectNotSet = &Hd5c
Const adErrDataConversion = &Hd5d
Const adErrObjectClosed = &He78
Const adErrObjectOpen = &He79
Const adErrProviderNotFound = &He7a
Const adErrBoundToCommand = &He7b
'---- ParameterAttributesEnum Values ----
Const adParamSigned = &H0010
Const adParamNullable = &H0040
Const adParamLong = &H0080
'---- ParameterDirectionEnum Values ----
Const adParamUnknown = &H0000
Const adParamInput = &H0001
Const adParamOutput = &H0002
Const adParamInputOutput = &H0003
Const adParamReturnValue = &H0004
'---- CommandTypeEnum Values ----
Const adCmdUnknown = 0
Const adCmdText = &H0001
Const adCmdTable = &H0002
Const adCmdStoredProc = &H0004
%>
<%
Sub drawAdObject(cf_id, activeCode)
'ADSERVER ADD-ON
if dLookUp("constants","ct_value","ct_id='adserv_mode'") = "1" then
call InsertAd(activeCode, dLookUp("constants","ct_value","ct_id='adserv_descr'"),cf_id)
end if
End Sub
Function IsAdvertisement(ad_id)
dim SQL, RS
set RS = Server.CreateObject("ADODB.RecordSet")
ad_id = ConvertToNum(ad_id)
SQL = "select count(AD_ID) as FLAG from ADS where AD_ID=" & ad_id
RS.Open SQL, Session("Con"),adOpenDynamic,adLockReadOnly
IsAdvertisement = RS("FLAG")
RS.Close
End Function
sub UpdateAdImpLogs(activeAd, ad_imp_date, ad_imp_day)
dim SQL, RS
dim ad_url
set RS = server.CreateObject("ADODB.RecordSet")
SQL = "SELECT ad_id, as_date, as_imp_day"
SQL = SQL & " FROM ads_daily_stats"
SQL = SQL & " WHERE ad_id=" & activeAd
SQL = SQL & " AND as_date=" & QueryDate(ad_imp_date)
RS.Open SQL, Session("Con"),adOpenDynamic,adLockOptimistic
if RS.eof then
RS.addnew
RS("ad_id") = activeAd
end if
RS("as_date") = ad_imp_date
RS("as_imp_day") = ad_imp_day
RS.Update
RS.Close
end sub
sub UpdateAdClicks(activeAd)
dim SQL, RS
dim ad_url
set RS = server.CreateObject("ADODB.RecordSet")
if activeAd="" then
exit sub
else
SQL = "SELECT ad_id, ad_click, ad_click_max, ad_url"
SQL = SQL & " FROM ads"
SQL = SQL & " WHERE ad_id=" & activeAd
SQL = SQL & " AND ad_status='1'"
RS.Open SQL, Application("Con"),adOpenDynamic,adLockOptimistic
if RS.EOF then
RS.Close
exit sub
else
ad_url = RS("ad_url")
RS("ad_click") = converttonum(RS("ad_click")) + 1
RS.Update
RS.Close
Response.Redirect ad_url
end if
end if
end sub
Sub UpdateAdStats(activeAd, activePosition)
dim SQL, RS
dim ad_system
dim maximpnow
set RS = server.CreateObject("ADODB.RecordSet")
SQL = "SELECT max(dp_imp) as maximp"
SQL = SQL & " FROM ads_2positions"
SQL = SQL & " WHERE ap_id=" & activePosition
RS.Open SQL, Session("Con"),adOpenDynamic,adLockReadOnly
If RS.EOF then
exit sub
else
maximpnow = RS("maximp")
RS.Close
end if
' Session("Con").BeginTrans
SQL = "SELECT dp_imp"
SQL = SQL & " FROM ads_2positions"
SQL = SQL & " WHERE ad_id=" & activeAd
SQL = SQL & " AND ap_id=" & activePosition
RS.Open SQL, Session("Con"),adOpenDynamic,adLockOptimistic
If RS.EOF then
' Session("Con").RollbackTrans
exit sub
else
RS("dp_imp") = maximpnow + 1 'maximize impressions in position in order not to be shown again soon
RS.Update
RS.Close
end if
SQL = "SELECT ad_id, ad_status,"
SQL = SQL & " ad_imp, ad_imp_day,"
SQL = SQL & " ad_imp_max, ad_imp_day_max, ad_imp_date,"
SQL = SQL & " ad_datt, ad_start, ad_end, ad_system, ad_status"
SQL = SQL & " FROM ads"
SQL = SQL & " WHERE ad_id=" & activeAd
RS.Open SQL, Session("Con"),adOpenDynamic,adLockOptimistic
If RS.EOF then
' Session("Con").RollbackTrans
exit sub
else
RS("ad_imp") = converttonum(RS("ad_imp")) + 1 ' one more impression for ad
If RS("ad_imp")="1" then
RS("ad_start") = now()
end If
' check for violation of impressions per day limit
If isnull(RS("ad_imp_date")) or RS("ad_imp_date")="" then
RS("ad_imp_date") = datevalue(now())
End if
If datevalue(RS("ad_imp_date")) = datevalue(now()) then
RS("ad_imp_day") = converttonum(RS("ad_imp_day")) + 1 ' one more impression for ad for today
Else
call UpdateAdImpLogs(activeAd, RS("ad_imp_date"), RS("ad_imp_day"))
RS("ad_imp_date") = datevalue(now())
RS("ad_imp_day") = 1 ' first impression for ad for today
End If
RS("ad_end") = now()
RS.Update
RS.Close
end if
'Session("Con").CommitTrans
'If err.number<>0 then
' Session("Con").RollbackTrans
'End If
end sub
Function DetermineAd(activePosition)
dim SQL, RS
dim activeAd, isValid
dim minimp
set RS = server.CreateObject("ADODB.RecordSet")
activeAd = -1
minimp = 0
SQL = "SELECT P.dp_imp, A.ad_id, ad_status,"
SQL = SQL & " ad_imp, ad_imp_day, ad_click,"
SQL = SQL & " ad_imp_max, ad_imp_day_max, ad_click_max, ad_imp_date,"
SQL = SQL & " ad_datf, ad_datt"
SQL = SQL & " FROM ads A, ads_2positions P"
SQL = SQL & " WHERE ad_status='1'"
SQL = SQL & " AND ad_datf<=" & QueryDate(now())
SQL = SQL & " AND A.ad_id=P.ad_id"
SQL = SQL & " AND P.ap_id=" & activePosition
RS.Open SQL, Session("Con"),adOpenDynamic,adLockReadOnly
while not RS.EOF
isValid = true
if not isnull(RS("ad_imp_max")) and converttonum(RS("ad_imp"))>=converttonum(RS("ad_imp_max")) then
isValid = false
end if
if (not isnull(RS("ad_imp_date"))) and RS("ad_imp_date")<>"" and datevalue(ConvertToDate(RS("ad_imp_date")))=datevalue(now()) then
if not isnull(RS("ad_imp_day_max")) and converttonum(RS("ad_imp_day"))>=converttonum(RS("ad_imp_day_max")) then
isValid = false
end if
end if
if not isnull(RS("ad_click_max")) and converttonum(RS("ad_click"))>converttonum(RS("ad_click_max")) then
isValid = false
end if
if ((not isnull(RS("ad_datt"))) and RS("ad_datt")<>"") and ConvertToDate(RS("ad_datt"))<=now() then
isValid = false
end if
If isValid and (converttonum(RS("dp_imp"))<=minimp or activeAd=-1) then
activeAd = RS("ad_id")
minimp = converttonum(RS("dp_imp"))
End if
RS.MoveNext
wend
RS.Close
DetermineAd = activeAd
End Function
sub InsertAd(activeCode, activeDescriptor, cf_id)
dim ap_id, ap_image_width, ap_image_height, ap_window
dim SQL, RS
set RS = server.CreateObject("ADODB.RecordSet")
SQL = "SELECT DISTINCT ap_id, ap_descr, ap_code, ap_descriptor, ap_category,"
SQL = SQL & " ap_image_width, ap_image_height, ap_window"
SQL = SQL & " FROM ads_positions"
SQL = SQL & " WHERE ap_code='" & activeCode & "'"
SQL = SQL & " AND ap_descriptor='" & activeDescriptor &"'"
RS.Open SQL, Session("Con"),adOpenDynamic,adLockReadOnly
if not RS.EOF then
ap_id = RS("ap_id")
ap_image_width = RS("ap_image_width")
ap_image_height = RS("ap_image_height")
ap_window = RS("ap_window")
RS.Close
else
RS.Close
exit sub
end if
ad_id = DetermineAd(ap_id)
if ad_id=-1 then exit sub
call UpdateAdStats(ad_id, ap_id)
if ap_window = 0 then
call ShowAd(ad_id, ap_id)
else
%>
<%
end if
end sub
Sub ShowAd(activeAd, activePosition)
dim SQL, RS
set RS = server.CreateObject("ADODB.RecordSet")
SQL = "SELECT ad_image, ad_descr, ad_image_width, ad_image_height,"
SQL = SQL & " ad_url, ad_alt, ad_target,"
SQL = SQL & " ap_image_width, ap_image_height, at_title, ap_window"
SQL = SQL & " FROM ads A, ads_2positions D, ads_positions P, ad_types T"
SQL = SQL & " WHERE P.ap_id=D.ap_id"
SQL = SQL & " AND A.ad_id=D.ad_id"
SQL = SQL & " AND A.ad_type=T.at_id"
SQL = SQL & " AND P.ap_id=" & activePosition
SQL = SQL & " AND A.ad_id=" & activeAd
RS.Open SQL, Session("Con"),adOpenDynamic,adLockReadOnly
if not RS.EOF then
'
select case RS("at_title")
case "image"
Response.Write ImageAd(activeAd, RS("ad_image"), RS("ad_image_width"), RS("ad_image_height"), RS("ad_url"), RS("ad_alt") ,RS("ad_target"), RS("ap_image_width"), RS("ap_image_height"), RS("ap_window"))
case "flash"
Response.Write FlashAd(activeAd, RS("ad_image"), RS("ad_image_width"), RS("ad_image_height"), RS("ad_url"), RS("ad_alt"), RS("ad_target"), RS("ap_image_width"), RS("ap_image_height"), RS("ap_window"))
end select
'
end if
RS.Close
End Sub
Function AdjustAdDimensions(im_width, im_height, pos_width, pos_height, pos_window)
dim mode
if ConvertToNum(pos_window)=0 then
if converttonum(im_width)=0 or converttonum(im_height)=0 then
mode = "position"
elseif converttonum(im_width)
<%
end if
end if
AdjustAdDimensions = mode
End Function
Function ImageAd(ad_id, im_file, im_width, im_height, im_url, im_alt, im_target, pos_width, pos_height, pos_window)
dim cmd, attr
dim width, height
cmd = ""http" then
attr = " src=""" & Application("Banners") & im_file & """"
else
attr = " src=""" & im_file & """"
end if
cmd = cmd & attr
' width, height
select case AdjustAdDimensions(im_width, im_height, pos_width, pos_height, pos_window)
case "position"
width = pos_width
height = pos_height
case "image"
width = im_width
height = im_height
case "scale"
width = pos_width
height = int(converttonum(im_height) * converttonum(pos_width)/converttonum(im_width))
end select
attr = " width=""" & width & """"
cmd = cmd & attr
attr = " height=""" & height & """"
cmd = cmd & attr
'alt
if im_alt<>"" then
attr = " alt=""" & im_alt & """"
cmd = cmd & attr
end if
cmd = cmd & " vspace=""0"""
cmd = cmd & ">"
if im_url<>"" then
attr = ""
cmd = attr & cmd
cmd = cmd & ""
end if
ImageAd = cmd
End Function
Function FlashAd(ad_id, im_file, im_width, im_height, im_url, im_alt, im_target, pos_width, pos_height, pos_window)
dim cmd, attr, plugin
dim width, height
plugin = " TYPE=""application/x-shockwave-flash"" PLUGINSPAGE=""http://www.macromedia.com/shockwave/download/index.cgi?P1_Prod_Version=ShockwaveFlash"""
cmd = cmd & ""
' 'alt
' if im_alt<>"" then
' attr = " alt=""" & im_alt & """"
' cmd = cmd & attr
' end if
' if im_url<>"" then
' attr = ""
' cmd = attr & cmd
' cmd = cmd & ""
' end if
FlashAd = cmd
End Function
%>
<%
'if InStr(1,UCase(Request.ServerVariables("path_info")),"CHAT")=0 then
'
'end if
'SQL INJECTION PRECAUSES
public function stripQuotes(strWords)
stripQuotes = replace(strWords, "'", "''")
end function
public function killChars(strWords)
dim badChars
dim newChars
badChars = array("select", "drop", ";", "--", "insert", "delete", "xp_")
newChars = strWords
for i = 0 to uBound(badChars)
newChars = replace(newChars, badChars(i), "")
next
killChars = newChars
end function
public function cleanMe(strWords)
dim cleanMeTemp
cleanMeTemp = strWords
cleanMeTemp = stripQuotes(cleanMeTemp)
cleanMeTemp = killChars(cleanMeTemp)
cleanMe = cleanMeTemp
end function
Function ConvertToString(s)
if isnull(s) then
ConvertToString = ""
else
ConvertToString = trim(s)
end if
End Function
function ConvertToNum(s)
if isnull(s) then
ConvertToNum = 0
else
if not isnumeric(s) then
ConvertToNum = 0
else
ConvertToNum = cdbl(s)
end if
end if
End function
Function ConvertToDate(d)
if isnull(d) or d="" then
ConvertToDate = ""
else
ConvertToDate = cdate(d)
end if
End Function
Sub AddToPending(fName)
dim tRS, SQL, id
set tRS = Server.CreateObject("ADODB.RecordSet")
SQL = "SELECT * FROM PENDING_OBJECTS" & " WHERE 1=0"
tRS.Open SQL,Session("Con"),adOpenDynamic,adLockOptimistic
id = GetNext(Left("PENDING_OBJECTS",12))
tRS.AddNew
tRS("PO_ID") = ID
tRS("PO_FILENAME") = fName
tRS("PO_STATUS") = "1"
tRS("CRD") = now
tRS("CHD") = now
tRS("CRUSER") = Session("US_ID")
tRS("CHUSER") = Session("US_ID")
tRS.Update
tRS.Close
set tRS = Nothing
End Sub
public Function DLookUp(TblName, ReturnField , WhereString)
Dim LookUpTBL
set LookUpTBL = Server.CreateObject("ADODB.RecordSet")
DIM LSQLQuery
DLookUp=""
LSQLQuery = "select " & ReturnField & " from " & TblName
if WhereString<>"" then LSQLQuery = LSQLQuery & " where " & WhereString
'Response.write LSQLQuery
LookUpTBL.Open LSQLQuery, Session("Con"), adOpenDynamic, adLockReadOnly
if (not LookUpTBL.EOF) then
dLookUp=ConvertToString(LookUpTBL(0))
end If
LookUpTBL.Close
set LookUpTBL=nothing
End Function
public Function LookUp(TblName, KeyField , ReturnField , KeyValue)
DIM LSQLQuery
Dim LookUpTBL
set LookUpTBL = Server.CreateObject("ADODB.RecordSet")
LookUp=""
LSQLQuery = "select " & ReturnField & " from " & TblName
if KeyValue<>"" and keyField<>"" then LSQLQuery = LSQLQuery & " where " & KeyField & "='" & KeyValue & "'"
'Response.write LSQLQuery
LookUpTBL.Open LSQLQuery, Session("Con"), adOpenDynamic, adLockReadOnly
if (not LookUpTBL.EOF) then
LookUp=ConvertToString(LookUpTBL(0))
end If
LookUpTBL.Close
set LookUpTBL=nothing
End Function
public Function LookUpNum(TblName, KeyField , ReturnField , KeyValue)
DIM LSQLQuery
Dim LookUpTBL
set LookUpTBL = Server.CreateObject("ADODB.RecordSet")
LookUpNum=""
IF KeyValue<>"" then
LSQLQuery = "select " & ReturnField & " from " & TblName & " where " & KeyField & "=" & KeyValue
LookUpTBL.Open LSQLQuery, Session("Con"), adOpenDynamic, adLockReadOnly
if (not LookUpTBL.EOF) then
LookUpNum=ConvertToString(LookUpTBL(ReturnField))
end If
LookUpTBL.Close
end if
set LookUpTBL=nothing
End Function
Public Function iif(c, a, b)
if c then
iif=a
else
iif=b
end if
End Function
Public Function VisitorNo()
dim rs, sql
if Session("VisitorNo") = 0 then
'Access Log
Session("VisitorNo") = GetNext("HITS")
set rs = Server.CreateObject("ADODB.RecordSet")
sql = "SELECT * FROM USER_ACCESS_LOG WHERE 1 = 0"
rs.Open SQL, Session("Con"), adOpenDynamic, adLockOptimistic
rs.AddNew
RS("UL_ID") = Session("VisitorNo")
RS("UL_DATE") = DateValue(Session("LoginTime"))
Rs("UL_TIME") = TimeValue(Session("LoginTime"))
Rs("UL_IP") = Request.ServerVariables("REMOTE_HOST")
rs.Update
rs.Close
end if
VisitorNo = Session("VisitorNo")
End Function
Public Function GetNext(CN_ID)
Dim getRS, getSQL
If CN_ID<>"" Then
set getRS = Server.CreateObject("ADODB.RecordSet")
getSQL = "SELECT * FROM COUNTERS WHERE CN_ID='" & CN_ID & "'"
getRS.open getSQL, Application("Con"), adOpenDynamic, adLockOptimistic
If not getRS.EOF Then
GetNext = getRS("CN_NVAL")
getRS("CN_NVAL") = getRS("CN_NVAL") + 1
getRS.Update
Else
GetNext = 1
getRS.AddNew
getRS("CN_ID") = left(CN_ID,12)
getRS("CN_DESCR") = CN_ID
getRS("CN_NVAL") = 2
getRS("CRUSER") = Session("US_ID")
getRS("CRD") = now()
getRS("CHUSER") = Session("US_ID")
getRS("CHD") = now()
getRS.Update
end if
getRS.close
End If
Set getRS = nothing
End Function
public Sub CloseSession()
dim rs, sql
if Session("VisitorNo") <> 0 then
'Access Log update
set rs = Server.CreateObject("ADODB.RecordSet")
sql = "SELECT * FROM USER_ACCESS_LOG WHERE UL_ID = " & Session("VisitorNo")
rs.Open SQL, Session("Con"), adOpenDynamic,adLockOptimistic
if not rs.EOF then
Rs("UL_DURATION") = DateDiff("m",Session("LoginTime"),Now())
if Rs("UL_DURATION")<=0 then Rs("UL_DURATION")=1
rs.Update
end if
rs.Close
end if
End Sub
Public Function DurationString(t1, t2)
Dim hours, minutes, secs
dif = DateDiff("s", cdate(t1), cdate(t2))
secs = dif mod 60
minutes = int(dif/60)
hours = int(minutes / 60)
minutes = minutes - hours * 60
DurationString=""
if hours>0 then DurationString = hours & "h "
if minutes>0 then DurationString = DurationString & minutes & "' "
if secs>0 then DurationString = DurationString & secs & "''"
End Function
Public Function UsDate(dat)
UsDate = Month(dat) & "/" & day(dat) & "/" & year(dat)
End Function
Public Function UsDateTime(dat)
UsDateTime = usDate(dat) & " " & hour(dat) & ":" & fixedDigits(minute(dat),2) & ":" & fixedDigits(second(dat),2)
End Function
Public Function QueryDate(dat)
QueryDate = "#" & UsDate(dat) & "#"
End Function
Public Function QueryDateTime(dat)
QueryDateTime = "#" & UsDateTime(dat) & "#"
End Function
Public Function UserIsMember(UG_USR_ID, US_ID)
dim SQL, RS
set RS = Server.CreateObject("ADODB.RecordSet")
SQL = "SELECT UG_USR_ID FROM USER_GROUPS, USER_GROUPS_REL "
SQL = SQL & "WHERE USER_GROUPS.UG_ID=USER_GROUPS_REL.UG_ID AND US_ID=" & US_ID
SQL = SQL & " AND UG_USR_ID='" & UG_USR_ID & "'"
RS.Open SQL, Session("Con"), adOpenDynamic, adLockReadOnly
UserIsMember = NOT RS.EOF
RS.CLOSE
SET RS = NOTHING
END Function
Function Max(a,b)
if ab then
Min = b
else
Min = a
end if
End Function
Function FixedDigits(m,NumberOfDigits)
dim i
FixedDigits = cstr(clng(m))
i=len(FixedDigits)-NumberOfDigits
if i>0 then
FixedDigits = string(i,"0") & FixedDigits
end if
End Function
Function FixedDecimals(m,NuberOfDecimals)
dim st, k, zerosToAdd
n = cdbl(m)
n = Round(n,NuberOfDecimals)
st = cstr(n)
k = instr(st,",")
if k = 0 then
zerosToAdd = NuberOfDecimals
else
zerosToAdd = NuberOfDecimals - (len(st) - k)
end if
if zerosToAdd=NuberOfDecimals then st = st & ","
for k = 1 to zerosToAdd
st = st & "0"
next
FixedDecimals = st
End Function
Function DottedNumber(n)
dim s, i, r, absNum, sign, nn
if isNull(n) then n = 0
nn = cdbl(n)
absNum = abs(nn)
if nn<0 then
sign = "-"
else
sign = ""
end if
s = cstr(absNum)
r = ""
for i = len(s) to 1 step -1
if (i-len(s)) mod 3 = 0 and i<>len(s) then r = "." & r
r = mid(s,i,1) & r
next
DottedNumber = "" & sign & r
End Function
Function Odd(n)
Odd = (n mod 2)=1
End Function
Function PartialString(s,i)
PartialString = Left(s,i)
End Function
Function gcd(x,y)
a=x
b=y
If a>0 and b>0 Then
While a<>b
If a>b Then
a=a-b
Else
b=b-a
End If
Wend
gcd=a
Else
gcd=1
End If
End Function
Function GetUser(userid)
dim userlogin, getSQL
Dim LookUpTBL
set LookUpTBL = Server.CreateObject("ADODB.RecordSet")
getSQL = "SELECT us_login FROM users WHERE us_id = " & userid
LookUpTBL.Open getSQL,Session("Con"),adOpenDynamic,adLockOptimistic
userlogin = Converttostring(LookUpTBL("us_login"))
LookUpTBL.Close
GetUser = userlogin
set LookUpTBL=nothing
End Function
Function ConvertToString_Dblquote(s)
if isnull(s) then
ConvertToString_Dblquote = ""
else
ConvertToString_Dblquote = trim(replace(s,"""","""))
end if
End Function
' =================================================================
' REVISED e-mail validation function =======================================
' =================================================================
Function IsValidEmail(strEmail)
' Dim bIsValid
' bIsValid = True
' If Len(strEmail) < 5 Then
' bIsValid = False
' Else
' If Instr(1, strEmail, " ") <> 0 Then
' bIsValid = False
' Else
' If InStr(1, strEmail, "@", 1) < 2 Then
' bIsValid = False
' Else
' If InStrRev(strEmail, ".") < InStr(1, strEmail, "@", 1) + 2 Then
' bIsValid = False
' End If
' End If
' End If
' End If
' IsValidEmail = bIsValid
IsValidEmail = RegExpTest(strEmail)
End Function
Function RegExpTest(sEmail)
RegExpTest = false
Dim regEx, retVal
' Create regular expression:
Set regEx = New RegExp
' Set pattern:
regEx.Pattern ="^[\w-\.]{1,}\@([\da-zA-Z-]{1,}\.){1,}[\da-zA-Z-]{2,3}$"
' Set case sensitivity.
regEx.IgnoreCase = true
' Execute the search test.
retVal = regEx.Test(sEmail)
If not retVal Then
exit function
End If
RegExpTest = true
End Function
'Function IsValidEmail(strEmail)
' Dim bIsValid
' bIsValid = True
'
' If Len(strEmail) < 5 Then
' bIsValid = False
' Else
' If Instr(1, strEmail, " ") <> 0 Then
' bIsValid = False
' Else
' If InStr(1, strEmail, "@", 1) < 2 Then
' bIsValid = False
' Else
' If InStrRev(strEmail, ".") < InStr(1, strEmail, "@", 1) + 2 Then
' bIsValid = False
' End If
' End If
' End If
' End If
'
' IsValidEmail = bIsValid
'Replaced by more professional function in 13/01/2006 by skotro
' IsValidEmail = RegExpTest(strEmail)
'End Function
Function ConvertToDBString(s)
if trim(s)="" then
ConvertToDBString = null
else
ConvertToDBString = trim(s)
end if
End Function
'CONTENT MANAGEMENT ADD-ONS
Sub ReleasePending(FileNameList)
dim globCMD, getSQL
set globCMD = server.CreateObject("ADODB.Command")
getSQL = "DELETE FROM PENDING_OBJECTS WHERE PO_FILENAME IN (" & FileNameList & ")"
globCMD.ActiveConnection = session("Con")
globCMD.CommandText = getSQL
globCMD.Execute
set globCMD = nothing
End Sub
Sub AddErrMessage(ErrMessage_string,Message)
ErrMessage_string = ErrMessage_string & "
" & Message & vbCrLf & vbCrLf
End Sub
Sub DisplayErrorPage(EMessage, ETarget)
Session("ErrorMessage") = EMessage
Session("ErrorTarget") = ETarget
Response.Redirect Application("Manage") & "ErrorPage.asp"
Response.End
End Sub
Sub DropDownFromTable(table, id, id_value, code, descr, SQLorder)
dim SQLdd, RSdd
set RSdd = server.CreateObject("ADODB.RecordSet")
SQLdd = "SELECT " & id & ", " & descr
if code<>"" then SQLdd = SQLdd & ", " & code
SQLdd = SQLdd & " FROM " & table
if SQLorder<>"" then SQLdd = SQLdd & " ORDER BY " & SQLorder
RSdd.Open SQLdd,session("Con"),adOpenDynamic,adLockReadOnly
while not RSdd.EOF
%>
<%RSdd.MoveNext
wend
RSdd.Close
set RSdd = nothing
End sub
%>
<%
Function CheckAccess(Login, Password)
dim RS, SQL
CheckAccess = false
SQL = "select us_id, us_login, us_password from users where us_login='" & cleanme(Trim(LOGIN)) & "' "
SQL = SQL & "and us_password='" & cleanMe(Trim(PASSWORD)) & "' "
set rs = server.createObject("ADODB.RecordSet")
Rs.Open SQL, session("Con"),adOpenDynamic,adLockReadOnly
CheckAccess = not Rs.EOF
if not Rs.EOF then
CheckAccess = cleanMe(trim(password)) = ConvertToString(rs("US_PASSWORD"))
if CheckAccess then
Session("US_ID") = clng(RS("US_ID"))
Session("Login")=cleanMe(Trim(Request("Login")))
Session("password")=cleanMe(Trim(Request("Password")))
end if
end if
Rs.Close
Session("AccessChecked")=true
End Function
Function CheckPassword(US_ID, Password, Full)
dim RS, SQL, login
CheckPassword=FALSE
SQL = "select us_password, us_login from users where us_id=" & cleanMe(US_ID)
set rs = server.createObject("ADODB.RecordSet")
Rs.Open SQL, session("Con"),adOpenDynamic,adLockReadOnly
IF not Rs.EOF THEN
if Full then
CheckPassword = Password=ConvertToString(rs("US_PASSWORD"))
else
if len(Password)=1 then
CheckPassword = Password=Mid(ConvertToString(rs("US_PASSWORD")),Left(cstr(us_id),1),1)
Response.Cookies("Control").Expires = DateAdd("m",6,Date())
Response.Cookies("Control")("I") = us_id
Response.Cookies("Control")("P") = PartialString(ConvertToString(rs("US_PASSWORD")),5)
else
CheckPassword = Password=PartialString(ConvertToString(rs("US_PASSWORD")),5)
end if
end if
login = ConvertToString(Rs("US_LOGIN"))
Password = ConvertToString(Rs("US_PASSWORD"))
End If
Rs.Close
if CheckPassword then
Session("US_ID")=US_ID
Session("Login")=Login
Session("Password")=Password
end if
End Function
Function CheckStoredAccess()
dim US_ID, PWD
US_ID=Request.Cookies("Control")("I")
if cstr(US_ID)<>"" then
PWD = Request.Cookies("Control")("P")
CheckStoredAccess=CheckPassword(US_ID, PWD, false)
else
CheckStoredAccess=false
end if
Session("AccessChecked")=true
End Function
Sub LoadGroups(US_ID)
dim SQL, RS
SET RS = Server.CreateObject("ADODB.RecordSet")
SQL = "SELECT UG_USR_ID FROM USER_GROUPS, USER_GROUPS_REL WHERE US_ID=" & US_ID & " AND USER_GROUPS.UG_ID=USER_GROUPS_REL.UG_ID"
Rs.Open sql, session("Con"),adOpenDynamic,adLockReadOnly
While not Rs.EOF
Session(RS("UG_USR_ID")) = true
Rs.MoveNext
wend
Rs.Close
End Sub
Sub InitConnection()
dim SQL, RS
SET RS = Server.CreateObject("ADODB.RecordSet")
sql = "select us_id from user_access_log where ul_id=" & VisitorNo()
Rs.Open sql, session("Con"),adOpenDynamic,adLockOptimistic
if not Rs.EOF then
rs("us_id") = Session("us_id")
Rs.Update
end if
Rs.Close
call LoadGroups(Session("us_id"))
SQL = "SELECT * FROM BOARD_USERS WHERE BR_ID=0 AND US_ID=" & Session("us_id")
Rs.Open SQL,SESSION("CON"),adOpenDynamic,adLockOptimistic
IF Rs.EOF THEN
Rs.AddNew
rs("BR_ID")=0
RS("US_ID")=Session("us_id")
Rs.Update
END IF
Rs.Close
End Sub
%>
<%
if Application("OnLine")<>true then
Session.Timeout = 1
Response.redirect Application("Root") & "welcome_temp.asp"
end if
if Session("VisitorNo") = 0 then
Call VisitorNo()
end if
if Session("AccessChecked")<>true then
if CheckStoredAccess() then
call InitConnection()
Session("UserWelcomed") = true
end if
end if
Session("UserWelcomed")=true
'pop-up for new SMS
if Session("US_ID")>0 THEN
LastSMS = ConvertToNum(dLookUp("MESSAGES","MAX(MS_ID)","MS_RECEIVER=" & Session("US_ID") & " AND MS_READ='0'"))
if LastSMS>Session("LastSMS") and LastSMS>0 then
Session("LastSMS")=LastSMS%>
<%
end if
end if
%>
<%
dim RS, SQL, I, lastDescr
set RS = Server.CreateObject("ADODB.RecordSet")
if Session("US_ID")=0 then Response.redirect Application("Root") end if
%>
ΝΥΓΜΑ: ΟΡΟΙ ΦΥΛΑΞΗΣ ΔΕΔΟΜΕΝΩΝ
ΜΕΛΗ ΟΡΟΙ ΦΥΛΑΞΗΣ ΔΕΔΟΜΕΝΩΝ
Το ΝΥΓΜΑ σέβεται το απόρρητο των προσωπικών στοιχείων που καταχωρούν
τα μέλη του κατά την οποιαδήποτε συναλλαγή τους με τον ηλεκτρονικό τόπο.
Σε καμία περίπτωση δεν προτίθεται να τα δημοσιοποιήσει, να τα επεξεργαστεί,
να τα μαγειρέψει ή ο,τιδήποτε άλλο βάζει ο νους του (κακού) ανθρώπου.
Τα προσωπικά αυτά δεδομένα (είναι και της μόδας ο όρος) διατηρούνται
στη βάση του ΝΥΓΜΑτος και χρησιμοποιούνται αποκλειστικά και μόνο για τη
διαμόρφωση της ηλεκτρονικής σελίδας ανάλογα με τις δηλωθείσες προτιμήσεις
και την τήρηση στατιστικών στοιχείων επισκεψιμότητας των σελίδων του τόπου.
Σε οποιαδήποτε χρονική στιγμή τα μέλη του ΝΥΓΜΑτος διατηρούν το δικαίωμα
ενημέρωσης ή και αντίρρησης στην περαιτέρω επεξεργασία των προσωπικών
τους στοιχείων βάσει του άρθρου 13 του νόμου 2472/97.