Skip to content

Instantly share code, notes, and snippets.

@zed9h

zed9h/sql_client.asp

Created July 18, 2009 20:08
Show Gist options
  • Save zed9h/149678 to your computer and use it in GitHub Desktop.
Save zed9h/149678 to your computer and use it in GitHub Desktop.
Download ZIP
asp vb sql client, configured to access mdb
Raw
sql_client.asp
<% option explicit %>
<%
' TO DO:
' - remove navigation and col '#' in forwardonly recsets (e.g. sp_help (?)
' - use RS.NextRecordset for multiple queries, instead of GO
on error resume next
'---- CursorTypeEnum Values ----
Const adOpenForwardOnly = 0
Const adOpenKeyset = 1
Const adOpenDynamic = 2
Const adOpenStatic = 3
'---- LockTypeEnum Values ----
Const adLockReadOnly = 1
Const adLockPessimistic = 2
Const adLockOptimistic = 3
Const adLockBatchOptimistic = 4
'---- ConnStrectModeEnum 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
'---- CommandTypeEnum Values ----
Const adCmdUnknown = 0
Const adCmdText = &H0001
Const adCmdTable = &H0002
Const adCmdStoredProc = &H0004
'---- OpenSchema Values ----
Const adSchemaColumns = 4
Const adSchemaIndexes = 12
Const adSchemaProcedures = 16
Const adSchemaTables = 20
Const adSchemaProviderTypes = 22
Const adSchemaProcedureParameters = 26
Const adSchemaPrimaryKeys = 28
'---- OpenTextFile Values ----
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8
on error goto 0
Dim timeout_in_sec : timeout_in_sec = 180
Server.ScriptTimeOut = timeout_in_sec
Response.ExpiresAbsolute = 0
Response.AddHeader "pragma", "no-cache"
Dim ConnObj, RS, RecordsAffected
' global hash ''''''''''''''''''''''''''''''''''''''''''
Dim global
Set global = CreateObject("Scripting.Dictionary")
function set_value(key,value)
if not isEmpty(value) then
global.item(key) = value
end if
set_value = global.item(key)
end function
'' <SELECT> processing function ''''''''''''''''''''''''
function process_select(name,items_array,fdef)
set_value name, fdef ' factory default
set_value name, global.item("udef"&name)' user default
Dim value : value = set_value(name, Request(name))
' only allow value if its on the array
Dim i
Dim r_value : r_value = value
for each i in items_array
if CDbl(i) <= CDbl(value) then r_value = i
next
value = r_value
Dim output : output = _
"<TR>"&_
" <TD ALIGN='LEFT' VALIGN='TOP'><font size=2>"&name&":</td>"&vbCRLF&_
" <TD ALIGN='RIGHT' VALIGN='TOP'><select name='"&name&"'>"&vbCRLF
for each i in items_array
output = output & " <option"
if i = value then output = output & " selected"
output = output & ">" & i & "</option>"&vbCRLF
next
output = output & "</select></td></tr>"&vbCRLF
set_value name&"Output", output
process_select=output
end function
'' aux ''''''
function remove_trailing(value)
remove_trailing = value
if value = "" then exit function
'remove trailing characters
Dim i, v
for i = len(value) to 1 step -1
select case Mid(value, i, 1)
case " ", vbCR, vbLF
case else : exit for
end select
next
remove_trailing = left(value,i)
end function
'' <TEXTAREA> processing function ''''''''''''''''''''''''
function process_textarea(name, fdef)
set_value name, fdef ' factory default
set_value name, global.item("udef"&name)' user default
Dim value : value = set_value(name, remove_trailing(Request(name)))
Dim output : output = _
"<TR>"&vbCRLF&_
" <TD ALIGN='RIGHT' VALIGN='TOP'><font size=2>"&name&":</td>"&vbCRLF&_
" <TD ALIGN='LEFT' COLSPAN=4>"&_
"<TEXTAREA name='"&name&"' cols="&global.item("Cols")&" rows="&global.item(name&"Rows")&">"&global.item(name)&vbCRLF&"</TEXTAREA>"&_
"</td>"&vbCRLF&_
"</tr>"&vbCRLF
set_value name&"Output", output
process_textarea = output
end function
'' FACTORY DEFAULTS ''''''''''''''''''
' <built-in on load-0>
'' USER DEFAULTS ''''''''''''''''''
Dim cfgFilename
cfgFilename = Server.MapPath("/") & Request.ServerVariables("SCRIPT_NAME")
cfgFilename = Replace(cfgFilename, "/", "\")
cfgFilename = Left(cfgFilename,InstrRev(cfgFilename, ".", -1))&"ini"
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim key2serialize : key2serialize = Array("ConnStrRows", "ScratchRows", "SQLRows", "Cols", "Timeout(min)", "ResultRows", "ConnStr", "Scratch", "SQL")
function on_err(section)
on_err = false
if err.number>0 then
%><table><tr><td bgcolor=0><font face=Arial color=white size=1>&nbsp;Error <%=section%> <font color=silver><%=cfgFilename%></font> (Err <%=Err.Number%>: <%=Err.Description%>)&nbsp;</font></td></tr></table><%
err.clear
on_err = true
end if
end function
sub saveINIvar(f,key)
Dim value : value = global.item(key)
value = Replace(value, vbCR, "")
value = Replace(value, """", """""")
value = Replace(value, vbLF, """&vbCRLF&""")
Dim row : row = key & "=""" & value & """"
f.WriteLine row
end sub
sub saveINI()
on error resume next
Dim f : Set f = fso.CreateTextFile(cfgFilename, True)
if not on_err("saving parameters") then
on error goto 0
Dim k
for each k in key2serialize
saveINIvar f, k
next
f.Close
else
on error goto 0
end if
end sub
'''''''''''''''''''''
sub loadINIvar(f)
Dim row : row = f.ReadLine
Dim p : p = InStr(row,"=""")
Dim key : key = left(row,p-1)
Dim value : value = mid(row,p+1)
value = mid(value,2,len(value)-2)
value = Replace(value, """&vbCRLF&""", vbCRLF)
value = Replace(value, """""", """")
set_value "udef"&key, value
end sub
sub loadINI()
on error resume next
Dim f : Set f = fso.OpenTextFile(cfgFilename, ForReading)
if not on_err("reading parameters") then
on error goto 0
do while not f.AtEndOfStream
loadINIvar f
loop
f.Close
else
on error goto 0
end if
end sub
'' SCHEMA PATCH ''''''''''''''''''''''''
if Request("func")="funcSchema" then
Dim schema_conn_str : schema_conn_str = remove_trailing(Request("ConnStr"))
%>
<html>
<title>SQL Client - Schema View</title>
<body>
<font face=Arial size=1><font color=gray>ConnStr:&nbsp;</font><%=schema_conn_str%></font><br><br>
<font face=Arial size=2>
<%
'' opening database schema ''''''''''''''''''''''''
Set ConnObj = Server.CreateObject("ADODB.Connection")
ConnObj.Mode = adModeRead
ConnObj.CommandTimeout = timeout_in_sec
ConnObj.Open schema_conn_str
Dim RS_tables, RS_columns, RS_types
Dim dtype : Set dtype = Server.CreateObject("Scripting.Dictionary")
dtype.add 8192, "ARRAY"
dtype.add 20, "BIGINT"
dtype.add 128, "BINARY"
dtype.add 11, "BOOLEAN"
dtype.add 8, "BSTR"
dtype.add 136, "CHAPTER"
dtype.add 129, "CHAR"
dtype.add 6, "CURRENCY"
dtype.add 7, "DATE"
dtype.add 133, "DBDATE"
dtype.add 134, "DBTIME"
dtype.add 135, "DBTIMESTAMP"
dtype.add 14, "DECIMAL"
dtype.add 5, "DOUBLE"
dtype.add 0, "EMPTY"
dtype.add 10, "ERROR"
dtype.add 64, "FILETIME"
dtype.add 72, "GUID"
dtype.add 9, "IDISPATCH"
dtype.add 3, "INTEGER"
dtype.add 13, "IUNKNOWN"
dtype.add 205, "LONGVARBINARY"
dtype.add 201, "LONGVARCHAR"
dtype.add 203, "LONGVARWCHAR"
dtype.add 131, "NUMERIC"
dtype.add 138, "PROPVARIANT"
dtype.add 4, "SINGLE"
dtype.add 2, "SMALLINT"
dtype.add 16, "TINYINT"
dtype.add 21, "UNSIGNEDBIGINT"
dtype.add 19, "UNSIGNEDINT"
dtype.add 18, "UNSIGNEDSMALLINT"
dtype.add 17, "UNSIGNEDTINYINT"
dtype.add 132, "USERDEFINED"
dtype.add 204, "VARBINARY"
dtype.add 200, "VARCHAR"
dtype.add 12, "VARIANT"
dtype.add 139, "VARNUMERIC"
dtype.add 202, "VARWCHAR"
dtype.add 130, "WCHAR"
'' printing database schema ''''''''''''''''''''''''
sub printColumns(table,color)
%><p>CREATE&nbsp;TABLE&nbsp;<font color=<%=color%>><b><%=table%></b></font>&nbsp;(<br><%
RS_columns.filter="TABLE_NAME='"&table&"'"
do while not RS_columns.EOF
RS_types.filter="DATA_TYPE="&RS_columns("DATA_TYPE")
%><dd><%=RS_columns("COLUMN_NAME")%>&nbsp;<%
%><font color=<%=color%>><%
Dim data_id : data_id = CLng(RS_columns("DATA_TYPE"))
if not RS_types.EOF then
%><%=ucase(RS_types("TYPE_NAME"))%><%
else
if dtype.Exists(data_id) then
%><%=ucase(dtype.item(data_id))%><%
else
%><%=data_id%><%
end if
end if
if not isNull(RS_columns("CHARACTER_MAXIMUM_LENGTH")) then
%>(<%=RS_columns("CHARACTER_MAXIMUM_LENGTH")%>)<%
end if
%></font><%
if not RS_columns("IS_NULLABLE") then
%>&nbsp;NOT<%
end if
%>&nbsp;NULL;<br><%
RS_columns.MoveNext
loop
%>);</p><%
end sub
sub printTables(atype,color)
RS_tables.filter="TABLE_TYPE='"&atype&"'"
if not RS_tables.EOF then
%><b><font face="Courier New" size=5><%=atype%>s</font></b><br><%
do while not RS_tables.EOF
printColumns RS_tables("TABLE_NAME"),color
RS_tables.MoveNext
loop
%><br><%
end if
end sub
sub printSchema(Conn)
' adSchemaTables: TABLE_NAME, TABLE_TYPE
' adSchemaColumns: TABLE_NAME, COLUMN_NAME, IS_NULLABLE, DATA_TYPE, CHARACTER_MAXIMUM_LENGTH, DESCRIPTION /**/
' adSchemaProviderTypes: DATA_TYPE, TYPE_NAME
Set RS_tables = ConnObj.OpenSchema(adSchemaTables)
Set RS_columns = ConnObj.OpenSchema(adSchemaColumns)
Set RS_types = ConnObj.OpenSchema(adSchemaProviderTypes)
printTables "TABLE", "blue"
printTables "VIEW", "red"
end sub
''''''''''''''''''''''
printSchema ConnObj
%>
</body>
</html>
<%
Response.end
end if
'' INITIALIZATION '''''''''''''''''''''''''''''''''''''''''''''''''
loadINI()
process_select "ConnStrRows",Array(1,2,4,6,8,10,12,20), 4
process_select "ScratchRows",Array(1,2,4,6,8,10,12,20), 6
process_select "SQLRows",Array(1,2,4,6,8,10,12,20), 6
process_select "Cols",Array(40,50,60,70,80,100,120,160,180), 60
process_select "Timeout(min)",Array(1/2,1,3,5,10,20,30,60), 3
process_select "ResultRows",Array(1,5,10,20,50,100,200,500), 20
process_textarea "ConnStr", "DSN=; DATABASE=; UID=sa; PWD=" & vbCRLF & vbCRLF & "DRIVER=Microsoft Access Driver (*.mdb); UID=admin; UserCommitSync=Yes; Threads=3; SafeTransactions=0; PageTimeout=5; MaxScanRows=8; MaxBufferSize=512; ImplicitCommitSync=Yes; FIL=MS Access; DriverId=25; DefaultDir=; DBQ=" & Server.MapPath (".") & "\.mdb"
process_textarea "Scratch", _
"select * from " & vbCRLF & _
"update from set ()" & vbCRLF & _
"" & vbCRLF
process_textarea "SQL", ""
saveINI()
'' INPUT FORM ''''''''''''''''''''''''
%>
<html>
<body>
<form name=form1 method="post" action="">
<input type="hidden" name="func" value="funcExec">
<SCRIPT LANGUAGE="JavaScript">
<!--
function popup(url,id,free,width,height) {
var w2 = window.open("",id,"width=1,height=1,left=999999,top=999999");
w2.close();
w2 = window.open(url,id,"toolbar=no,location=no,directories=no,status=no,menubar=no,scrollbars="+free+",resizable="+free+",copyhistory=no,width="+width+",height="+height);
return w2;
}
function about() {
var w2 = popup("","sql_client_ack","no",220,300);
w2.document.open();
w2.document.write(
"<title>SQL Client - About &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;</title>"+
"<body bgcolor=#f0f0f0>"+
"<font face=Arial size=2>"+
"<p align=right><b><font color=darkblue><font face='Courier New' size=4>sql_client.asp</font><br>"+
"<font color=darkred>2000.03.03</font> release 9c</font></b></p><p>"+
"<b>Development</b><br><font color=blue>zED <font size=1><a href=mailto:[email protected]>[email protected]</a></font>,<br> enrique <font size=1><a href=mailto:[email protected]>[email protected]</a></font>,<br> dbb <font size=1><a href=mailto:[email protected]>[email protected]</a></font></font><br><br>"+
"<b>Production</b><br><font color=blue>BIS.BowneRio <font size=1><a href=http://www.bowneinternet.com.br target=_blank>www.bowneinternet.com.br</a></font></font><br><br>"+
"<b>Distribution</b><br><font color=blue>Tripod <font size=1><a href=http://carlo31.tripod.com target=_blank>carlo31.tripod.com<a/></font></font></p></font>"+
"<p align=right><font size=2><a href='javascript:window.close()'>close</a></font></p>"
);
}
function schema() {
var conn_str = document.form1.ConnStr.value;
popup("?func=funcSchema&ConnStr="+escape(conn_str),"sql_client_schema","yes",420,0);
}
//-->
</SCRIPT>
<TABLE>
<%=global.item("ConnStrOutput")%>
<%=global.item("ScratchOutput")%>
<%=global.item("SQLOutput")%>
<tr>
<td></td>
<td align=left valign=top>
<INPUT TYPE="SUBMIT" VALUE="SEND"><br>
<font face=Arial size=1><br>
<a href="javascript:about()">about</a>&nbsp;
<a href="javascript:schema()">schema</a>&nbsp;
</font><br>
<font face="Times New Roman" size=4>SQL Client</font>
</td>
<td></td>
<td align=right valign=top><table>
<%=global.item("ConnStrRowsOutput")%>
<%=global.item("ScratchRowsOutput")%>
<%=global.item("SQLRowsOutput")%>
</table></td>
<td align=right valign=top><table>
<%=global.item("ColsOutput")%>
<%=global.item("Timeout(min)Output")%>
<%=global.item("ResultRowsOutput")%>
</table></td>
</tr>
</TABLE>
<SCRIPT LANGUAGE="JavaScript">
<!--
document.form1.SQL.focus();
//-->
</SCRIPT>
<%
if Request("func")="funcExec" then
if global.Item("ConnStr")<>"" and global.Item("SQL")<>"" then
'' SQL EXECUTION ''''''''''''''''''''''''
timeout_in_sec = CDbl(global.item("Timeout(min)"))*60
Server.ScriptTimeOut = timeout_in_sec
Set ConnObj = Server.CreateObject("ADODB.Connection")
ConnObj.Mode = adModeReadWrite
ConnObj.CommandTimeout = timeout_in_sec
ConnObj.Open global.Item("ConnStr")
RecordsAffected = -1
Dim SQL, SQL_type
SQL = global.Item("SQL")
SQL = Replace(SQL,vbCR,"")
Dim comandos_separados
comandos_separados = split ( SQL, vbLF & "GO" & vbLF, -1, 1 )
sub write_status(SQL, RecordsAffected)
Dim exec_status
exec_status = ""
select case ( RecordsAffected )
case -1: exec_status = ""
case 0: exec_status = "NENHUM REGISTRO AFETADO"
case 1: exec_status = "1 REGISTRO AFETADO"
case else exec_status = RecordsAffected & " REGISTROS AFETADOS"
end select
if exec_status<>"" then
%><font face=Arial size=2 color=blue><b>&nbsp;<b><%=exec_status %><b><br><font size=1>(<%=SQL%>)</font><br><br>
<%
end if
end sub
' pre-commands
for p = Lbound(comandos_separados) to Ubound(comandos_separados)-1
ConnObj.Execute comandos_separados(p), RecordsAffected, adCmdText
write_status comandos_separados(p), RecordsAffected
RecordsAffected = -1
next
' The Command (last one in array)
SQL = Replace(comandos_separados(Ubound(comandos_separados)),vbLF," ")
SQL = Trim(SQL)
Dim p
p=InStr(SQL, " ")-1
if p<0 then p=0
SQL_type = LCase(Left(SQL,p))
if SQL_type = "select" then 'FIXME: want RecordsAffected and adOpenStatic together
Set RS = Server.CreateObject("ADODB.Recordset")
RS.Open SQL, ConnObj, adOpenStatic, adLockOptimistic, adCmdText
else
Set RS = ConnObj.Execute (SQL, RecordsAffected, adCmdText)
end if
Dim n : n=0
Dim max_rows : max_rows = CLng(global.Item("ResultRows"))
if ( RS.State <> 0 ) then
' get top posisiton
Dim top_pos
top_pos = Request("top_pos")
if not isNumeric(top_pos) then top_pos = 1
top_pos = CLng(top_pos) - 1
' change top posisiton
if Request("nav") = "LAST" then top_pos = RS.RecordCount - max_rows
if Request("nav") = "NEXT" then top_pos = top_pos + max_rows
if Request("nav") = "PREV" then top_pos = top_pos - max_rows
if Request("nav") = "FIRST" then top_pos = 0
if top_pos < 0 then top_pos = 0
if top_pos > RS.RecordCount - 1 then top_pos = RS.RecordCount - 1
' write navigation bar
%>
<table>
<TR>
<TD colspan=2></TD>
<TD ALIGN="LEFT">
<INPUT TYPE="SUBMIT" name="nav" VALUE="FIRST">
<INPUT TYPE="SUBMIT" name="nav" VALUE="PREV">
&nbsp;<INPUT TYPE="TEXT" name="top_pos" VALUE="<%=top_pos+1%>" SIZE=6><font face=system size=4><b>&nbsp;/&nbsp;<%=RS.RecordCount%></b></font>&nbsp;
<INPUT TYPE="SUBMIT" name="nav" VALUE="NEXT">
<INPUT TYPE="SUBMIT" name="nav" VALUE="LAST">
</td>
<TD ALIGN="RIGHT" VALIGN="TOP"></td>
</tr>
</table>
<table cellpadding=0 cellspacing=0 border=1>
<script language="Javascript">
<!--
px = '<img src="" width=4 height=2>';
nb = '&nbsp;';
function a() { document.write('<tr bgcolor=gray><td align=center><font color=white>#</td>'); }
function b(c) { document.write('<td nowrap><font face=Arial size=2 color=white><b>'+px+c+px+'</td>'); }
function i(i) { document.write('<tr bgcolor=silver><td bgcolor=gray align=right valign=bottom><font face=Arial size=1 color=white><b>'+nb+i+nb+'</td>'); }
function n() { document.write('<td nowrap><font face="Courier New" size=2 color=white>'+nb+'&ltNULL&gt'+nb+'</td>'); }
function d(d) { document.write('<td nowrap><font face="Courier New" size=2 >'+px+d+px+'</td>'); }
function r() { document.write('</tr>'); }
a();<%
function js_encode(value)
' js_encode = Server.HTMLencode(value)
' html protection
value = Replace(value,"&","&amp;")
value = Replace(value,"<","&lt;")
value = Replace(value,">","&gt;")
' html formating
value = Replace(value," "," &nbsp;") 'FIXME: replace for and client side replace
value = Replace(value,vbCR,"")
value = Replace(value,vbLF,"<br>")
' javascript protection
value = Replace(value,"\","\\")
value = Replace(value,"""","&quot;")
value = """" & value & """"
js_encode = value
end function
'' HEADER WRITING ''''''''''''''''''''''''
Dim field
n=1 'counts the '#' col
for each field in RS.fields
n=n+1
%>b(<%=js_encode(field.name) %>);<%
next
%>r();
<%
'' ROW WRITING LOOP ''''''''''''''''''''''''
Dim has_hit_end_of_rs, has_hit_max_rows, has_no_records
has_hit_end_of_rs = false
has_hit_max_rows = false
has_no_records = false
Dim i
i = 0
if not RS.EOF then
if top_pos >0 then RS.Move top_pos
if not RS.EOF then
do while not RS.EOF
if i>=max_rows then
has_hit_max_rows = true
exit do
end if
%>i(<%=top_pos+i+1%>);<%
for each field in RS.fields
if isNull(field) then
%>n();<%
else
if Trim(CStr(field))="" then
field="&nbsp;"
end if
%>d(<%=js_encode(field) %>);<%
end if
next
i = i + 1
%>r();
<%
RS.MoveNext
loop
%>
// -->
</script>
<%
RS.close
else
has_hit_end_of_rs = true
end if
else
has_no_records = true
end if
end if
'' STATUS LINE WRITING ''''''''''''''''''''''''
' recordset
Dim rs_status
rs_status = ""
if has_no_records then
rs_status = "no records found."
else
if has_hit_end_of_rs then
if top_pos > 0 then
rs_status = "passed the end of the file, hit 'PREV' to return."
else
rs_status = "the end of file"
end if
else
if has_hit_max_rows then
rs_status = "more records follow, hit 'NEXT' to go on."
end if
end if
end if
if rs_status <> "" then
%><tr bgcolor=gray><td colspan=<%=n%>><font color=white size=2>&nbsp;<%=rs_status%>&nbsp;</td></tr>
<%
end if
' conn.execute
write_status SQL, RecordsAffected
ConnObj.close
else
%><dd><font face=Arial size=2 color=darkred><b>NOTHING TO EXECUTE</font><br>
fill-in the <i>SQL</i> field</b><%
end if ' global.Item("ConnStr")<>"" and global.Item("SQL")<>"" then
end if ' Request("func")<>"funcExec" then
%></table>
<%
%>
</form>
</body>
</html>
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment