File: D:/HostingSpaces/RImmers/duitsedog.tk/wwwroot/includes/inc_sql.asp
<%
REM -- ADO command types
const adCmdText = 1
const adCmdTable = 2
const adCmdStoredProc = 4
const adCmdUnknown = 8
REM -- ADO cursor types
const adOpenForwardOnly = 0 '# (Default)
const adOpenKeyset = 1
const adOpenDynamic = 2
const adOpenStatic = 3
REM -- ADO cursor locations
const adUseServer = 2 '# (Default)
const adUseClient = 3
REM -- ADO lock types
const adLockReadOnly = 1
const adLockPessimistic = 2
const adLockOptimistic = 3
const adLockBatchOptimistic = 4
REM -- DataTypeEnum Values
const adVarChar = 200
const adChar = 129
const adInteger = 3
const adDBDate = 133
const adBinary = 128
const adCurrency = 6
const adBoolean = 11
const adNumeric = 131
const adSingle = 4
const adDouble = 5
REM -- ParameterDirectionEnum Values
const adParamUnknown = &H0000
const adParamInput = &H0001
const adParamOutput = &H0002
const adParamInputOutput = &H0003
const adParamReturnValue = &H0004
REM -- ExecuteOptionEnum Values
Const adAsyncExecute = 16
Const adAsyncFetch = 32
Const adAsyncFetchNonBlocking = 64
Const adExecuteNoRecords = 128
Const adBookmarkCurrent = 0
%>
<SCRIPT LANGUAGE=JScript RUNAT=Server>
function y2k(number) {
return (number < 1000) ? number + 1900 : number;
}
function milliDif() {
var d = new Date();
return d.getTime()
}
function elapsedpretty(parm1)
{
var elapsedsecs = 0
var elapsedmins = 0
elapsedsecs=Math.floor(parm1/1000)
parm1=parm1%1000
elapsedmins=Math.floor(elapsedsecs/60)
elapsedsecs=elapsedsecs%60
elapsedpretty=elapsedmins + " minute"
if(elapsedmins!=1)
elapsedpretty=elapsedpretty+"s"
elapsedpretty = elapsedpretty+" " + elapsedsecs+" second"
if(elapsedsecs!=1)
elapsedpretty=elapsedpretty+"s"
elapsedpretty = elapsedpretty+ " "+parm1+" millisecond"
if(parm1!=1)
elapsedpretty=elapsedpretty+"s"
return elapsedpretty;
}
function elapsedshort(parm1)
{
return parm1+" ms"
}
</script>
<%
Sub txtLog(ByVal txt)
If True Then
Const strFile = "D:\HostingSpaces\RImmers\duitsedog.tk\wwwroot\logs\duitsedog.txt"
Dim fso, MyFile
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FileExists(strFile) Or Application("intLogLines") > 200 Then
Application("intLogLines") = 0
Set MyFile = fso.CreateTextFile(strFile,True)
Else
Set MyFile = fso.OpenTextFile(strFile,8)
End If
MyFile.WriteLine(now & " " & Request.ServerVariables("REMOTE_HOST") & " " & txt)
MyFile.Close
Application("intLogLines") = Application("intLogLines") + 1
End If
End Sub
Sub SendInfoMail(ByVal Subject, ByVal Msg)
On Error Resume next
txtLog "SendInfoMail(" & Subject & "," & Msg & ")"
Dim myMail
Set myMail = CreateObject("CDO.Message")
myMail.Subject = Subject
myMail.From = "noreply@yoda-ict.nl"
myMail.To = "robert.immers@gmail.com"
myMail.HTMLBody = Msg
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") = "localhost"
'Server port
myMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
myMail.Configuration.Fields.Update
myMail.Send
set myMail = nothing
End Sub
Sub SendWebsiteData(ByVal strUrl, ByVal strSubject)
On Error Resume next
txtLog "SendWebsiteData(" & strUrl & "," & strSubject & ")"
Dim myMail
Set myMail = CreateObject("CDO.Message")
myMail.Subject = strSubject
myMail.From = "noreply@yoda-ict.nl"
myMail.To = "robert.immers@gmail.com"
myMail.HTMLBody = strUrl
' onderstaande werkt niet bij ANWB site
myMail.CreateMHTMLBody strUrl
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") = "localhost"
'Server port
myMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
myMail.Configuration.Fields.Update
myMail.Send
set myMail = nothing
End Sub
Sub SendMail(ByVal Subject, ByVal Msg)
If True Then
On Error Resume next
txtLog "SendMail(" & Subject & "," & Msg & ")"
Dim myMail
Set myMail = CreateObject("CDO.Message")
myMail.Subject = Subject
myMail.From = "noreply@yoda-ict.nl"
myMail.To = "ddoggenlog@gmail.com"
myMail.TextBody = Msg
myMail.HTMLBody = Msg
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") = "localhost"
'Server port
myMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
myMail.Configuration.Fields.Update
myMail.Send
set myMail = nothing
End If
End Sub
Function CheckDB()
Dim connState, comm, commState
on error resume next
txtLog "CheckDB()"
If Not Session("blnInTransaction") Then
Set Session("objDB") = Server.CreateObject("ADODB.Connection")
Session("objDB").Open Application("stoeligans_ConnectionString")
End If
select case Session("objDB").State
case 0: connState = "The Connection object is closed"
case 1: connState = "The Connection object is open"
case 2: connState = "The Connection object is connecting"
case 4: connState = "The Connection object is executing a command"
case 8: connState = "The rows of the Connection object are being retrieved"
case else connState = "Connection:" & Session("objDB").State
End Select
txtLog "CheckDB() connstate = " & connState
set comm=Server.CreateObject("ADODB.Command")
select case comm.State
case 0: commState = "The Command object is closed"
case 1: commState = "The Command object is open"
case 2: commState = "The Command object is connecting"
case 4: commState = "The Command object is executing a command"
case 8: commState = "The rows of the Command object are being retrieved"
case else commState = "Command:" & comm.State
End Select
txtLog "CheckDB() commState = " & commState
CheckDB = connState & " | " & commState
If Err.Number <> 0 Then
' If Err.Number = "3704" Then
'Response.Write("reset IIS")
' End If
Call SendMail("CheckDB error | Database Connection Offline, trying to restart...", Err.description)
Call Touch(Server.MapPath("/"), "global.asa", now)
CheckDB = Err.description
Else
Call SendMail("CheckDB resolved ","Database Connection back online")
End If
Set comm = Nothing
End Function
Sub Touch(FolderPath, FileName, NewDate)
On Error Resume Next
txtLog "Touch(" & FolderPath & "," & FileName & "," & NewDate & ")"
Set app = CreateObject("Shell.Application")
Set folder = app.NameSpace(FolderPath)
Set file = folder.ParseName(FileName)
file.ModifyDate = NewDate
'If Not Application("blnSendErrorMail") Then
' Call SendMail("Duitsedog.tk Touch " & FileName, FolderPath & FileName)
'End If
set file = nothing
set folder = nothing
set app = nothing
End Sub
Function GetField(ByVal strTable, ByVal strFieldName, ByVal strKeyName, ByVal strKeyVal)
Dim Rs, strSQL, i
If Not IsNull(strKeyVal) And strKeyVal<>"" Then
strSQL = "SELECT " & strFieldName & " " & _
"FROM " & strTable & " " & _
"WHERE " & strKeyName & " = " & strKeyVal
Set Rs = GetRS(strSQL)
If Not Rs.EOF Then
GetField = Rs(strFieldName)
Else
GetField = Null
End if
Rs.Close
Else
GetField = Null
End If
Set Rs = Nothing
End Function
Function TryExecSQL(ByVal strSQL, ByRef ErrNumber, ByRef ErrSource, ByRef ErrDesc, ByRef Identity)
Dim Rs, timStart, intMS, strTimTotal
On Error Resume Next
If IsNull(Session("blnInRollback")) Then Session("blnInRollback") = False
If Not Session("blnInRollback") Then
timStart = milliDif()
If IsNull(Session("blnInTransaction")) Then Session("blnInTransaction") = False
If Not Session("blnInTransaction") Then
Set Session("objDB") = Server.CreateObject("ADODB.Connection")
Session("objDB").Open Application("stoeligans_ConnectionString")
'Session("objDB").Execute("set datefirst 1")
Session("objDB").BeginTrans
End If
Session("objDB").Execute(strSQL)
Set Rs = Session("objDB").Execute("SELECT @@IDENTITY AS id")
Identity = Rs("id")
intMS = milliDif() - timStart
strTimTotal = elapsedshort(intMS)
ErrNumber = Err.Number
If Err.Number = 0 Then
If Not Session("blnInTransaction") Then Session("objDB").CommitTrans
'Response.Write("<font color=#00CC00>" & str & "</font>" & "<br>")
txtLog " USER: " & Session("intGebrId") & " EXECUTION: " & strTimTotal & " SQL: " & strSQL
If intMS>1000 Then txtLog " USER: " & Session("intGebrId") & " EXECUTION: " & strTimTotal & " SQL: " & strSQL
Else
Session("objDB").RollbackTrans
If Session("blnInTransaction") Then Session("blnInRollback") = True
ErrSource = Err.Source
ErrDesc = Err.Description
txtLog "TryExecSQL ERROR:" & ErrSource & " | " & ErrDesc & " EXECUTION: " & strTimTotal & " SQL: " & strSQL
TryRecoverDB("TryExecSQL Session(objDB): " & Session("objDB"))
'Response.Write("<font color=#FF0000>" & strToForm(str) & " Errorcode: " & Server.strToForm(Err.Description) & "</font>" & "<br>")
End If
If Not Session("blnInTransaction") Then Set Session("objDB") = Nothing
End If
End Function
Function GetRS(ByVal strSQL)
Dim Rs, timStart, intMS, strTimTotal, strDBMsg, strErrSource, strErrDesc
On Error Resume Next
timStart = milliDif()
If IsNull(Session("blnInTransaction")) Then Session("blnInTransaction") = False
If Not Session("blnInTransaction") Or IsNull(Session("objDB")) Then
Set Session("objDB") = Server.CreateObject("ADODB.Connection")
Session("objDB").Open Application("stoeligans_ConnectionString")
'Session("objDB").Execute("set datefirst 1")
End If
txtLog "GETRS Session(objDB).State=" & Session("objDB").State
If Session("objDB").State <> 1 Then
TryRecoverDB("GetRS: session(objDB)=" & Session("objDB"))
'Response.Redirect("/default.asp")
End If
If True Then
Set GetRS = Session("objDB").Execute(strSQL)
Else
Set Rs = Server.CreateObject("ADODB.RecordSet")
Rs.ActiveConnection = Session("objDB")
Rs.CursorType = adOpenStatic
Rs.LockType = adLockReadOnly
Rs.Open strSQL
Set GetRS = Rs
'Set Rs.ActiveConnection = Nothing
End If
intMS = milliDif() - timStart
strTimTotal = elapsedshort(intMS)
If Err.Number = 0 Then
txtLog " USER: " & Session("intGebrId") & " EXECUTION: " & strTimTotal & " SQL: " & strSQL
If intMS>1000 Then txtLog " USER: " & Session("intGebrId") & " EXECUTION: " & strTimTotal & " SQL: " & strSQL
Else
strErrSource = Err.Source
strErrDesc = Err.Description
Call SendMail("duitsedog.tk | GetRS Error", strErrSource & " | " & strErrDesc & " SQL: " & strSQL)
TryRecoverDB("GetRS Error")
txtLog "******** ERROR **********" & Minute(Now()) & " USER: " & Session("intGebrId") & " ERR: " & strErrDesc & "EXECUTION: " & strTimTotal & " SQL: " & strSQL
'Response.Redirect("/")
'Err.Raise Err.number , Err.Source, Err.Description & "[sql]" & strSQL
End If
If Not Session("blnInTransaction") Then Set Session("objDB") = Nothing
End Function
Function ExecSQL(ByVal strSQL)
' Dim intErrNumber, strErrSource, strErrDesc, intIdentity
' TryExecSQL str, intErrNumber, strErrSource, strErrDesc ,intIdentity
' If intErrNumber <> 0 Then
'Response.Redirect("/default.asp?reset=1")
' End If
Dim Rs, timStart, intMS, strTimTotal, intErrNumber, strErrSource, strErrDesc, intIdentity
On Error Resume Next
If IsNull(Session("blnInRollback")) Then Session("blnInRollback") = False
If Not Session("blnInRollback") Then
timStart = milliDif()
If IsNull(Session("blnInTransaction")) Then Session("blnInTransaction") = False
If Not Session("blnInTransaction") Then
Set Session("objDB") = Server.CreateObject("ADODB.Connection")
Session("objDB").Open Application("stoeligans_ConnectionString")
Session("objDB").BeginTrans
End If
Session("objDB").Execute(strSQL)
Set Rs = Session("objDB").Execute("SELECT @@IDENTITY AS id")
intIdentity = Rs("id")
intMS = milliDif() - timStart
strTimTotal = elapsedshort(intMS)
intErrNumber = Err.Number
If intErrNumber = 0 Then
If Not Session("blnInTransaction") Then Session("objDB").CommitTrans
'Response.Write("<font color=#00CC00>" & str & "</font>" & "<br>")
txtLog " ExecSQL EXECUTION: " & strTimTotal & " SQL: " & strSQL
Else
Session("objDB").RollbackTrans
If Session("blnInTransaction") Then Session("blnInRollback") = True
strErrSource = Err.Source
strErrDesc = Err.Description
txtLog "ExecSQL ERROR:" & strErrSource & " | " & strErrDesc & " EXECUTION: " & strTimTotal & " SQL: " & strSQL
Call SendMail("duitsedog.tk | ExecSQL ERROR",strErrSource & " | " & strErrDesc & " EXECUTION: " & strTimTotal & " SQL: " & strSQL)
TryRecoverDB("ExecSQL Session(objDB): " & Session("objDB") & "sql: " & strSQL)
'Response.Write("<font color=#FF0000>" & strToForm(str) & " Errorcode: " & Server.strToForm(Err.Description) & "</font>" & "<br>")
End If
If Not Session("blnInTransaction") Then Set Session("objDB") = Nothing
End If
End Function
Function ExecSQLID(ByVal str)
Dim intErrNumber, strErrSource, strErrDesc, intIdentity
TryExecSQL str, intErrNumber, strErrSource, strErrDesc, intIdentity
If intErrNumber <> 0 Then
Err.Raise intErrNumber, strErrSource, strErrDesc & "[sql]" & str
Else
ExecSQLID = intIdentity
End If
End Function
Sub TryRecoverDB(ByVal input)
Dim connState, comm, commState
on error resume next
txtLog "TryRecoverDB(" & input & ")"
If Not Session("blnInTransaction") Then
Set Session("objDB") = Server.CreateObject("ADODB.Connection")
Session("objDB").Open Application("stoeligans_ConnectionString")
End If
select case Session("objDB").State
case 0: connState = "The Connection object is closed"
case 1: connState = "The Connection object is open"
case 2: connState = "The Connection object is connecting"
case 4: connState = "The Connection object is executing a command"
case 8: connState = "The rows of the Connection object are being retrieved"
case else connState = "Connection:" & Session("objDB").State
End Select
txtLog "TryRecoverDB() connstate = " & connState
If Err.Number <> 0 or Session("objDB").State <> 1 Then
' If Err.Number = "3704" Then
'Response.Write("reset IIS")
' End If
txtLog "TryRecoverDB() ERROR: " & Err.Number & " DESC: " & Err.description
Call Touch(Server.MapPath("/"), "global.asa", now)
If Not Application("blnSendErrorMail") Then
Call SendMail("duitsedog.tk | Database Connection Offline", "trying to restart... <br/><br/>input: " & input & "<br/> conn state: " & connState & "<br/>Error: " & Err.description)
Application("blnSendErrorMail") = true
End If
Response.redirect("default_reset.asp")
Else
'Call SendMail("duitsedog.tk | Database Connection online",input)
Application("blnSendErrorMail") = false
End If
Set comm = Nothing
end Sub
%>