michael/programming-examples
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Adding ASP example files

Browse Source
This commit is contained in:
Michael Reber 2019-11-18 14:25:58 +01:00
parent 8c9a19ec97
commit 8258e10e80
241 changed files with 11840 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

165
asp/ActiveX_ADO_Arrays/ADO Schemas to list tables & fields.asp Normal file
View File

@ -0,0 +1,165 @@
<html><head>
<TITLE>dbschemas.asp</TITLE>
</head>
<body bgcolor="#FFFFFF">
<!--#INCLUDE VIRTUAL="/ADOVBS.INC" -->
<!--#INCLUDE VIRTUAL="/learn/test/lib_fieldtypes.asp" -->
<%
myDSN="DSN=Student;uid=student;pwd=magic"
Set conntemp=Server.CreateObject("adodb.connection")
conntemp.open myDSN
Set rsSchema = conntemp.OpenSchema(adSchemaColumns)
thistable=""
pad=" "
Do UNTIL rsSchema.EOF
prevtable=thistable
thistable=rsSchema("Table_Name")
thiscolumn=rsSchema("COLUMN_NAME")
If thistable<>prevtable Then
Response.Write "Table=<b>" & thistable & "</b><br>"
Response.Write "TABLE_CATALOG=<b>" & rsSchema("TABLE_CATALOG") & "</b><br>"
Response.Write "TABLE_SCHEMA=<b>" & rsSchema("TABLE_SCHEMA") & "</b><p>"
End If
Response.Write "<br>" & pad & "Field=<b>" & thiscolumn & "</b><br>"
Response.Write pad & "Type=<b>" & fieldtypename(rsSchema("DATA_TYPE")) & "</b><br>"
Dim colschema(27)
colschema(0)="TABLE_CATALOG"
colschema(1)="TABLE_SCHEMA"
colschema(2)="TABLE_NAME"
colschema(3)="COLUMN_NAME"
colschema(4)="COLUMN_GUID"
colschema(5)="COLUMN_PROP_ID"
colschema(6)="ORDINAL_POSITION"
colschema(7)="COLUMN_HASDEFAULT"
colschema(8)="COLUMN_DEFAULT"
colschema(9)="COLUMN_FLAGS"
colschema(10)="IS_NULLABLE"
colschema(11)="DATA_TYPE"
colschema(12)="TYPE_GUID"
colschema(13)="CHARACTER_MAXIMUM_LENGTH"
colschema(14)="CHARACTER_OCTET_LENGTH"
colschema(15)="NUMERIC_PRECISION"
colschema(16)="NUMERIC_SCALE"
colschema(17)="DATETIME_PRECISION"
colschema(18)="CHARACTER_SET_CATALOG"
colschema(19)="CHARACTER_SET_SCHEMA"
colschema(20)="CHARACTER_SET_NAME"
colschema(21)="COLLATION_CATALOG"
colschema(22)="COLLATION_SCHEMA"
colschema(23)="COLLATION_NAME"
colschema(24)="DOMAIN_NAME"
colschema(25)="DOMAIN_CATALOG"
colschema(26)="DOMAIN_SCHEMA"
colschema(27)="DESCRIPTION"
On Error Resume Next
For counter=4 To 27
thisColInfoType=colschema(counter)
thisColInfo=rsSchema(thisColInfoType)
If Err.number<>0 Then
thiscolinfo="-error-"
Err.Clear
End If
If thisColInfo<>"" Then
Response.Write pad & pad & pad & thiscolinfotype
Response.Write "=<b>" & thiscolinfo & "</b><br>"
End If
Next
Response.Flush
rsSchema.MoveNext
Loop
rsSchema.Close
Set rsSchema=Nothing
conntemp.close
Set conntemp=Nothing
%>
</body></html>
Here Is the contents of lib_fieldtypes.asp which Is included To make this example work:
<%
Function fieldtypename(parm1)
Select Case Parm1
Case 0
fieldtypename="adEmpty"
Case 16
fieldtypename="adTinyInt"
Case 2
fieldtypename="adSmallInt"
Case 3
fieldtypename="adInteger"
Case 20
fieldtypename="adBigInt"
Case 17
fieldtypename="adUnsignedTinyInt"
Case 18
fieldtypename="adUnsignedSmallInt"
Case 19
fieldtypename="adUnsignedInt"
Case 21
fieldtypename="adUnsignedBigInt"
Case 4
fieldtypename="adSingle"
Case 5
fieldtypename="adDouble"
Case 6
fieldtypename="adCurrency"
Case 14
fieldtypename="adDecimal"
Case 131
fieldtypename="adNumeric"
Case 11
fieldtypename="adBoolean"
Case 10
fieldtypename="adError"
Case 132
fieldtypename="adUserDefined"
Case 12
fieldtypename="adVariant"
Case 9
fieldtypename="adIDispatch"
Case 13
fieldtypename="adIUnknown"
Case 72
fieldtypename="adGUID"
Case 7
fieldtypename="adDate"
Case 133
fieldtypename="adDBDate"
Case 134
fieldtypename="adDBTime"
Case 135
fieldtypename="adDBTimeStamp"
Case 8
fieldtypename="adBSTR"
Case 129
fieldtypename="adChar"
Case 200
fieldtypename="adVarChar"
Case 201
fieldtypename="adLongVarChar"
Case 130
fieldtypename="adWChar"
Case 202
fieldtypename="adVarWChar"
Case 203
fieldtypename="adLongVarWChar"
Case 128
fieldtypename="adBinary"
Case 204
fieldtypename="adVarBinary"
Case 205
fieldtypename="adLongVarBinary"
Case Else
fieldtypename="Undefined by ADO"
End Select
End Function
%>

35
asp/ActiveX_ADO_Arrays/ADO Techniques -- The .maxrecords property.asp Normal file
View File

@ -0,0 +1,35 @@
ADO Techniques -- The .maxrecords property
<html><head>
<TITLE>dbmaxrecs.asp</TITLE>
</head><body bgcolor="#FFFFFF">
<!--#INCLUDE VIRTUAL="/ADOVBS.INC" -->
<%
Set rstemp=Server.CreateObject("adodb.Recordset")
rstemp.maxrecords=15
connectme="DSN=Student;uid=student;pwd=magic"
rstemp.open "select * from titles", _
connectme,adopenstatic
' table display
howmanyfields=rstemp.fields.count -1
%>
<table border=1><tr>
<%
For i=0 To howmanyfields %>
<td><b><%=rstemp(i).name %></B></TD>
<% Next %>
</tr>
<%
Do While Not rstemp.eof %>
<tr>
<% For i = 0 To howmanyfields%>
<td valign=top><% = rstemp.fields(i).value %> </td>
<% Next %>
</tr>
<%
rstemp.movenext
Loop
rstemp.close
Set rstemp=Nothing
%>
</table></body></html>

82
asp/ActiveX_ADO_Arrays/Add New Record with ADO.asp Normal file
View File

@ -0,0 +1,82 @@
<html><head>
<title>dbnewrec.asp</title></head>
<body bgcolor="#FFFFFF">
<% ' My ASP program that allows you to append a record %>
<form name="myauthor" action="dbnewADOrespond.asp" method="GET">
<p>Author ID: <Input Type="TEXT" name="id"></p>
<p> Author Name: <Input Type="TEXT" name="name"></p>
<p> Year Born: <Input Type="TEXT" name="year"></p>
<p> <Input Type="SUBMIT"> </p>
</form></body></html>
The form responder looks like this:
<TITLE>dbnewADO.asp</TITLE>
<body bgcolor="#FFFFFF">
<HTML>
<!--#INCLUDE VIRTUAL="/ADOVBS.INC" -->
<!--#INCLUDE VIRTUAL="/learn/test/lib_errors.asp" -->
<%
On Error Resume Next
auname=Request.QueryString("name")
auyear=Request.QueryString("year")
auID=Request.QueryString("ID")
If auid<9000 Then
auid=auid+9000
End If
conn="DSN=Student;uid=student;pwd=magic"
Set RS = Server.CreateObject("ADODB.Recordset")
RS.Open "authors",Conn,adopenstatic,adlockoptimistic
RS.AddNew
'RS("AU_ID")=auid
RS("Author") = auname
RS("Year_Born")= Int(auyear)
RS.Update
Call ErrorVBscriptReport("Adding Record")
Call ErrorADOReport("Adding Record",RS.activeconnection)
RS.Close
Set rs=Nothing
%>
</BODY>
</HTML>
Here Is the include file that displays appropriate errors:
<%
Sub ErrorVBScriptReport(parm_msg)
If Err.number=0 Then
Exit Sub
End If
pad=" "
Response.Write "<b>VBScript Errors Occured!<br>"
Response.Write parm_msg & "</b><br>"
Response.Write pad & "Error Number= #<b>" & Err.number & "</b><br>"
Response.Write pad & "Error Desc.= <b>" & Err.description & "</b><br>"
Response.Write pad & "Help Context= <b>" & Err.helpcontext & "</b><br>"
Response.Write pad & "Help File Path=<b>" & Err.helpfile & "</b><br>"
Response.Write pad & "Error Source= <b>" & Err.source & "</b><br><hr>"
End Sub
Sub ErrorADOReport(parm_msg,parm_conn)
HowManyErrs=parm_conn.errors.count
If HowManyErrs=0 Then
Exit Sub
End If
pad=" "
Response.Write "<b>ADO Reports these Database Error(s) executing:<br>"
Response.Write SQLstmt & "</b><br>"
For counter= 0 To HowManyErrs-1
errornum=parm_conn.errors(counter).number
errordesc=parm_conn.errors(counter).description
Response.Write pad & "Error#=<b>" & errornum & "</b><br>"
Response.Write pad & "Error description=<b>"
Response.Write errordesc & "</b><p>"
Next
End Sub
%>

134
asp/ActiveX_ADO_Arrays/Another month, day, year dropdown creator.asp Normal file
View File

@ -0,0 +1,134 @@
<script language=javascript>
function fnSubmit(strPage)
{
document.forms[0].action= strPage
document.forms[0].submit()
}
</script>
<%
'here is the call
writedropdowns
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub writeDropDowns()
Dim strSelfLink
strSelfLink = request.servervariables("SCRIPT_NAME")
response.Write "<form name=dates method=post>" & vbcrlf
response.Write MonthDropDown("month1",False,request("month1"),strSelfLink) & " " & DayDropDown("day1", "",getDaysInMonth(request("month1"),request("year1")),request("day1")) & " " & YearDropDown("year1","","", request("year1"),strSelfLink) & vbcrlf
response.Write "</form>" & vbcrlf
End Sub
'MonthDropDown
'strName = name of drop down
'blnNum = 'If blnNUM Is True, Then show As numbers
'strSelected = the currenct selected month
'strSelfLink = link to current page
Function MonthDropDown(strName, blnNum, strSelected, strSelfLink)
Dim strTemp, i, strSelectedString
strTemp = "<select name='" & strName& "' onchange='javascript: fnSubmit(" & chr(34) & strSelfLink & chr(34) & ")'>" & vbcrlf
strTemp = strTemp & "<option value='" & 0 & "'>" & "Month" & "</option>" & vbcrlf
For i = 1 To 12
If strSelected = CStr(i) Then
strSelectedString = "Selected"
Else
strSelectedString = ""
End If
If blnNum Then
strTemp = strTemp & "<option value='" & i & "' " & strSelectedString & " >" & i & "</option>" & vbcrlf
Else
strTemp = strTemp & "<option value='" & i & "' " & strSelectedString & " >" & MonthName(i) & "</option>" & vbcrlf
End If
Next
strTemp = strTemp & "</select>" & vbcrlf
MonthDropDown = strTemp
End Function
'YearDropDown
'strName = name of dropdown
'intStartYear = year to start options list
'intEndYear = year to end options list
'strSelected = the currenct selected year
'strSelfLink = link To currentpage
Function YearDropDown(strName, intStartYear, intEndYear, strSelected, strSelfLink)
Dim strTemp, i, strSelectedString
If intStartYear = "" Then
intStartYear = Year(now())
End If
If intEndYear = "" Then
intEndYear = Year(now()) + 9
End If
strTemp = "<select name='" & strName& "' onchange='javascript: fnSubmit(" & chr(34) & strSelfLink & chr(34) & ")'>" & vbcrlf
strTemp = strTemp & "<option value='" & 0 & "'>" & "Year" & "</option>" & vbcrlf
For i = intStartYear To intEndYear
If strSelected = CStr(i) Then
strSelectedString = "Selected"
Else
strSelectedString = ""
End If
strTemp = strTemp & "<option value='" & i & "' " & strSelectedString & " >" & i & "</option>" & vbcrlf
Next
strTemp = strTemp & "</select>" & vbcrlf
YearDropDown = strTemp
End Function
'DayDropDown
'strName = name of drop down
'intStartDay = day to start with
'intEndDay = day to end with
'strSelected = current slected day
Function DayDropDown(strName, intStartDay, intEndDay, strSelected )
Dim strTemp, i, strSelectedString
If intStartDay = "" Then
intStartDay = 1
End If
If intEndDay = "" Then
intEndDay = getDaysInMonth(Month(now()),Year(now()))
End If
strTemp = "<select name='" & strName& "'>" & vbcrlf
strTemp = strTemp & "<option value='" & 0 & "'>" & "Day" & "</option>" & vbcrlf
For i = intStartDay To intEndDay
If strSelected = CStr(i) Then
strSelectedString = "Selected"
Else
strSelectedString = ""
End If
strTemp = strTemp & "<option value='" & i & "' " & strSelectedString & " >" & i & "</option>" & vbcrlf
Next
strTemp = strTemp & "</select>" & vbcrlf
DayDropDown = strTemp
End Function
'getDaysInMonth
'strMonth = month as number
'strYear = year
Function getDaysInMonth(strMonth,strYear)
Dim strDays
Select Case CInt(strMonth)
Case 1,3,5,7,8,10,12:
strDays = 31
Case 4,6,9,11:
strDays = 30
Case 2:
If ( (CInt(strYear) Mod 4 = 0 And CInt(strYear) Mod 100 <> 0) Or ( CInt(strYear) Mod 400 = 0) ) Then
strDays = 29
Else
strDays = 28
End If
'Case Else:
End Select
getDaysInMonth = strDays
End Function
%>

37
asp/ActiveX_ADO_Arrays/Arrays to store data.asp Normal file
View File

@ -0,0 +1,37 @@
<html><head>
<title>arraysredim.asp</title>
</head><body bgcolor="#FFFFFF">
<%
' this code
Dim a_array(100)
' this code will fail
x=100
Dim my_array(x)
%>
</body></html>
Assigning an Array size With a variable produces an Error unless the ReDim command Is used.
<html><head>
<title>arraysredimcorrect.asp</title>
</head><body bgcolor="#FFFFFF">
<%
Dim my_array()
x=100
ReDim preserve my_array(x)
my_array(20)="Hi!"
my_array(40)="How are You"
lowcount=LBound(my_array)
highcount=UBound(my_array)
Response.Write "lowcount=" & lowcount & ";highcount=" & highcount & "<p>"
For counter=lowcount To highcount
Response.Write counter & " "
Response.Write my_array(counter) & "<br>"
Next
%>
</body></html>

24
asp/ActiveX_ADO_Arrays/CombSort Function.asp Normal file
View File

@ -0,0 +1,24 @@
<%
Private Function CombSort(ByVal UnsortedArray)
Dim I, J, Temp, Gap, Swapped
Dim ArrSize, Combcom, Combswap
Const Shrink = 1.3
ArrSize = UBound( UnsortedArray )
Gap = Arrsize - 1
Do
Gap = Int(Gap / Shrink)
Swapped = True
Combcom = Combcom + 1
For J = 0 To Arrsize - Gap
If UnsortedArray(J) > UnsortedArray(J + Gap) Then
Temp = UnsortedArray(J)
UnsortedArray(J) = UnsortedArray(J + Gap)
UnsortedArray(J + Gap) = Temp
Swapped = False
Combswap = Combswap + 1
End If
Next
Loop Until Not Swapped And Gap = 1
CombSort = UnsortedArray
End Function
%>

30
asp/ActiveX_ADO_Arrays/Count the Number of Lines.asp Normal file
View File

@ -0,0 +1,30 @@
<!-- #Include file="connect_strings.asp" -->
<!-- #Include file="adovbs.inc" -->
<%
Dim strSql, rsScript
strSql = "SELECT ScriptCode FROM Scripts"
Set rsScript = objConn.Execute(strSql) 'execute sql call
%>
<html>
<head>
</head>
<body>
<%
Dim CodeLine, StrCode, StrAll, CountAll, LineCount
CodeLine = ""
Do Until rsScript.EOF
StrCode = (rsScript("ScriptCode"))
CodeLine = "" & CodeLine & StrCode
rsScript.MoveNext
Loop
StrAll = Trim(Server.HTMLEncode(CodeLine))
CountAll = Split(StrAll,vbLf, -1, 1)
StrAll = ""
LineCount = UBound(CountAll)
Response.Write LineCount
%>
</body>
</html>
<% Call DBConnClose(ObjConn) %>

225
asp/ActiveX_ADO_Arrays/Database Paging.asp Normal file
View File

@ -0,0 +1,225 @@
<%@ Language=VBScript %>
<!--#include File="_fpclass/adovbs.inc"-->
<%
gend = CStr(Request.QueryString("gender"))
Dim iPageSize 'How many records To show
Dim iRecCurrent ' The page we want To show
Dim sSQL 'SQL command To execute
Dim RecSet 'The ADODB recordset object
Dim I 'Standard looping var
Dim iRecEnd ' Last Record
Dim iRecMax ' Max of record Loop
Dim J ' Loop variabel
Dim iRecNext ' Var of Next record To start at
Dim iRecPrev ' Var of Previous record
Dim sGender ' Var For displaying whether Women's or Men's race
Dim iNumPage ' Number of pages
' Get parameters
iPageSize = 20
' Retrieve page to show or default to 0
If Request.QueryString("page") = "" Then
iRecCurrent = 0 ' First Record
Else
iRecCurrent = CInt(Request.QueryString("page"))
End If
' Assign value to race
If gend = "Male" Then
sGender = "Men's"
Else
sGender = "Women's"
End If
' SQL statement
sSQL = "SELECT * FROM 5KResults WHERE Gender='"
sSQL = sSQL & gend & "' ORDER BY Time"
Set RecSet = Server.CreateObject("ADODB.Recordset")
RecSet.Open sSQL,"DSN=chiledadsn",adOpenForwardOnly,adLockReadOnly
' Get the count of the records
Do While Not RecSet.EOF
J = J + 1
RecSet.MoveNext
Loop
iRecEnd = J -1
' Get the number of pages
iNumPage = CInt(iRecEnd/iPageSize)
' If the request page falls outside the
' acceptable range,
' give them the closest match (0 or max)
'
If iRecCurrent > iRecEnd Then iRecCurrent = iRecEnd
If iRecCurrent < 0 Then iRecCurrent = 0
If iRecCurrent < iRecEnd Then
iRecNext = iRecCurrent + iPageSize
Else
iRecNext = iRecEnd
End If
If iRecCurrent > 0 Then
iRecPrev = iRecCurrent - iPageSize
Else
iRecPrev = 0
End If
' Do this so when calling the las page w
' e only loop through
' the number of records we have if less
' than the iPageSize
If (iRecNext - iRecEnd ) > 0 Then
iRecMax = iRecEnd - iRecCurrent
Else
iRecMax = iPageSize
End If
' Start at the beginning of the database
'
RecSet.MoveFirst
'Move to the record we want to start at
RecSet.Move(iRecCurrent)
' use this when creating links
' doesn't matter what this page is named
'
strScriptName = Request.ServerVariables("SCRIPT_NAME")
%>
<%
Sub NavBar()
Dim iPage
Dim iVue
Dim sNumbers
Dim sPrev
Dim sNext
Dim sFirst
Dim sLast
Dim sNavBar
Dim iLastPage
iLastPage = iRecEnd - iPageSize
For i = 0 To (iNumPage - 1)
iPage = i * iPageSize
iVue = i + 1
sNumbers = sNumbers & NavLink(strScriptName,iPage,gend,iVue)
Next
If iRecCurrent <> 0 Then
sFirst = NavLink(strScriptName,0,gend,"First")
sPrev = NavLink(strScriptName,iRecPrev,gend,"Previous")
End If
If (iRecCurrent + iRecMax) < iRecEnd Then
sNext = NavLink(strScriptName,iRecNext,gend,"Next")
sLast = NavLink(strScriptName,iLastPage,gend,"Last")
End If
sNavBar = sNumbers & "<BR>" & sFirst & sPrev & sNext & sLast
Response.Write(sNavBar)
End Sub
%>
<%
' Creates the link used by the navigatio
' n sub
Function NavLink(scriptName,pageNum,gendr, sWord)
Dim strLink
strLink = strLink & "<A HREF='"
strLink = strLink & scriptName
strLink = strLink & "?page="
strLink = strLink & pageNum
strLink = strLink & "&gender="
strLink = strLink & gendr
strLink = strLink & "'>"
strLink = strLink & sWord
strLink = strLink & "</A> "
NavLink = strLink
End Function
%>
<HTML>
<HEAD>
<TITLE>5K Race Results </TITLE>
<META name="description" content="An example of paging through a database.">
<META name="keywords" content="Active Server Pages, ASP, database, paging">
<META http-equiv="Content-Type" content="text/html; charset=windows-1252">
<BASE target="_top">
<META name="language" content="en-us">
<META name="robots" content="INDEX">
<META name="revisit-after" content="14 days">
<META http-equiv="pragma" content="no-cache">
</HEAD>
<BODY>
<!-- Database Table -->
<H3><% =sGender %> 5K Race</H3>
<P><STRONG>Records</STRONG>: <% =iRecCurrent %> - <% = iRecCurrent + iRecMax %> of <% =iRecEnd %></P>
<P><% NavBar %></P>
<%
' Use these for debugging
'Response.Write ("iRecCurrent: " & iRecC
' urrent & "<BR>")
'Response.Write("iRecEnd: " & iRecEnd &
' "<BR>")
'Response.Write("iRecMax: " & iRecMax &
' "<BR>")
'Response.Write("iRecNext: " & iRecNext
' & "<BR>")
'Response.Write("iRecPrev: " & iRecPrev
' & "<BR>")
'Response.Write(CInt(iRecEnd/iPageSize)
' & "<BR>")
%>
<TABLE border="0" cellPadding="1" cellSpacing="0" width="425px">
<TR bgColor="blue">
<TD style="WIDTH: 130px" width="150" bgcolor="#388C40"><STRONG>Name</STRONG></TD>
<TD style="WIDTH: 35px" width="35" bgcolor="#388C40"><STRONG>Age</STRONG></TD>
<TD style="WIDTH: 90px" width="150" bgcolor="#388C40"><STRONG>City</STRONG></TD>
<TD style="WIDTH: 35px" width="45" bgcolor="#388C40"><STRONG>State</STRONG></TD>
<TD style="WIDTH: 50px" width="75" bgcolor="#388C40"><STRONG>Time</STRONG></TD>
<TD style="WIDTH: 50px" width="75" bgcolor="#388C40"><STRONG>Pace</STRONG></TD></TR>
<%
For i = 0 To iRecMax
If i Mod 2 Then
Response.Write ("<TR bgColor=""#008080""><TD>")
Else
Response.Write("<TR><TD>")
End If
Response.Write(RecSet("FirstName") & " ")
Response.Write(RecSet("LastName")& "</TD>")
Response.Write("<TD>" & RecSet("age") & "</TD>")
Response.Write("<TD>" & RecSet("City") & "</TD>")
Response.Write("<TD>" & RecSet("State") & "</TD>")
Response.Write("<TD>" & RecSet("Time" )& "</TD>")
Response.Write("<TD>" & RecSet("Pace") & "</TD>")
Response.Write("</TR>")
' Move to the next record
RecSet.MoveNext
Next
' Clean up after yourself
RecSet.Close
Set RecSet = Nothing
%>
</TABLE>
<P><% Call NavBar %></P>
<!-- End Database Table -->
</BODY>
</HTML>

59
asp/ActiveX_ADO_Arrays/How to filter a recordset.asp Normal file
View File

@ -0,0 +1,59 @@
<HTML>
<HEAD><TITLE>Place Document Title Here</TITLE></HEAD>
<BODY BGColor=ffffff Text=000000>
<%
Set cn = Server.CreateObject("ADODB.Connection")
Set rs = Server.CreateObject("ADODB.RecordSet")
cn.Open Application("guestDSN")
rs.ActiveConnection = cn
rs.CursorType = adOpenStatic
rs.LockType = adLockOptimistic
rs.Source = "SELECT * FROM authors"
rs.Open
%>
<TABLE BORDER=1>
<TR>
<TH Colspan=<%= rs.Fields.Count %>><B>Before Filter</B></TH>
</TR>
<TR>
<% For i = 0 To RS.Fields.Count - 1 %>
<TD><B><%= RS(i).Name %></B></TD>
<% Next %>
</TR>
<% Do While Not RS.EOF %>
<TR>
<% For i = 0 To RS.Fields.Count - 1 %>
<TD><%= RS(i) %></TD>
<% Next %>
</TR>
<%
RS.MoveNext
Loop
rs.Filter = "phone LIKE '415%'"
rs.MoveFirst
%>
</TABLE>
<P>
<TABLE BORDER=1>
<TR>
<TH Colspan=<%= rs.Fields.Count %>><B>After Filter</B></TH>
</TR>
<TR>
<% For i = 0 To RS.Fields.Count - 1 %>
<TD><B><%= RS(i).Name %></B></TD>
<% Next %>
</TR>
<% Do While Not RS.EOF %>
<TR>
<% For i = 0 To RS.Fields.Count - 1%>
<TD><%= RS(i) %></TD>
<% Next %>
</TR>
<%
RS.MoveNext
Loop
rs.MoveFirst
RS.Close
Cn.Close
%>
</TABLE>

102
asp/ActiveX_ADO_Arrays/How to shutdown reboot logoff WIndows 9x NT Me 2000.asp Normal file
View File

@ -0,0 +1,102 @@
program shutdown;
{$APPTYPE CONSOLE}
uses
SysUtils,
Windows;
var
logoff: boolean = false;
reboot: boolean = false;
warn: boolean = false;
downQuick: boolean = false;
cancelShutdown: boolean = false;
powerOff: boolean = false;
timeDelay: integer = 0;
function HasParam(Opt: Char): Boolean;
var
x: integer;
begin
result := false;
for x := 1 to paramCount do
if (paramstr(x) = '-'+opt) or (paramstr(x) = '/'+opt) then result := true;
end;
function GetErrorString: String;
var
lz: Cardinal;
err: array[0..512] of Char;
begin
lz := GetLastError;
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, lz, 0, @err, 512, nil);
result := string(err);
end;
procedure DoShutdown;
var
rl,flgs: Cardinal;
hToken: Cardinal;
tkp: TOKEN_PRIVILEGES;
begin
flgs := 0;
if downQuick then flgs := flgs or EWX_FORCE;
if not reboot then flgs := flgs or EWX_SHUTDOWN;
if reboot then flgs := flgs or EWX_REBOOT;
if poweroff and (not reboot) then flgs := flgs or EWX_POWEROFF;
if logoff then flgs := (flgs and (not (EWX_REBOOT or EWX_SHUTDOWN or EWX_POWEROFF))) or EWX_LOGOFF;
if Win32Platform = VER_PLATFORM_WIN32_NT then begin
if not OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
Writeln('Cannot open process token. ['+GetErrorString+']')
else begin
if LookupPrivilegeValue(nil, 'SeShutdownPrivilege', tkp.Privileges[0].Luid) then begin
tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
tkp.PrivilegeCount := 1;
AdjustTokenPrivileges(hToken, False, tkp, 0, nil, rl);
if GetLastError <> ERROR_SUCCESS then
Writeln('Error adjusting process privileges.');
end else Writeln('Cannot find privilege value. ['+GetErrorString+']');
end;
{ if CancelShutdown then
if AbortSystemShutdown(nil) = False then
Writeln(\'Cannot abort. [\'+GetErrorString+\']\')
else
Writeln(\'Cancelled.\')
else begin
if InitiateSystemShutdown(nil, nil, timeDelay, downQuick, Reboot) = False then
Writeln(\'Cannot go down. [\'+GetErrorString+\']\')
else
Writeln(\'Shutting down!\');
end;}
end;
// else begin
ExitWindowsEx(flgs, 0);
// end;
end;
begin
Writeln('Shutdown v0.3 for Win32 (similar to the Linux version)');
Writeln('X Software. All Rights Reserved.');
if HasParam('?') or (ParamCount=0) then begin
Writeln('Usage: shutdown [-akrhfnc] [-t secs]');
Writeln(' -k: don''t really shutdown, only warn.');
Writeln(' -r: reboot after shutdown.');
Writeln(' -h: halt after shutdown.');
Writeln(' -p: power off after shutdown');
Writeln(' -l: log off only');
Writeln(' -n: kill apps that don''t want to die.');
Writeln(' -c: cancel a running shutdown.');
end else begin
if HasParam('k') then warn := true;
if HasParam('r') then reboot := true;
if HasParam('h') and reboot then begin
Writeln('Error: Cannot specify -r and -h parameters together!');
Exit;
end;
if HasParam('h') then reboot := false;
if HasParam('n') then downQuick := true;
if HasParam('c') then cancelShutdown := true;
if HasParam('p') then powerOff := true;
if HasParam('l') then logoff := true;
DoShutdown;
end;
end.

154
asp/ActiveX_ADO_Arrays/Index Server Access via ADO.asp Normal file
View File

@ -0,0 +1,154 @@
<html><head>
<title>iskeyword.asp</title>
</head><body bgcolor="#FFFFFF">
<Form action = "iskeywordRespond.asp" method="get">
Choose The Word You Want To Search For::<p>
Search Word: <Input NAME="Keyword" size ="30"><br>
<Input Type="submit" value="Find The Documents!">
</form>
</body></html>
The iskeywordrespond.asp looks like this:
<html><head>
<title>iskeywordrespond.asp</title>
</head>
<body>
<%
Set objQuery = Server.CreateObject("ixsso.query")
Set objUtil = Server.CreateObject("ixsso.util")
my_keyword=request("keyword")
' keyword search
myquery=myquery & "$CONTENTS " & my_keyword
' Exclude specific folders
%>
<!--#include virtual="/search/exclude.asp"-->
<%
' Exclude specific filenames
myquery=myquery & " and not #filename indexmaster.asp"
myquery=myquery & " and not #filename index.asp"
myquery=myquery & " and not #filename indexold.asp"
' Exclude specific extensions
myquery=myquery & " and not #filename *.|(txt|,inc|,htm|,mdb|,cnt|,class|,toc|,html|,css|)"
'myquery="$CONTENTS dsn"
objQuery.Query=myQuery
objQuery.Columns = "Vpath, DocTitle, Filename, Characterization, Contents,DocKeyWords, Rank"
'objquery.Columns = "DocTitle, vpath, filename, size, write, characterization, rank"
objQuery.SortBy = "Rank [d]"
objQuery.MaxRecords = 50
objquery.catalog="learnasp"
'objUtil.AddScopeToQuery objQuery, "/", "deep"
objquery.LocaleID = objutil.ISOToLocaleID("EN-US")
linebr="<br>" & vbCrLf
Set rstemp = objQuery.CreateRecordSet("nonsequential")
Do UNTIL rstemp.eof
For Each key In rstemp.fields
keyname=LCase(key.name)
Select Case keyname
Case "vpath"
Response.Write "<a href='"
Response.Write key
Response.Write "'>" & key & "</a>" & linebr
Case Else
Response.Write "<b>" & keyname & ":</b>" & linebr
Response.Write key & linebr
End Select
Next
Response.Write "<br><hr>"
rstemp.movenext
Loop
' clean up
rstemp.close
Set rstemp=Nothing
Set objQuery = Nothing
Set objUtil = Nothing
%>
</body>
</html>
It has To exclude many folders On my site And the following file excludes directories:
<%
myquery=myquery & " and not #Vpath = **_* "
myquery=myquery & " and not #Vpath = *_contents* "
myquery=myquery & " and not #Vpath = *_raw* "
myquery=myquery & " and not #Vpath = *ads* "
myquery=myquery & " and not #Vpath = *aspace* "
myquery=myquery & " and not #Vpath = *advicedraft* "
'myquery=myquery & " and not #Vpath = *asplists* "
myquery=myquery & " and not #Vpath = *aspmagazine
ew* "
myquery=myquery & " and not #Vpath = *aspfuture* "
myquery=myquery & " and not #Vpath = *asptraining* "
myquery=myquery & " and not #Vpath = *aspynews* "
myquery=myquery & " and not #Vpath = *activeserverpages* "
myquery=myquery & " and not #Vpath = *contribute* "
myquery=myquery & " and not #Vpath = *cst* "
myquery=myquery & " and not #Vpath = *charlescarrolldraft* "
myquery=myquery & " and not #Vpath = *charlesteam* "
myquery=myquery & " and not #Vpath = *dcline* "
myquery=myquery & " and not #Vpath = *drafts* "
myquery=myquery & " and not #Vpath = *experiments* "
myquery=myquery & " and not #Vpath = *genericdb* "
myquery=myquery & " and not #Vpath = *future* "
myquery=myquery & " and not #Vpath = *home* "
myquery=myquery & " and not #Vpath = *how* "
myquery=myquery & " and not #Vpath = *images* "
myquery=myquery & " and not #Vpath = *library* "
myquery=myquery & " and not #Vpath = *learncover* "
myquery=myquery & " and not #Vpath = *learnsecurityrisk* "
myquery=myquery & " and not #Vpath = *
aoko* "
myquery=myquery & " and not #Vpath = *private* "
myquery=myquery & " and not #Vpath = *perlscript* "
myquery=myquery & " and not #Vpath = *
eference* "
myquery=myquery & " and not #Vpath = *
edesign* "
myquery=myquery & " and not #Vpath = *search* "
myquery=myquery & " and not #Vpath = *searchasplists* "
myquery=myquery & " and not #Vpath = *secret* "
myquery=myquery & " and not #Vpath = *sites* "
myquery=myquery & " and not #Vpath = *search* "
myquery=myquery & " and not #Vpath = *speedsitelaws* "
myquery=myquery & " and not #Vpath = *start* "
myquery=myquery & " and not #Vpath = * rash* "
myquery=myquery & " and not #Vpath = * est* "
myquery=myquery & " and not #Vpath = *upload* "
myquery=myquery & " and not #Vpath = *upload ests* "
myquery=myquery & " and not #filename indexmaster.asp"
myquery=myquery & " and not #filename index.asp"
myquery=myquery & " and not #filename indexold.asp"
myquery=myquery & " and not #filename *.|(txt|,inc|,htm|,mdb|,cnt|,class|,toc|,html|,css|)"
%>

69
asp/ActiveX_ADO_Arrays/Insert TEXT blob using ADO.asp Normal file
View File

@ -0,0 +1,69 @@
<%@ Language=VBScript %>
<%
Option Explicit
Response.Expires = 0
' *****************************
' Variable Declarations
' *****************************
' Strings
Dim SQL
' Integers & Numerics
' Objects
Dim cn, rs
' Other
' *****************************
' Initialize Variables
' *****************************
%>
<HTML>
<HEAD>
<!-- #INCLUDE Virtual="/include/ForceFrame.htm" -->
<TITLE>Insert using SPT (SQL pass-thru)</TITLE></HEAD>
<BODY>
<BASEFont Face="Verdana,Arial">
<%
If Request.Form("TextCol") = "" Then
%>
<FORM Action=SQLInsert.asp Method=Post>
<TEXTAREA Rows=10 Cols=45 Name=TextCol>This example uses SQL Pass-thru To insert
a record into a database. This method allows us To insert into BLOB fields such As
SQL Server Text fields, FoxPro Memo fields, Or other fields > 255 characters.
This has an embedded Single quote(') To show how these can be handled With
an SQL insert.</TEXTAREA><P>
<Input Type=Submit Name=btnSubmit Value="Submit">
</FORM>
<%
Else
Set cn = Server.CreateObject("ADODB.Connection")
cn.Open Application("guestDSN")
SQL = "INSERT INTO pubs..paulen (TextCol) "
SQL = SQL & " VALUES ('" & padQuotes(Request("TextCol")) & "')"
cn.Execute SQL
Response.Write "<B>Inserted:</B><BR>" & Request("TextCol")
End If
%>
<P>
<%
Function padQuotes( instring )
REM This Function pads an extra Single q
' uote in strings containing quotes for
REM proper SQL searching.
Dim bodybuild
Dim bodystring
Dim Length
Dim i
bodybuild = ""
bodystring = instring
Length = Len(bodystring)
For I = 1 To length
bodybuild = bodybuild & Mid(bodystring, I, 1)
If Mid(bodystring, I, 1) = Chr(39) Then
bodybuild = bodybuild & Mid(bodystring, I, 1)
End If
Next
bodystring = bodybuild
padQuotes = bodystring
End Function
%>
</BODY>
</HTML>

84
asp/ActiveX_ADO_Arrays/Pagination Script in ASP.asp Normal file
View File

@ -0,0 +1,84 @@
Pagination Script in ASP
' iNumPerPage is the number of items to
' display on each page
' sURL is the page to put with the link
' , sQuerystring is additional qs stuff
' adodbConnection, adodbCommand, sTable
' are all for the table to get row count from. *
' *
' Print out the numbers (if any) betwee
' n the "previous" and "next" buttons
' It'll act like this (current # is in
' bold):
' 1 2 3 4 5 6 7 8 9 <b>10</b> >> next
' previous << <b>11</b> 12 13 14 15 16 17 18 *
' *
'' ****************************************
Sub PrintRecordsetNav( iNumPerPage, adodbConnection, adodbCommand, sTable, sURL, sQuerystring )
Dim iTtlNumItems, iDBLoc, sSqlTemp, iTtlTemp
Dim iDBLocTemp, sURLBeg, iA, iB, x, iTemp, rsObj
iDBLoc = CInt(Request("iDBLoc"))
iTtlNumItems = CInt(Request("iTtlNumItems"))
' Get ttl num of items from the database if it's Not already In the QueryString
If (iTtlNumItems = 0) Then
Set rsObj = Server.CreateObject("ADODB.Recordset")
sSqlTemp = "SELECT COUNT(*) FROM " & sTable
adodbCommand.CommandText = sSqlTemp
rsObj.Open adodbCommand
If Not(rsObj.EOF) Then
iTtlNumItems = rsObj(0)
End If
rsObj.Close
Set rsObj = Nothing
End If
iTtlTemp = iTtlNumItems iNumPerPage ' this is the number of numbers overall (use the "" To return int)
iDBLocTemp = iDBLoc iNumPerPage ' this is which number we are currently On (use the "" To return int)
If (sQuerystring <> "") Then
sURLBeg = "<A href = """ & sURL & "?" & sQuerystring & "&iTtlNumItems=" & iTtlNumItems & "&iDBLoc="
Else
sURLBeg = "<A href = """ & sURL & "?iTtlNumItems=" & iTtlNumItems & "&iDBLoc="
End If
'***** BEGIN DISPLAY *****
' Print the "Previous"
If (iDBLoc <> 0) Then
Response.Write sURLBeg & (iDBLoc - iNumPerPage) & """>Previous</A> "
End If
' Print the <<
If (iDBLocTemp >= iNumPerPage) Then
Response.Write sURLBeg & (( iDBLocTemp iNumPerPage ) * iNumPerPage ^ 2) - (iNumPerPage * 9) & """><<</A> "
End If
' Print the numbers in between. Print them out in sets of 10.
iA = ( iDBLocTemp iNumPerPage ) * iNumPerPage
iB = ( iDBLocTemp iNumPerPage ) * iNumPerPage + iNumPerPage
For x = iA To iB
iTemp = (x * iNumPerPage)
If (iTemp < iTtlNumItems) Then ' takes care of extra numbers after the overall final number
If (iDBLoc = iTemp) Then
Response.Write " <B>[" & x+1 & "]</B>"
Else
Response.Write " " & sURLBeg & (x * iNumPerPage) & """>" & x+1 & "</A>"
End If
Else
Exit For
End If
Next
' Print the >>
If (iTtlTemp > iDBLocTemp) Then
If ((iDBLocTemp + iNumPerPage) <= iTtlTemp) Then
Response.Write " " & sURLBeg & (( iDBLocTemp iNumPerPage ) * iNumPerPage + iNumPerPage ) * iNumPerPage & """>>></A> "
End If
End If
' Print the "Next"
If ((iDBLoc + iNumPerPage) < iTtlNumItems) Then
Response.Write " " & sURLBeg & (iDBLoc + iNumPerPage) & """>Next</A>"
End If
'***** End DISPLAY *****
End Sub

62
asp/ActiveX_ADO_Arrays/ProgIDInfo Object.asp Normal file
View File

@ -0,0 +1,62 @@
<%
Class Program
Public Description, ClsID, ProgID, Path, TypeLib, Version, DLLName
End Class
Class ProgIDInfo
Private WshShell, sCVProgID, oFSO
Private Sub Class_Initialize()
On Error Resume Next
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set WshShell = CreateObject("WScript.Shell")
End Sub
Private Sub Class_Terminate()
If IsObject(WshShell) Then Set WshShell = Nothing
If IsObject(oFSO) Then Set oFSO = Nothing
End Sub
Private Function IIf(ByVal conditions, ByVal trueval, ByVal falseval)
If CBool(conditions) Then IIf = trueval Else IIf = falseval
End Function
Public Function LoadProgID(ByVal sProgramID)
Dim sTmpProg, oTmp, sRegBase, sDesc, sClsID
Dim sPath, sTypeLib, sProgID, sVers, sPathSpec
If IsObject(WshShell) Then
On Error Resume Next
sCVProgID = WshShell.RegRead("HKCR" & _
sProgramID & "CurVer")
sTmpProg = IIf(Err.number = 0, sCVProgID, sProgramID)
sRegBase = "HKCR" & sTmpProg
sDesc = WshShell.RegRead(sRegBase & "")
sClsID = WshShell.RegRead(sRegBase & "clsid")
sRegBase = "HKCRCLSID" & sClsID
sPath = WshShell.RegRead(sRegBase & "InprocServer32")
sPath = WshShell.ExpandEnvironmentStrings(sPath)
sTypeLib = WshShell.RegRead(sRegBase & "TypeLib")
sProgID = WshShell.RegRead(sRegBase & "ProgID")
sVers = oFSO.getFileVersion(sPath)
sPathSpec = Right(sPath, Len(sPath) - _
InStrRev(sPath, ""))
Set oTmp = New Program
oTmp.Description = sDesc
oTmp.ClsID = IIf(sClsID <> "", sClsID, "undetermined")
oTmp.Path = IIf(sPath <> "", sPath, "undetermined")
oTmp.TypeLib = IIf(sTypeLib <> "", _
sTypeLib, "undetermined")
oTmp.ProgID = IIf(sProgID <> "", _
sProgID, "undetermined")
oTmp.DLLName = IIf(sPathSpec <> "", _
sPathSpec, "undetermined")
oTmp.Version = IIf(sVers <> "", sVers, "undetermined")
Set LoadProgID = oTmp
Else
Set LoadProgID = Nothing
End If
End Function
End Class
%>

25
asp/ActiveX_ADO_Arrays/Random Array.asp Normal file
View File

@ -0,0 +1,25 @@
Function RandomArray(alen, LBound, UBound)
Dim i, j, exists, nextrand, newrandom, result
result = Null
If (alen >= 1) Then
ReDim result(alen - 1)
Randomize
For i = 0 To alen - 1
nextrand = True
Do While nextrand
exists = False
newrandom = Int((UBound - LBound + 1) * Rnd + LBound)
For j = 0 To i - 1
exists = exists Or (result(j) = newrandom)
Next
If (Not exists) Then
nextrand = False
result(i) = newrandom
End If
Loop
Next
End If
RandomArray = result
End Function

22
asp/ActiveX_ADO_Arrays/SelectionSort Function.asp Normal file
View File

@ -0,0 +1,22 @@
<%
Private Function SelectionSort(ByVal unsortedarray)
Dim Front, Back, I, Loc, Selcom
Dim Temp, Selswap, Arrsize
Arrsize = UBound(unsortedarray)
For Front = 0 To Arrsize - 1
Loc = Front
For Back = Front To Arrsize
Selcom = Selcom + 1
If unsortedarray(Loc) > _
unsortedarray(Back) Then
Loc = Back
End If
Next
Selswap = Selswap + 1
Temp = unsortedarray(Loc)
unsortedarray(Loc) = unsortedarray(Front)
unsortedarray(Front) = Temp
Next
SelectionSort = unsortedarray
End Function
%>

32
asp/ActiveX_ADO_Arrays/Send a Ringtone to Nokia phones in ASP.asp Normal file
View File

@ -0,0 +1,32 @@
<%
Set sms = Server.CreateObject( "Simplewire.SMS" )
' Subscriber Settings
sms.SubscriberID = "123-123-123-12345"
sms.SubscriberPassword = "Password Goes Here"
' Message Settings
sms.MsgPin = "+1 100 510 1234"
sms.MsgFrom = "Demo"
sms.MsgCallback = "+1 100 555 1212"
' Smart Message Settings
sms.OptPhone = "nokia"
sms.MsgRingtone = "Simplewire:d=4,o=5,b=63:8a,8e,32a,32e,16a,8c6,8a,32c6,32a,16c6,8e6,8c6,32e6,32c6,16e6,8g6,32g,32p,16g,32c6,32g,16c6,8e6,32p"
Response.Write("<b>Sending message to Simplewire...</b><br>")
' Send Message
sms.MsgSend
' Check For Errors
If (sms.Success) Then
Response.Write("<b>Message was sent!</b><br>")
Else
Response.Write("<b>Message was not sent!</b><br>")
Response.Write("Error Code: " & sms.ErrorCode & "<br>")
Response.Write("Error Desc: " & sms.ErrorDesc & "<br>")
End If
Set sms = Nothing
%>

34
asp/ActiveX_ADO_Arrays/Send an Operator Logo to Nokia phones in ASP.asp Normal file
View File

@ -0,0 +1,34 @@
<%
Set sms = Server.CreateObject( "Simplewire.SMS" )
' Subscriber Settings
sms.SubscriberID = "123-123-123-12345"
sms.SubscriberPassword = "Password Goes Here"
' Message Settings
sms.MsgPin = "+1 100 510 1234"
sms.MsgFrom = "Demo"
sms.MsgCallback = "+1 100 555 1212"
' Smart Message Settings
sms.OptPhone = "nokia"
sms.OptCountryCode = "Country Code goes here"
sms.OptNetworkCode = "Network Code goes here"
sms.MsgOperatorLogoFilename = Server.MapPath("example.gif")
Response.Write("<b>Sending message to Simplewire...</b><br>")
' Send Message
sms.MsgSend
' Check For Errors
If (sms.Success) Then
Response.Write("<b>Message was sent!</b><br>")
Else
Response.Write("<b>Message was not sent!</b><br>")
Response.Write("Error Code: " & sms.ErrorCode & "<br>")
Response.Write("Error Desc: " & sms.ErrorDesc & "<br>")
End If
Set sms = Nothing
%>

40
asp/ActiveX_ADO_Arrays/Sort arrays.asp Normal file
View File

@ -0,0 +1,40 @@
Sort arrays
'--------Begin Function----
Function fnSort(aSort, intAsc)
Dim intTempStore
Dim i, j
For i = 0 To UBound(aSort) - 1
For j = i To UBound(aSort)
'Sort Ascending
If intAsc = 1 Then
If aSort(i) > aSort(j) Then
intTempStore = aSort(i)
aSort(i) = aSort(j)
aSort(j) = intTempStore
End If 'i > j
'Sort Descending
Else
If aSort(i) < aSort(j) Then
intTempStore = aSort(i)
aSort(i) = aSort(j)
aSort(j) = intTempStore
End If 'i < j
End If 'intAsc = 1
Next 'j
Next 'i
fnSort = aSort
End Function 'fnSort
'-------------------------
Dim aUnSort(3), aSorted
aUnSort(0) = 4
aUnSort(1) = 2
aUnSort(2) = 6
aUnSort(3) = 20
'call the function
'second argument:
' * ascending sorted = 1
' * descending sorting = any other chara
' cter
aSorted = fnSort(aUnSort, 1)
Erase aUnSort

19
asp/ActiveX_ADO_Arrays/Using a Stored Procedure with ADO.asp Normal file
View File

@ -0,0 +1,19 @@
Using a Stored Procedure with ADO
Dim cn As New ADODB.Connection
cn.Open sConStr
Dim cmd As New ADODB.Command
cn.CursorLocation = adUseClient
Set cmd.ActiveConnection = cn
cmd.CommandText = "addNew_Service"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Refresh
cmd.Parameters.Item("@wsdlfilename") = CStr(services(serviceId).wsdlfilename)
cmd.Parameters.Item("@WSMLFileName") = CStr(services(serviceId).WSMLFileName)
cmd.Parameters.Item("@name") = CStr(services(serviceId).name)
cmd.Parameters.Item("@description") = CStr(services(serviceId).description)
cmd.Parameters.Item("@uuid") = CStr(sUUID)
cmd.Parameters.Item("@Service_ID") = 0
cmd.Execute
Debug.Print Err.description
newService_ID = cmd.Parameters("@Service_ID").Value

36
asp/ActiveX_ADO_Arrays/Version Check.asp Normal file
View File

@ -0,0 +1,36 @@
<%@ language=vbscript%>
<HTML>
<HEAD>
<TITLE>versioncheck.asp</TITLE>
</HEAD>
<body bgcolor="#FFFFFF">
<script language=jscript runat=server>
Response.Write ("scripting engine=<b>" + ScriptEngine() + "</b><br>");
Response.Write ("buildversion=<b>" + ScriptEngineBuildVersion() + "</b><br>");
Response.Write ("majorversion=<b>" + ScriptEngineMajorVersion() + "</b><br>");
Response.Write ("minorversion=<b>" + ScriptEngineMinorVersion() + "</b><br>");
</script>
<%
Response.Write "<hr><br>"
Response.Write "scripting engine=<b>" & ScriptEngine() & "</b><br>"
Response.Write "buildversion=<b>" & ScriptEngineBuildVersion() & "</b><br>"
Response.Write "majorversion=<b>" & ScriptEngineMajorVersion() & "</b><br>"
Response.Write "minorversion=<b>" & ScriptEngineMinorVersion() & "</b><br>"
Response.Write "<hr><br>"
Set tempconn=Server.CreateObject("adodb.connection")
Response.Write "ado version=<b>"
Response.Write tempconn.version & "</b><br>"
Set tempconn=Nothing
Response.Write "<hr><br>"
serversoftware=Request.ServerVariables("server_software")
Response.Write "server software=<b>"
Response.Write serversoftware & "</b><br>"
Response.Write "Script Timeout = <b>" & Server.ScriptTimeout & " seconds</b><br>"
Response.Write "Session Timeout = <b>" & Session.Timeout & " minutes</b><br>"
%>
</BODY></HTML>

130
asp/Components/ASP Mail Interface.asp Normal file
View File

@ -0,0 +1,130 @@
<SCRIPT LANGUAGE="VBScript" RUNAT=SERVER>
' requires: _const, _err
Function GetMailObject
Dim mo
On Error Resume Next
PushLocalError
GetMailObject = Null
Set mo = Server.CreateObject("SMTPsvg.Mailer")
If CheckPopError Then
Exit Function
End If
mo.CharSet = 2
mo.ContentType = "text/html"
mo.FromName = fromname
mo.FromAddress = fromaddress
mo.Organization = company
mo.Priority = 3
mo.RemoteHost = mailhost
Set GetMailObject = mo
PopError
End Function
Function SendMailEx(SendName, SendAddr, Subject, Body)
Dim mo, i, result
On Error Resume Next
PushLocalError
If (root = "Local") Then
SendMailEx = True
PopError
Exit Function
End If
SendMailEx = False
Set mo = GetMailObject
If CheckError Or IsNull(mo) Then
PopError
Exit Function
End If
' mo.SMTPLog = uploadroot & "log.txt"
mo.Subject = Subject
mo.BodyText = Body
If IsArray(SendName) And IsArray(SendAddr) Then
For i = LBound(SendName) To UBound(SendName)
mo.AddBCC SendName(i), SendAddr(i)
Next
Else
mo.AddRecipient SendName, SendAddr
End If
result = mo.SendMail
If CheckPopError Then
Exit Function
End If
SendMailEx = result
PopError
End Function
Function SendMail(SendTo, Subject, Body)
SendMail = SendMailEx(SendTo, SendTo, Subject, Body)
End Function
Function SendMailFromFile(SendTo, Subject, FileName)
Dim mo, i, result
On Error Resume Next
PushLocalError
If (root = "Local") Then
SendMailFromFile = True
PopError
Exit Function
End If
SendMailFromFile = False
Set mo = GetMailObject
If CheckError Or IsNull(mo) Then
PopError
Exit Function
End If
' mo.SMTPLog = uploadroot & "log.txt"
mo.Subject = Subject
If IsArray(SendTo) Then
For i = LBound(SendTo) To UBound(SendTo)
mo.AddBCC SendTo(i), SendTo(i)
Next
Else
mo.AddRecipient SendTo, SendTo
End If
result = mo.GetBodyTextFromFile(FileName, False, False)
If CheckPopError Then
Exit Function
End If
If result Then
result = mo.SendMail
If CheckPopError Then
Exit Function
End If
End If
SendMailFromFile = result
PopError
End Function
</SCRIPT>

34
asp/Components/Auto Generate Password.asp Normal file
View File

@ -0,0 +1,34 @@
<%@ Language=VBScript %>
<HTML>
<HEAD>
</HEAD>
<BODY>
<%
Function gen_key(digits)
dim char_array(50)
iTestChar = Asc("0")
For i = 0 To 9
char_array(i) = Chr(iTestChar)
iTestChar = iTestChar + 1
Next
iTestChar = Asc("A")
For i = 10 To 10 + 25
char_array(i) = Chr(iTestChar)
iTestChar = iTestChar + 1
Next
randomize
do while len(output) < digits
num = char_array(Int((35 - 12 + 1) * Rnd + 5))
output = output + num
loop
gen_key = output
End Function
response.write gen_key(13)
%>
</BODY>
</HTML>

20
asp/Components/Know all drive properties through file system.asp Normal file
View File

@ -0,0 +1,20 @@
<%
'Know all drive properties through file system object
Dim fso, drv, s,strDir
'if directory name is H:\docuemnts strDir="H:\docuemnts\"
Set fso = CreateObject("Scripting.FileSystemObject")
Set drv = fso.GetDrive(fso.GetDriveName(strDir))
s = "Drive " & UCase(drv.Path) & "<br>"
s = s & drv.driveType & "<br>"
s = s & drv.FileSystem & "<br>"
s = s & drv.IsReady & "<br>"
s = s & drv.Path & "<br>"
s = s & drv.RootFolder & "<br>"
s = s & drv.ShareName & "<br>"
s = s & drv.VolumeName & "<br>"
s = s & drv.driveType & "<br>"
Response.Write s
%>

53
asp/Components/Limiting the Upload Size.asp Normal file
View File

@ -0,0 +1,53 @@
<html>
<head>
<title>Limit File Size</title>
</head>
<body>
Thank you For uploading your file.<br>
<% Set upl = Server.CreateObject(SoftArtisans.FileUp) %>
<% upl.MaxBytes = 1000 '--- limit the upload size to 1000 bytes %>
The maximum file size that you are permitted To upload Is <%=upl.MaxBytes%> bytes.<br>
<% upl.SaveAs C: empupload.out %>
Total Bytes Written: <%=upl.TotalBytes%><br>
Server File Name: <%=upl.ServerName%><br>
Total Bytes Transmitted: <%=Request.TotalBytes%>
</body>
</html>
Restricting File Types
Use SA-FileUp's ContentType property and a Select condition to save only files of a specific type.
<html>
<head>
<title>Limit File Type</title>
</head>
<body>
<% Set upl = Server.CreateObject("SoftArtisans.FileUp")
'--- Parse out the file name
FName = Mid(upl.UserFilename, InStrRev(upl.UserFilename, ) + 1)
'--- Retrieve the file's content type and assign it to a variable
FCONT = upl.ContentType
'--- Restrict the file types saved using a Select condition
Select Case LCase(FCONT)
Case "image/gif"
upl.Save
Response.Write <P> & FName & has been saved.
Case image/pjpeg
upl.Save
Response.Write <P> & FName & has been saved.
Case Else
upl.delete
Response.Write <P> & You may only upload gif And jpeg files.<BR>
Response.End
End Select
%>
</body>
</html>

33
asp/Components/MkSheet Statement.asp Normal file
View File

@ -0,0 +1,33 @@
<% MkSheet Server.MapPath("/file.xls") %>
source code:
<%
Private Sub MkSheet(ByVal pathname)
Dim objXls, objBook, objFSO
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists( pathname ) Then
Set objFSO = Nothing
Err.Raise 5150, "MkSheet Statement", _
"File Already Exists! MkSheet " & _
"can only create sheets."
Exit Sub
End If
Set objFSO = Nothing
On Error Resume Next
Set objXls = CreateObject("Excel.Application")
If Err Then
Err.Clear
On Error GoTo 0
Err.Raise 5150, "MkSheet Statement", _
"Microsoft Excel Is Not Installed " & _
"On This Server!"
Exit Sub
End If
Set objBook = objXls.Workbooks.Add
objBook.SaveAs( pathname )
Set objBook = Nothing
objXls.Quit
Set objXls = Nothing
On Error GoTo 0
End Sub
%>

221
asp/Components/Open Office.asp Normal file
View File

@ -0,0 +1,221 @@
<%
'EXCEL
Dim xls, I, J, tempName, tempPath, tempnum
On Error Resume Next
Set xls = CreateObject("Excel.Application")
With xls
' Make sure there is no minimized window created
.Application.Visible = False
' Add a new workbook
.Workbooks.Add
' Select some cells to put the DATETIME in it
.Range("A1:C1").Select
.Selection.MergeCells = True
.Selection = Now
' populate some cells
For I = 2 To 15
For J = 2 To 20
tempnum = 12
If J = 15 Then
.Cells(J, I).Value = Sqr(i*j) / (i^tempnum)
ElseIf J = 10 Then
.Cells(J, I).Value = (i+j) * (i^tempnum)
Else
.Cells(J, I).Value = (i+j)^2
End If
Next
Next
.Charts.Add
.ActiveChart.ChartType = 67 'xlLineMarkersStacked100 = 67
' xlColumns = 2
.ActiveChart.SetSourceData .Sheets("Sheet1").Range("B2:O20"), 2
' xlLocationAsNewSheet = 1
.ActiveChart.Location 1
With .ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = "My Kewl Chart number #" & CStr(tempnum)
.Axes(1, 1).HasTitle = True
.Axes(1, 1).AxisTitle.Characters.Text = "X axis for you"
.Axes(2, 1).HasTitle = True
.Axes(2, 1).AxisTitle.Characters.Text = "Y axis for me"
End With
With .ActiveChart.Axes(1)
.HasMajorGridlines = True
.HasMinorGridlines = False
End With
With .ActiveChart.Axes(2)
.HasMajorGridlines = True
.HasMinorGridlines = False
End With
.ActiveChart.HasLegend = True
.ActiveChart.Legend.Select
' xlBottom = -4107
.Selection.Position = -4107
' xlDataLabelsShowNone = -4142
.ActiveChart.ApplyDataLabels -4142, False
.ActiveChart.HasDataTable = False
' Make a path for the file to be saved
tempName = Hour(Now) & Minute(Now) & Second(Now) & ".xls"
tempPath = "d:inetpubwwwroot esting" & tempName
' Save the Workbook in my web drive
.Application.DisplayAlerts = False
.Sheets("Sheet2").Select
.ActiveWindow.SelectedSheets.Delete
.Sheets("Sheet3").Select
.ActiveWindow.SelectedSheets.Delete
.Sheets("Chart1").Select
.Application.DisplayAlerts = True
.ActiveWorkbook.SaveAs tempPath
'.ActiveWorkBook.PrintOut 1
.ActiveWorkbook.Close
' VERY IMPORTANT HERE
' Quit the Application
' xls.Quit is NOT enough...is it only the reference to the Excel Object
' you still have to terminate the Application
.Application.Quit
End With
' VERY IMPORTANT HERE
' Release the memory
Set xls = Nothing
'***********************************
'WORD
Dim wrd, doc, filepath, filename
On Error Resume Next
Set wrd = CreateObject("Word.Application")
With wrd
' Make sure there is no minimized window created
.Application.Visible = False
' Add a new document
.Documents.Add
filepath = "d:inetpubwwwroot"
filename = "silly" & Second(Now) & ".doc"
.ActiveDocument.SaveAs filepath & filename, 0 ' Word Document Format
doc = "This is a document" & vbCrLf
doc = doc & "IDENTIFICATION: ME!!!" & vbCrLf
doc = doc & Date & vbCrLf
doc = doc & filepath & vbCrLf & vbCrLf
doc = doc & "WHAT DO YOU WANT???"
With .Selection
.Selection.TypeText doc
.Selection.WholeStory
.Selection.Font.Name = "Courier New"
.Selection.Font.Bold = True
.Selection.Font.Italic = True
.Selection.Font.Size = 32
.Selection.HomeKey
End With
.ActiveDocument.Close -1 'Save Changes
' VERY IMPORTANT HERE
' Quit the Application
' wrd.Quit is NOT enough...is it only the reference to the Word Object
' you still have to terminate the Application
.Application.Quit
End With
' VERY IMPORTANT HERE
' Release the memory
Set wrd = Nothing
'***********************************
'MSACCESS
Dim msa, I, J, tempName, tempPath, tempnum
Dim Mywk, newDb
On Error Resume Next
Set msa = CreateObject("Access.Application")
tempName = Hour(Now) & Minute(Now) & Second(Now) & ".mdb"
tempPath = "d:inetpubwwwroot esting" & tempName
Set Mywk = msa.DBEngine.Workspaces(0)
Set newDb = Mywk.CreateDatabase(tempPath, ";LANGID=0x0409;CP=1252;COUNTRY=0")
newDb.close
Mywk.Close
Set newDb = Nothing
Set Mywk = Nothing
msa.Application.Quit
Set msa = Nothing
'***********************************
'POWERPOINT
'***********************************
Dim ppt, I, J, tempName, tempPath, tempnum
On Error Resume Next
Set ppt = CreateObject("PowerPoint.Application")
tempName = Hour(Now) & Minute(Now) & Second(Now) & ".ppt"
tempPath = "d:inetpubwwwroot esting" & tempName
ppt.Presentations.Add -1
ppt.ActiveWindow.View.GotoSlide ppt.ActivePresentation.Slides.Add(1, 12).SlideIndex
ppt.ActiveWindow.Selection.SlideRange.Shapes.AddLabel(1, 114, 156, 474, 36).Select
ppt.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters(1, 0).Select
With ppt.ActiveWindow.Selection.TextRange
.Text = "WOW THIS WORKS!!!"
With .Font
.Name = "Times New Roman"
.Size = 24
.Bold = 0
.Italic = 0
.Underline = 0
.Shadow = -1
.Emboss = 0
.BaselineOffset = 0
.AutoRotateNumbers = 0
.Color.SchemeColor = 2
End With
End With
ppt.ActiveWindow.Selection.Unselect
ppt.ActivePresentation.SaveAs tempPath
ppt.ActivePresentation.Close
' there is no Application object for PPT, so just quit ppt
ppt.Quit
' Release the memory to PPT
Set ppt = Nothing
%>

73
asp/Components/Protect your Client Side Script with ASP.asp Normal file
View File

@ -0,0 +1,73 @@
' Name: Protect your Client Side Script
' with ASP v1.1
' Description:This code will allow you t
' o use ASP to check that the request for
' your JavaScript and VBScript is a "real"
' request or just someone trying to steal
' your code. If the request.servervariable
' s("HTTP_REFERER") returns a page from yo
' ur site then your return the JavaScript
' if request.servervariables("HTTP_REFERER
' ") doesn't return a page from your site
' you return an appropriate response of yo
' ur own.
' Inputs:This is the basic idea laid out
' for you to examine. You will still have
' to do a little work to integrate it in t
' o your site but it isn't much more than
' copy and paste.
The Input Request.ServerVariables("HTTP_REFERER") which Is automatically sent by the browser.
'
' Returns:Will return the JavaScript or
' VBScript if appropriate, if not a messag
' e to the user.
'
' Side Effects:It doesn't seem to work o
' n Netscape without setting up IIS to par
' se .js files like it does .asp. The user
' can still open the file from the user's
' cache unless you include:
<%
Response.Expires = 60
Response.ExpiresAbsolute = Now() - 1
Response.AddHeader "pragma","no-cache"
Response.AddHeader "cache-control","private"
Response.CacheControl = "no-cache"
%>
At the top of the protected JavaScript file. This Is stop the browser from saving a Local copy of the file.
'
Use the line below In place of your normal JavaScript include line.
<SCRIPT src="testcjs.asp" language="JavaScript" Type="text/javascript"></SCRIPT>
Use the code below In place of your normal JavaScript .JS file. It must be saved As a .ASP file Or it will Not work. Actually, you can Set IIS server To read .js files just like it does .asp files. This Is a good idea To hide your protection scheme For any users who are trying bypass it. Then you could save it As a .js file.
If you Do this a lot more people will be stumped.
Of course you could just As easily protect your vbscript With the technique too.
<%
' This is to force file to open save as
' dialog box and not open in user's browse
' r
' It would be even safer to have it as "
' badtype/badtype" instead of "text/javasc
' ript"
Response.ContentType = "text/javascript"
' Set the line below to the page that wi
' ll be granted acess to the file
' You could change the test to allow all
' pages on your site access, etc.
If (Request.ServerVariables("HTTP_REFERER") = "http://www.mysite.com/myfolder/mypage.asp") Then
%>
/* This Is where you put the real JavaScript that you want To run */
document.write(" ACCESS GRANTED @ <%=time%> <BR/>");
document.write(" request.servervariables("HTTP_REFERER") = "<%=Request.ServerVariables("HTTP_REFERER")%>"");
<%
Else
%>
/* This Is where you put the message you want users To see In place of your real JavaScript */
/* I wouldn't use the bottom line since it will give away your protection scheme and help */
/* users find a way To break it */
No soup For you.
Request.ServerVariables("HTTP_REFERER") = "<%=request.servervariables("HTTP_REFERER")%>"
<%
End If
%>

52
asp/Components/Selected item in Combo Box from database - more thoughts.asp Normal file
View File

@ -0,0 +1,52 @@
<%@ Language=VBScript
EnableSessionState=False %>
<%
Option Explicit
Dim oConn ' as adodb.Connection
Dim oRs ' as ADODB.Recordset
Dim oRsCity ' as ADODB.Recordset
Dim strClientCity ' as string
Dim strSQL ' as string
Dim strCity ' as string
set oConn = server.createobject("ADODB.Connection")
Call oConn.Open("Provider=SQLOledb;Data Source=(local);Initial Catalog=Tryit; Integrated Security=SSPI;")
'Set oRs = Server.CreateObject("Adodb.recordset")
'strSQL = "Select fldCity from tblClientDetail where clname = N'Fred'"
'Call oRs.Open(strsql, oConn, adOpenForwardOnly, adLockReadOnly, adCmdText)
'if not oRs.EOF then
' strClientCity=objRS("fldCity")
'end if
'Call oRs.Close()
'Set oRs = Nothing
strClientCity = "Delhi"
Set oRsCity = Server.CreateObject("Adodb.recordset")
strSQL = "Select name from Cities Order by Name"
Call oRsCity.Open(strsql, oConn, adOpenForwardOnly, adLockReadOnly, adCmdText)
%>
<HTML>
<HEAD>
</HEAD>
<BODY>
<form name="frmLogin" method="post" action="modifyClient.asp">
select combobox:<br>
<select class="textboxes1" name="city" style="font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 8pt;">
<%
Call Response.Write("<option value=''")
If oRsCity.EOF Then Call Response.Write(" Selected='yes'")
Call Response.Write(">Select</option>" & vbCrLf)
Do until oRsCity.EOF
strCity = oRsCity.Fields(0).Value
Call Response.Write("<option value='" & Server.HTMLEncode(strCity) & "'")
If strClientCity = strCity Then Call Response.Write(" Selected='yes'")
Call Response.Write(">" & strCity & "</option>" & vbCrLf)
Call oRsCity.MoveNext()
loop
%>
</select>
</BODY>
</HTML>

29
asp/Components/Send a 1-Way SMS in ASP.asp Normal file
View File

@ -0,0 +1,29 @@
<%
Set sms = Server.CreateObject( "Simplewire.SMS" )
' Subscriber Settings
sms.SubscriberID = "123-123-123-12345"
sms.SubscriberPassword = "Password Goes Here"
' Message Settings
sms.MsgPin = "+1 100 510 1234"
sms.MsgFrom = "Demo"
sms.MsgCallback = "+1 100 555 1212"
sms.MsgText = "Hello World From Simplewire!"
Response.Write("<b>Sending message to Simplewire...</b><br>")
' Send Message
sms.MsgSend
' Check For Errors
If (sms.Success) Then
Response.Write("<b>Message was sent!</b><br>")
Else
Response.Write("<b>Message was not sent!</b><br>")
Response.Write("Error Code: " & sms.ErrorCode & "<br>")
Response.Write("Error Desc: " & sms.ErrorDesc & "<br>")
End If
Set sms = Nothing
%>

159
asp/Components/System Detector.asp Normal file
View File

@ -0,0 +1,159 @@
<HTML>
<HEAD>
<TITLE>Detecting System Components</TITLE>
</HEAD>
<BODY BGCOLOR="#FFFFFF" Text="#000000" TOPMARGIN="0" LEFTMARGIN="0" MARGINHEIGHT="0" MARGINWIDTH="0"><TABLE BORDER="0" WIDTH="100%" CELLSPACING="0" CELLPADDING="0"><TR><TD WIDTH="25%" BGCOLOR="#465697"> </TD>
<TD WIDTH="100%" BGCOLOR="#465697"><FONT FACE="Verdana" SIZE="2" COLOR="#FFFFFF"><B>Detecting Email Components...</B>
</FONT>
</TD>
<TD WIDTH="25%" BGCOLOR="#465697"> </TD>
</TR>
<TR><TD COLSPAN="3" WIDTH="100%"> </TD>
</TR>
<TR><TD WIDTH="25%"> </TD>
<TD WIDTH="50%"><FONT FACE="Verdana" SIZE="2"><%
Dim sql_control
Dim sql_con_trol
sql_con_trol = 0
On Error Resume Next
Set sql_control = CreateObject("VSEmail.SMTPSendMail")
If Err Then
Else
Response.Write "Detected: <B><FONT COLOR=""#009900"">VSEmail</FONT></B><BR>" & vbCrLf
sql_con_trol = sql_con_trol + 1
End If
Err.Clear
Set sql_control = CreateObject("Persits.MailSender")
If Err Then
Else
Response.Write "Detected: <B><FONT COLOR=""#009900"">ASPEmail</FONT></B><BR>" & vbCrLf
sql_con_trol = sql_con_trol + 1
End If
Err.Clear
Set sql_control = Server.CreateObject("CDONTS.NewMail")
If Err Then
Else
Response.Write "Detected: <B><FONT COLOR=""#009900"">CDONTS</FONT></B><BR>" & vbCrLf
sql_con_trol = sql_con_trol + 1
End If
Err.Clear
Set sql_control = Server.CreateObject("SMTPsvg.Mailer")
If Err Then
Else
Response.Write "Detected: <B><FONT COLOR=""#009900"">ASPMail</FONT></B><BR>" & vbCrLf
sql_con_trol = sql_con_trol + 1
End If
Err.Clear
Set sql_control = Server.CreateObject("JMail.SMTPMail")
If Err Then
Else
Response.Write "Detected: <B><FONT COLOR=""#009900"">JMail 3.7</FONT></B><BR>" & vbCrLf
sql_con_trol = sql_con_trol + 1
End If
Err.Clear
Set sql_control = Server.CreateObject("JMail.Message")
If Err Then
Else
Response.Write "Detected: <B><FONT COLOR=""#009900"">JMail 4.1</FONT></B><BR>" & vbCrLf
sql_con_trol = sql_con_trol + 1
End If
Err.Clear
Set sql_control = Server.CreateObject("Dynu.Email")
If Err Then
Else
Response.Write "Detected: <B><FONT COLOR=""#009900"">Dynu Mail</FONT></B><BR>" & vbCrLf
sql_con_trol = sql_con_trol + 1
End If
Err.Clear
Set sql_control = Server.CreateObject("ADISCON.SimpleMail.1")
If Err Then
Else
Response.Write "Detected: <B><FONT COLOR=""#009900"">Simple Mail</FONT></B><BR>" & vbCrLf
sql_con_trol = sql_con_trol + 1
End If
Err.Clear
Set sql_control = Server.CreateObject("ASPMail.ASPMailCtrl.1")
If Err Then
Else
Response.Write "Detected: <B><FONT COLOR=""#009900"">OCXMail</FONT></B><BR>" & vbCrLf
sql_con_trol = sql_con_trol + 1
End If
Err.Clear
If sql_con_trol > 0 Then
Response.Write "<BR><BR>Found <B>" & sql_con_trol & "</B> components." & vbCrLf
Response.Write "<BR>" & vbCrLf
Response.Write "<BR>Please inform your Mail-Robot administrator about the installed components." & vbCrLf
Response.Write "<BR>" & vbCrLf
Response.Write "<BR><B><A HREF=""mailto:yellowbaris@yahoo.com"">yellowbaris@yahoo.com</A></B>" & vbCrLf
Else
Response.Write "<BR>" & vbCrLf
Response.Write "<BR>Your sever has Not installed any of the email components spidered by this program." & vbCrLf
Response.Write "<BR>" & vbCrLf
Response.Write "<BR>Please contact your web server administrator to be informed" & vbCrLf
Response.Write "<BR>about the installed <B>email components</B> on your server." & vbCrLf
End If
%></FONT>
</TD>
<TD WIDTH="25%"> </TD>
</TR>
</TABLE>
<BR>
<BR>
<TABLE BORDER="0" WIDTH="100%" CELLSPACING="0" CELLPADDING="0"><TR><TD WIDTH="25%" BGCOLOR="#465697"> </TD>
<TD WIDTH="100%" BGCOLOR="#465697"><FONT FACE="Verdana" SIZE="2" COLOR="#FFFFFF"><B>Detecting FileSystem Components...</B>
</FONT>
</TD>
<TD WIDTH="25%" BGCOLOR="#465697"> </TD>
</TR>
<TR><TD COLSPAN="3" WIDTH="100%"> </TD>
</TR>
<TR><TD WIDTH="25%"> </TD>
<TD WIDTH="50%"><FONT FACE="Verdana" SIZE="2"><%
On Error Resume Next
OutHTML = ""
Set FSO = CreateObject("Scripting.FileSystemObject")
Set act = FSO.CreateTextFile(Server.MapPath("testfile.txt"), True)
act.WriteLine("TestLine")
act.Close
Set act = Nothing
If Err = 0 Then
OutHTML = OutHTML & "<BR>Creating of files supported..." & vbCrLf
Else
OutHTML = OutHTML & "<BR>Creating of files <B>Not</B> supported..." & vbCrLf
End If
fso.DeleteFile(Server.MapPath("testfile.txt"))
If Err = 0 Then
OutHTML = OutHTML & "<BR>Deleting and Modifying of files supported..." & vbCrLf
Else
OutHTML = OutHTML & "<BR>Deleting and Modifying of files <B>Not</B> supported..." & vbCrLf
OutHTML = OutHTML & "<BR>This causes Mail-Robot Not To work propperly." & vbCrLf
End If
Set FSO = Nothing
If Err > 0 Then
Response.Write "<B>Scripting.FileSystemObject Not full supported.</B>" & vbCrLf
Else
Response.Write "Detected: <B><FONT COLOR=""#009900"">Scripting.FileSystemObject</FONT></B><BR><BR>" & vbCrLf
c1 = c1 + 1
End If
Err.Clear
Response.Write OutHTML
If c1 > 0 Then
Response.Write "<BR>Found <B>" & c1 & "</B> components." & vbCrLf
Response.Write "<BR>" & vbCrLf
Response.Write "<BR>Please inform your Mail-Robot administrator about the installed components." & vbCrLf
Response.Write "<BR>" & vbCrLf
Response.Write "<BR><B><A HREF=""mailto:yellowbaris@yahoo.com"">yellowbaris@yahoo.com</A></B>" & vbCrLf
Else
Response.Write "<BR>" & vbCrLf
Response.Write "<BR>Please inform your Mail-Robot administrator about the installed components." & vbCrLf
Response.Write "<BR>" & vbCrLf
Response.Write "<BR>Please contact your web server administrator to be informed" & vbCrLf
Response.Write "<BR>about the installed <B>FileSystemObjects</B> on your server." & vbCrLf
End If
%></FONT>
</TD>
<TD WIDTH="25%"> </TD>
</TR>
</TABLE>
</BODY>
</HTML>

36
asp/Components/URL Decode.asp Normal file
View File

@ -0,0 +1,36 @@
<%
Function myURLDecode(strString)
strString = Replace(strString, "%2F", "/")
strString = Replace(strString, "%7C", "|")
strString = Replace(strString, "%3F", "?")
strString = Replace(strString, "%21", "!")
strString = Replace(strString, "%40", "@")
strString = Replace(strString, "%5C", "")
strString = Replace(strString, "%23", "#")
strString = Replace(strString, "%24", "$")
strString = Replace(strString, "%5E", "^")
strString = Replace(strString, "%26", "&")
strString = Replace(strString, "%25", "%")
strString = Replace(strString, "%2A", "*")
strString = Replace(strString, "%28", "(")
strString = Replace(strString, "%29", ")")
strString = Replace(strString, "%7D", "}")
strString = Replace(strString, "%3A", ":")
strString = Replace(strString, "%2C", ",")
strString = Replace(strString, "%7B", "{")
strString = Replace(strString, "%2B", "+")
strString = Replace(strString, "%2E", ".")
strString = Replace(strString, "%2D", "-")
strString = Replace(strString, "%7E", "~")
strString = Replace(strString, "%2D", "-")
strString = Replace(strString, "%5B", "[")
strString = Replace(strString, "%5F", "_")
strString = Replace(strString, "%5D", "]")
strString = Replace(strString, "%60", "`")
strString = Replace(strString, "%3D", "=")
strString = Replace(strString, "%27", "'")
strString = Replace(strString, "+", " ")
strString = Replace(strString, "%22", Chr(34))
myURLDecode = strString
End Function
%>

87
asp/Components/Universal URL check.asp Normal file
View File

@ -0,0 +1,87 @@
'<INPUT type="text" name="url">
' Assumes:There are 3 pages:
'check.asp To post the url and receive the result of the check.
'checkurl.asp this page will Do the check
'checkdone.asp; this page will post the results back To the referer.
'
' Side Effects:In order to make this scr
' ipt work you server should have IE 5+ in
' stalled.
'
'****** check.asp ****
'part 1: the post form
'*********************
<%
strFrom=Request.Form("result")
strResult=Request.Form("url")
%>
<HTML>
<HEAD>
<TITLE>URL check</TITLE>
</HEAD>
<BODY>
<FORM method="post" action="checkurl.asp">
<P><Input Type="text" name="url"></P>
<P><Input Type="submit" value="submit" name="submit"></P>
</FORM>
<P><%= strFrom %></P>
<P><%= strResult %></P>
</BODY>
</HTML>
'****** checkurl.asp ****
'part 2: the actual check
'************************
<%
strURL=Request.Form("url")
If strURL<>"" Then
If Left(LCase(strURL),7)<>"http://" Then
strURL="http://" & strURL
End If
On Error Resume Next
Dim objHTTP
Dim sHTML
Set objHTTP = Server.CreateObject ("Microsoft.XMLHTTP")
objHTTP.open "GET", strURL, False
objHTTP.send
sHTML=objHTTP.statusText
If err Or sHTML<>"OK" Then
sTxt="fail"
Else
sTxt="ok"
End If
Set objHTTP=Nothing
Else
sTxt="fail"
End If
strFrom=Request.ServerVariables("HTTP_REFERER")
p=InStr(1,strFrom,"?")
If p>0 Then
strFrom=Left(strFrom,p-1)
End If
Response.Redirect "checkdone.asp?result=" & sTxt & "&ref=" & strURL & "&return=" & strFrom
%>
'****** checkdone.asp ****
'part 3: post the results back to the re
' ferer
'************************
<%
strRes=Request.QueryString("result")
strRef=Request.QueryString("ref")
strRet=Request.QueryString("return")
%>
<HTML>
<HEAD>
</HEAD>
<SCRIPT>
Function postit(){
myform.submit();
}
</SCRIPT>
<BODY onLoad="postit()">
<FORM method="post" action="<%= strRet %>" name="myform">
<Input Type="hidden" name="result" value="<%= strRes %>">
<Input Type="hidden" name="url" value="<%= strRef %>">
</FORM>
</BODY>
</HTML>

61
asp/Components/Uploading with SA-FileUp.asp Normal file
View File

@ -0,0 +1,61 @@
<HTML><HEAD>
<TITLE>uploadsimple</TITLE>
</HEAD><body bgcolor="#FFFFFF">
<form enctype="multipart/form-data" method="post" action="uploadsimplerespond.asp">
<TABLE WIDTH="100%">
<TR>
<TD ALIGN="RIGHT" VALIGN="TOP">Filename:</TD>
<TD ALIGN="LEFT"><Input Type="FILE" NAME="FILE1">
</TD>
</TR>
<TR>
<TD ALIGN="RIGHT"> </TD>
<TD ALIGN="LEFT"><Input Type="SUBMIT" NAME="SUB1" VALUE="Upload File"></TD>
</TR>
<TR>
<TD ALIGN="RIGHT"> </TD>
<TD ALIGN="LEFT">
<B><I><SMALL>Note: If a button labeled "Browse..." does Not appear, Then your
browser does Not support File Upload. For Internet Explorer 3.02 users, a
free add-On Is available from Microsoft. If you <b>Do Not see a Browse... button</b>
<A HREF="http://www.microsoft.com/msdownload/ieplatform/iewin95/iewin95.asp" TARGET="_new">click here To go To Microsoft's Site and get your free file upload add-on</A>.
Select "Internet Explorer 3.02 File Upload Add-On for Windows 95 & NT".
</SMALL></I></B>
</TD>
</TR>
</TABLE>
</form>
</BODY></HTML>
The Form Definition
To enable file upload, include an Input tag of <Type="FILE"> In your HTML form.
When using a form To upload files, you must Set the following attributes:
The FORM tag must include the attribute ENCTYPE="multipart/form-data".
The <Input Type="FILE"> must include the NAME attribute.
The Server-side Processing
The responder To the form will look like this:
<HTML><HEAD>
<TITLE>Uploadsimplerespond</TITLE>
</HEAD><BODY>
Thank you For uploading your file.<br>
<% Set upl = Server.CreateObject("SoftArtisans.FileUp")
upl.Path = Server.MapPath ("/upload/tests")
upl.SaveAs "upload.tst"%><BR>
Total Bytes Written: <%=upl.TotalBytes%>
</BODY></HTML>
To process the upload On the server,
In the response page (In this Case, uploadsimplerespond.asp) create an instance of the SA-FileUp object.
<% Set upl = Server.CreateObject("SoftArtisans.FileUp") %>
Save the file In a directory On the web server.
<% upl.SaveAs "C: empupload.out" %>
The TotalBytes Property contains the size In bytes of the uploaded file.
The directory On the web server must have Read, Write, And Delete NTFS permissions For the anonymous Or authenticated user. Otherwise, SA-FileUp will Not be able To Write files into that directory. Talk To your web master about setting the appropriate permissions.

44
asp/Components/WSH Script to remove un-needed IIS Script-Mappings.asp Normal file
View File

@ -0,0 +1,44 @@
Dim strExt
Dim myValue
Dim strNothing
Dim strBuild
Dim i
Dim iValue
Set myValue = GetObject("IIS://LocalHost/W3SVC/1/root")
'Returns an array multi valued list
'Puts the values in a local array variable myArray
myArray = myValue.Get("ScriptMaps")
'Loops through building a string
'based on myArray list of values
For i = 0 To UBound(myArray)
iValue = InStr(myArray(i), ",")
strExt = Left(myArray(i), iValue - 1)
Select Case strExt
Case ".idq", ".ida", ".printer", ".htw", ".htr"
'Builds a bogus string of un-needed mappings
strNothing = strNothing & myArray(i)
Case Else
'Builds a string of mappings with
'the # as the delimiter
strBuild = strBuild & myArray(i) & "#"
End Select
Next
'Returns a 1-dimensinonal array based
'on the string i build existing values
strBuild = Split(strBuild, "#")
'Clears current Script Mappings in the metabase
myValue.Put "ScriptMaps", vbNull
'Inserts values without un-needed mappings into metabase
myValue.Put "ScriptMaps", strBuild
myValue.SetInfo
Set myValue = Nothing

149
asp/Data_Access_DateTime/ASP Date Picker.asp Normal file
View File

@ -0,0 +1,149 @@
<%@ Language=VBScript %>
<%
Option Explicit
Const TOP_COORDINATE = 30
Dim curDate
Dim daysCount
Dim lastDay
Dim firstDay
Dim i
Dim topC
Dim leftC
Dim tempDate
Dim curMonth
Dim curYear
Dim calHTML
Dim pDate
Dim curMonthText
Dim rowCount
Dim nextMonth
Dim prevMonth
Dim retControl
curDate = Request("date")
retControl = Request("ctl")
If IsDate(curDate) Then pDate = FormatDateTime(curDate, 0)
If curDate = "" Then
curDate = Now()
Else
If IsDate(curDate) Then curDate = Month(curDate) & "/" & Day(curDate) & "/" & Year(curDate)
End If
If IsDate(curDate) Then
curMonth = Month(curDate)
curMonthText = TextMonth(curMonth) & "-" & Year(curDate)
curYear = Year(curDate)
firstDay = curMonth & "/" & "01" & "/" & curYear
lastDay = DateAdd("d", -1, DateAdd("m", 1, firstDay))
nextMonth = DateAdd("m", 1, firstDay)
nextMonth = FormatDateTime(Month(nextMonth) & "/" & Day(curDate) & "/" & Year(nextMonth), 0) & _
"&ctl=" & retControl
prevMonth = DateAdd("m", -1, firstDay)
prevMonth = FormatDateTime(Month(prevMonth) & "/" & Day(curDate) & "/" & Year(prevMonth), 0) & _
"&ctl=" & retControl
daysCount = CInt(Day(lastDay))
For i = 1 To daysCount
tempDate = curMonth & "/" & i & "/" & curYear
leftC = calcLeft(DatePart("w", tempDate, vbMonday))
topC = calcTop(tempDate)
calHTML = calHTML & _
"<DIV style='text-align: center; position: absolute; width: 50px; left: " & leftC & "px; top: " & topC & _
"px; font-family: Tahoma, Arial; cursor: hand; "
If FormatDateTime(tempDate, vbShortDate) = FormatDateTime(Now, vbShortDate) Then
calHTML = calHTML & "background-color: orange; color: white"
Else
calHTML = calHTML & "background-color: #faf0e6; color: black"
End If
If FormatDateTime(tempDate, vbShortDate) = FormatDateTime(pDate, vbShortDate) Then
calHTML = calHTML & "; border: solid blue 1px"
End If
calHTML = calHTML & "' onClick=" & Chr(34) & "onDateSelected('" & _
fNumber(Month(tempDate)) & "/" & fNumber(Day(tempDate)) & "/" & Year(tempDate) & _
"')" & Chr(34) & ">" & Day(tempDate) & "</DIV>" & vbCrLf
Next
End If
Function fNumber(fNum)
If Len(CStr(fNum)) < 2 Then
fNumber = "0" & CStr(fNum)
Else
fNumber = fNum
End If
End Function
Function calcLeft(wDay)
calcLeft = ((wDay - 1) * 50) + 2
End Function
Function calcTop(wDate)
Dim mStartDate
Dim mStartWeekDay
Dim dRow
mStartDate = Month(wDate) & "/" & "01/" & Year(wDate)
mStartWeekDay = DatePart("w", mStartDate, vbMonday)
dRow = ((mStartWeekDay + CInt(DateDiff("d", mStartDate, wDate))) 7) + 1
If Weekday(wDate, vbMonday) = 7 Then dRow = dRow - 1
calcTop = ((dRow - 1) * 20) + 1 + TOP_COORDINATE
If dRow > rowCount Then rowCount = dRow
End Function
Function TextMonth(dMonth)
Select Case dMonth
Case 1: TextMonth = "January"
Case 2: TextMonth = "February"
Case 3: TextMonth = "March"
Case 4: TextMonth = "April"
Case 5: TextMonth = "May"
Case 6: TextMonth = "June"
Case 7: TextMonth = "July"
Case 8: TextMonth = "August"
Case 9: TextMonth = "September"
Case 10: TextMonth = "October"
Case 11: TextMonth = "November"
Case 12: TextMonth = "December"
End Select
End Function
%>
<HTML>
<HEAD>
<TITLE>Date picker</TITLE>
<LINK REL="stylesheet" Type="text/css" HREF="../site_css.css">
<SCRIPT language="JavaScript">
Function onDateSelected(lDate) {
var cObj = eval("opener.window.document." + hostCtl.value);
If (cObj != Null) {
cObj.value = lDate;
cObj.focus();
}
self.window.close();
}window.open
Function initPos() {
curMonth.style.top = (calRows.value * 20) + 30;
window.resizeTo(360, parseInt(curMonth.style.top, 10) + parseInt(curMonth.clientHeight, 10) + 50);
}
</SCRIPT>
</HEAD>
<BODY topmargin="0" leftmargin="0" onLoad="initPos()">
<Input Type="hidden" id="calRows" name="calRows" value="<%=rowCount%>">
<Input Type="hidden" id="hostCtl" name="hostCtl" value="<%=retControl%>">
<DIV style="position: absolute; left: 2px; top: 2px; width: 350px">
<TABLE width="350">
<TR style="background-color: darkblue; color: white">
<TD width="50" align="center"><B>mon</B></TD>
<TD width="50" align="center"><B>tue</B></TD>
<TD width="50" align="center"><B>wed</B></TD>
<TD width="50" align="center"><B>thu</B></TD>
<TD width="50" align="center"><B>fri</B></TD>
<TD width="50" align="center"><B>sat</B></TD>
<TD width="50" align="center"><B>sun</B></TD>
</TR>
</TABLE>
<%=calHTML%>
</DIV>
<DIV id="curMonth" style="position: absolute; left: 2px; width: 350px; text-align: center;">
<TABLE width="350">
<TR style="background-color: black; color: white">
<TD width="100"><A href="calendar.asp?date=<%=prevMonth%>">Previous</A></TD>
<TD align="center" width="150"><B><%=curMonthText%></B></TD>
<TD width="100" align="right"><A href="calendar.asp?date=<%=nextMonth%>">Next</A></TD>
</TR>
</TABLE>
</DIV>
</BODY>
</HTML>

36
asp/Data_Access_DateTime/Convert Records To Arrays Using GetRows.asp Normal file
View File

@ -0,0 +1,36 @@
<%
Function myURLDecode(strString)
strString = Replace(strString, "%2F", "/")
strString = Replace(strString, "%7C", "|")
strString = Replace(strString, "%3F", "?")
strString = Replace(strString, "%21", "!")
strString = Replace(strString, "%40", "@")
strString = Replace(strString, "%5C", "")
strString = Replace(strString, "%23", "#")
strString = Replace(strString, "%24", "$")
strString = Replace(strString, "%5E", "^")
strString = Replace(strString, "%26", "&")
strString = Replace(strString, "%25", "%")
strString = Replace(strString, "%2A", "*")
strString = Replace(strString, "%28", "(")
strString = Replace(strString, "%29", ")")
strString = Replace(strString, "%7D", "}")
strString = Replace(strString, "%3A", ":")
strString = Replace(strString, "%2C", ",")
strString = Replace(strString, "%7B", "{")
strString = Replace(strString, "%2B", "+")
strString = Replace(strString, "%2E", ".")
strString = Replace(strString, "%2D", "-")
strString = Replace(strString, "%7E", "~")
strString = Replace(strString, "%2D", "-")
strString = Replace(strString, "%5B", "[")
strString = Replace(strString, "%5F", "_")
strString = Replace(strString, "%5D", "]")
strString = Replace(strString, "%60", "`")
strString = Replace(strString, "%3D", "=")
strString = Replace(strString, "%27", "'")
strString = Replace(strString, "+", " ")
strString = Replace(strString, "%22", Chr(34))
myURLDecode = strString
End Function
%>

87
asp/Data_Access_DateTime/DIGITAL CLOCK.asp Normal file
View File

@ -0,0 +1,87 @@
<SCRIPT language=javascript>
Function mOvr(src,clrOver){
If (!src.contains(event.fromElement)){
src.style.cursor = 'hand';
src.bgColor = clrOver;
}
}
Function mOut(src,clrIn){
If (!src.contains(event.toElement)){
src.style.cursor = 'default';
src.bgColor = clrIn;
}
}
Function mClk(src){
If(event.srcElement.tagName=='TD')
src.children.tags('A')[0].click();
}
</SCRIPT>
<HTML>
<HEAD>
<TITLE>Clock</TITLE>
<BODY bgColor="#ffffff" onload="return window_onload()" onunload="return window_onunload()" marginheight="0" topmargin="0" leftmargin="0" marginwidth="0">
<SCRIPT>
var ClockTicks="";
var LocalTimerNormalBackground="#FFFFFF";
var LocalTimerHighlightBackground="#FF0000";
var HighlightPointer="default";
Function StartClocks(){
If(ClockTicks==""){
ClockTicks=window.setInterval("PutTime()",1000);
}
else{
StopClocks();
}
}
Function StopClocks(){
If(ClockTicks!=""){
window.clearInterval(ClockTicks);
ClockTicks="";
}
}
Function PutTime(){
var LocalDate=New Date();
var LocalHours=LocalDate.getHours() + "";
var LocalMinutes=LocalDate.getMinutes() + "";
var LocalSeconds=LocalDate.getSeconds() + "";
If(LocalHours.length==1){
LocalHours="0" + LocalHours;
}
If(LocalMinutes.length==1){
LocalMinutes="0" + LocalMinutes;
}
If(LocalSeconds.length==1){
LocalSeconds="0" + LocalSeconds;
}
LocalTimer.innerHTML=LocalHours + ":" + LocalMinutes + ":" + LocalSeconds;
LocalTimer.title="LOCAL: " + LocalDate.toLocaleString();
}
</SCRIPT>
<SCRIPT ID="clientEventHandlersJS" LANGUAGE="javascript">
<!--
Function window_onload() {
StartClocks();
}
Function window_onunload() {
StopClocks();
}
Function LocalTimer_onmouseout() {
LocalTimer.style.backgroundColor=LocalTimerNormalBackground;
}
Function LocalTimer_onmouseover() {
LocalTimer.style.backgroundColor=LocalTimerHighlightBackground;
}
//-->
</SCRIPT>
</HEAD>
<FONT size = "4" align = Right color = firebrick>
<!-- To use With asp page -->
<%
Dim a
a=Date()
Response.Write FormatDateTime(a,1)
%>
Time ::
<span ID="LocalTimer" style="COLOR: #0000ff; CURSOR: default" LANGUAGE="javascript"></span></FONT>
</BODY>
</HTML>

28
asp/Data_Access_DateTime/Diff Business Days.asp Normal file
View File

@ -0,0 +1,28 @@
' evaluate the number of business days between two dates
'
Function BusinessDateDiff(ByVal StartDate As Date, ByVal EndDate As Date, _
Optional ByVal SaturdayIsHoliday As Boolean = True) As Long
Dim incr As Date
' ensure we don't take time part into account
StartDate = Int(StartDate)
EndDate = Int(EndDate)
' incr can be +1 or -1
If StartDate < EndDate Then incr = 1 Else incr = -1
Do Until StartDate = EndDate
' skip to previous or next day
StartDate = StartDate + incr
If Weekday(StartDate) <> vbSunday And (Weekday(StartDate) <> vbSaturday _
Or Not SaturdayIsHoliday) Then
' if it's a weekday add/subtract one to the result
BusinessDateDiff = BusinessDateDiff + incr
End If
Loop
' when the loop is exited the function name
' contains the correct result
End Function

111
asp/Data_Access_DateTime/Dynamic Database Tables.asp Normal file
View File

@ -0,0 +1,111 @@
<HTML>
<HEAD>
<TITLE>Document</TITLE>
</HEAD>
<BODY BGCOLOR="#FFFFFF" TEXT="#000000">
<FORM ACTION=DynamicTableResults.asp METHOD=Post>
<TABLE BORDER='1'>
<TR>
<TD BGCOLOR=#EEEEEE COLSPAN=3>
Get table Data and Column Headers From A Table
</TD>
</TR>
<TR>
<TD>Enter The Table Name:</TD>
<TD><INPUT TYPE=Text Name=Table SIZE=25></TD>
</TR>
<TR>
<TD>Enter The DSN:</TD>
<TD><INPUT TYPE=Text NAME=DSN SIZE=25></TD>
</TR>
</TABLE><BR>
<INPUT TYPE=Submit VALUE=Submit> <INPUT TYPE=Reset VALUE=Reset>
</FORM>
</BODY>
</HTML>
Here is the code that does all the work.
<%@ LANGUAGE="VBSCRIPT" %>
<%
Option Explicit
'---------------------- WEB SITE: -----------------------
' File Name: DynamicTableResults.asp
'
' Purpose: This will take a table name from DynamicTable.asp
' (you must specify the DSN also)
' and list all the data and table column names.
' Good to see what's in a table when you forgot or don't know.
'Dim and Construct the SQL Query notice the request.form entry
'To get a table name entered by the user
Dim strSQL
strSQL = "SELECT * FROM " & Request.Form("Table") & ""
'This will display the SQL string on the page,
'i use it to check for errors
Response.Write strSQL
'Dim and create a connection object, notice the request.form to get
'a DSN entered by the user in the objConn.Open line. You must have
'a DSN created for the database on your machine and know it's name.
Dim objConn
Set objConn = Server.CreateObject("ADODB.Connection")
objConn.Open "DSN=" & Request.Form("DSN") & ""
'Dim and create a recordset object
Dim objRS
Set objRS = Server.CreateObject("ADODB.Recordset")
objRS.Open strSQL, objConn
Dim fCount, i
fCount = objRS.Fields.Count - 1
Response.Write "<table border=1><tr bgcolor='#EEEEEE'>"
for i=0 to fCount
Response.Write "<th>" & objRS(i).name & "</th>"
next
Response.Write "</tr>"
While Not objRS.EOF
Response.Write "<tr>"
for i=0 to fCount
Response.Write "<td> " & objRS(i).value & "</td>"
next
Response.Write "</tr>"
objRS.MoveNext
Wend
Response.Write "</table>"
'Close and dereference
objRS.Close
Set objRS = Nothing
objConn.Close
Set objConn = Nothing
'-----
' Begin HTML output
%>
<HTML>
<HEAD>
<TITLE>Untitled</TITLE>
</HEAD>
<BODY>
</BODY>
</HTML>
<%
'----------------------------------------------------------------------
' End HTML Output
'----------------------------------------------------------------------
'----------------------------------------------------------------------
' All ASP post processing code goes here, as well as
' sub routines and functions
'----------------------------------------------------------------------
%>

24
asp/Data_Access_DateTime/Dynamic Dropdown Boxes.asp Normal file
View File

@ -0,0 +1,24 @@
<select size="1" name="LocationCode">
<option selected><%=LocationCode%></option>
<%
On Error Resume Next
SET GENERAL = Server.CreateObject("ADODB.Recordset")
GENERAL.ActiveConnection = "DSN=ODBC NAME" or connection string of choice
GENERAL.Source = "Select DESCRIPTION From DESCRIPTION Order By DESCRIPTION"
GENERAL.CursorType = 0
GENERAL.LockType = 3
GENERAL.Open
GENERAL_numRows = 0
Do until GENERAL.EOF = True
response.write "<option>" & trim(GENERAL.Fields.Item("DESCRIPTION").value) & "</option>"
GENERAL.Movenext
Loop
GENERAL.Close
Set General = Nothing
response.write "<option>OTHER</option>"
%>
</select>

24
asp/Data_Access_DateTime/Dynamic Table.asp Normal file
View File

@ -0,0 +1,24 @@
SQL = "SELECT * FROM MyTable"
Set Conn = Server.CreateObject("ADODB.Connection")
Conn.Open Application("ConnectionString")
Set RS = Server.CreateObject("ADODB.Recordset")
RS.Open SQL, Conn
fCount = RS.Fields.Count - 1
Response.Write "<table border=1><tr bgcolor='#EEEEEE'>"
for i=0 to fCount
Response.Write "<th>" & RS(i).name & "</th>"
next
Response.Write "</tr>"
While Not RS.EOF
Response.Write "<tr>"
for i=0 to fCount
Response.Write "<td>" & RS(i).value & "</td>"
next
Response.Write "</tr>
RS.MoveNext
Wend
Response.Write "</table>"
RS.Close
Set RS = Nothing
Conn.Close
Set Conn = Nothing

39
asp/Data_Access_DateTime/European Weeknumber.asp Normal file
View File

@ -0,0 +1,39 @@
Function weeknummer (iYear, iMonth, iDay)
dim thursdayofweek
dim firstthursdayofyear
dim MyDay
dim dayofWeek
dim thursdaysyear
MyDay = DateSerial(iYear, iMonth, iDay)
dayofWeek = Weekday(MyDay)
if dayofWeek = 1 then
thursdayofweek = dateadd("d", -3 , MyDay)
else
thursdayofweek = dateadd("d",(5 - dayofWeek), MyDay)
end if
thursdaysyear = Year( thursdayofweek )
firstthursdayofyear = first_thursday_of_year (thursdaysyear)
weeknummer = (datediff("ww", firstthursdayofyear ,thursdayofweek) + 1)
end Function
function first_thursday_of_year (iYear)
dim first_jan
dim dayofWeek
first_jan = DateSerial(iYear, 1, 1)
dayofWeek = Weekday(first_jan)
select case dayofweek
case 1 first_thursday_of_year = dateadd("d", 4 ,first_jan)
case 2 first_thursday_of_year = dateadd("d", 3 ,first_jan)
case 3 first_thursday_of_year = dateadd("d", 2 ,first_jan)
case 4 first_thursday_of_year = dateadd("d", 1 ,first_jan)
case 5 first_thursday_of_year = first_jan
case 6 first_thursday_of_year = dateadd("d", 6 ,first_jan)
case 7 first_thursday_of_year = dateadd("d", 5 ,first_jan)
End Select
end function

179
asp/Data_Access_DateTime/Format Dates.asp Normal file
View File

@ -0,0 +1,179 @@
<%
Function fncGetDayOrdinal( _
ByVal intDay _
)
' Accepts a day of the month as an integer and returns the
' appropriate suffix
Dim strOrd
Select Case intDay
Case 1, 21, 31
strOrd = "st"
Case 2, 22
strOrd = "nd"
Case 3, 23
strOrd = "rd"
Case Else
strOrd = "th"
End Select
fncGetDayOrdinal = strOrd
End Function ' fncGetDayOrdinal
Function fncFmtDate( _
ByVal strDate, _
ByRef strFormat _
)
' Accepts strDate as a valid date/time,
' strFormat as the output template.
' The function finds each item in the
' template and replaces it with the
' relevant information extracted from strDate
' Template items (example)
' %m Month as a decimal (02)
' %B Full month name (February)
' %b Abbreviated month name (Feb )
' %d Day of the month (23)
' %O Ordinal of day of month (eg st or rd or nd)
' %j Day of the year (54)
' %Y Year with century (1998)
' %y Year without century (98)
' %w Weekday as integer (0 is Sunday)
' %a Abbreviated day name (Fri)
' %A Weekday Name (Friday)
' %H Hour in 24 hour format (24)
' %h Hour in 12 hour format (12)
' %N Minute as an integer (01)
' %n Minute as optional if minute <> 0
' %S Second as an integer (55)
' %P AM/PM Indicator (PM)
On Error Resume Next
Dim intPosItem
Dim int12HourPart
Dim str24HourPart
Dim strMinutePart
Dim strSecondPart
Dim strAMPM
' Insert Month Numbers
strFormat = Replace(strFormat, "%m", _
DatePart("m", strDate), 1, -1, vbBinaryCompare)
' Insert non-Abbreviated Month Names
strFormat = Replace(strFormat, "%B", _
MonthName(DatePart("m", strDate), _
False), 1, -1, vbBinaryCompare)
' Insert Abbreviated Month Names
strFormat = Replace(strFormat, "%b", _
MonthName(DatePart("m", strDate), _
True), 1, -1, vbBinaryCompare)
' Insert Day Of Month
strFormat = Replace(strFormat, "%d", _
DatePart("d",strDate), 1, _
-1, vbBinaryCompare)
' Insert Day of Month Ordinal (eg st, th, or rd)
strFormat = Replace(strFormat, "%O", _
fncGetDayOrdinal(Day(strDate)), _
1, -1, vbBinaryCompare)
' Insert Day of Year
strFormat = Replace(strFormat, "%j", _
DatePart("y",strDate), 1, _
-1, vbBinaryCompare)
' Insert Long Year (4 digit)
strFormat = Replace(strFormat, "%Y", _
DatePart("yyyy",strDate), 1, _
-1, vbBinaryCompare)
' Insert Short Year (2 digit)
strFormat = Replace(strFormat, "%y", _
Right(DatePart("yyyy",strDate),2), _
1, -1, vbBinaryCompare)
' Insert Weekday as Integer (eg 0 = Sunday)
strFormat = Replace(strFormat, "%w", _
DatePart("w",strDate,1), 1, _
-1, vbBinaryCompare)
' Insert Abbreviated Weekday Name (eg Sun)
strFormat = Replace(strFormat, "%a", _
WeekdayName(DatePart("w",strDate,1),True), 1, _
-1, vbBinaryCompare)
' Insert non-Abbreviated Weekday Name
strFormat = Replace(strFormat, "%A", _
WeekdayName(DatePart("w",strDate,1),False), 1, _
-1, vbBinaryCompare)
' Insert Hour in 24hr format
str24HourPart = DatePart("h",strDate)
If Len(str24HourPart) < 2 Then str24HourPart = "0" & _
str24HourPart
strFormat = Replace(strFormat, "%H", str24HourPart, 1, _
-1, vbBinaryCompare)
' Insert Hour in 12hr format
int12HourPart = DatePart("h",strDate) Mod 12
If int12HourPart = 0 Then int12HourPart = 12
strFormat = Replace(strFormat, "%h", int12HourPart, 1, _
-1, vbBinaryCompare)
' Insert Minutes
strMinutePart = DatePart("n",strDate)
If Len(strMinutePart) < 2 Then _
strMinutePart = "0" & strMinutePart
strFormat = Replace(strFormat, "%N", strMinutePart, _
1, -1, vbBinaryCompare)
' Insert Optional Minutes
If CInt(strMinutePart) = 0 Then
strFormat = Replace(strFormat, "%n", "", 1, _
-1, vbBinaryCompare)
Else
If CInt(strMinutePart) < 10 Then _
strMinutePart = "0" & strMinutePart
strMinutePart = ":" & strMinutePart
strFormat = Replace(strFormat, "%n", strMinutePart, _
1, -1, vbBinaryCompare)
End If
' Insert Seconds
strSecondPart = DatePart("s",strDate)
If Len(strSecondPart) < 2 Then _
strSecondPart = "0" & strSecondPart
strFormat = Replace(strFormat, "%S", strSecondPart, 1, _
-1, vbBinaryCompare)
' Insert AM/PM indicator
If DatePart("h",strDate) >= 12 Then
strAMPM = "PM"
Else
strAMPM = "AM"
End If
strFormat = Replace(strFormat, "%P", strAMPM, 1, _
-1, vbBinaryCompare)
fncFmtDate = strFormat
'If there is an error output its value
If Err.number <> 0 Then
Response.Clear
Response.Write "ERROR " & Err.number & _
": fmcFmtDate - " & Err.description
Response.Flush
Response.End
End If
End Function ' fncFmtDate
%>

52
asp/Data_Access_DateTime/Paging in ASP.asp Normal file
View File

@ -0,0 +1,52 @@
<html>
<head>
<!-- #Include file="adovbs.inc" -->
<title>SQL</title>
</head>
<body>
<%
Dim CurrentPage,RowCount,i
CurrentPage=TRIM(Request("CurrentPage"))
if CurrentPage="" then CurrentPage=1
Set ObjCon=Server.CreateObject("ADODB.Connection")
Set ObjRec=Server.CreateObject("ADODB.Recordset")
ObjCon.Open "driver={SQL SERVER};server=mahesh;uid=sa;database=test"
ObjRec.CursorType=adOpenStatic
ObjRec.PageSize=5
dim tsql
tsql=""
tsql="Select * from Student "
ObjRec.Open tsql,ObjCon
ObjRec.AbsolutePage=cINT(CurrentPage)
RowCount=0
While Not ObjRec.Eof and RowCount<ObjRec.PageSize
for i=0 to ObjRec.Fields.Count-1
objRec(i)
Next
RowCount=RowCount+1
ObjRec.MoveNext
Wend
for i= 0 to ObjRec.PageCount
%>
<a href="Paging.asp?CurrentPage=<% =i %>"><% =i %></a>
<% Next %>
</body>
</html>

70
asp/Data_Access_DateTime/Query database and Variables.asp Normal file
View File

@ -0,0 +1,70 @@
<%
Response.Buffer = True
sDSN = "dsn=Incident"
ATYPE = trim(request.querystring("ATYPE"))
If trim(request.querystring("ID")) <> Empty Then
SET GENERAL = Server.CreateObject("ADODB.Recordset")
GENERAL.ActiveConnection = sDSN
GENERAL.Source = "Select * From Incident Where IncidentReportNumber=" & request.querystring("ID")
GENERAL.CursorType = 0
GENERAL.LockType = 3
GENERAL.Open
GENERAL_numRows = 0
If GENERAL.EOF = True Then
sError = "NF"
Else
InsuranceClaim = trim(GENERAL.Fields.Item("InsuranceClaim").value)
IncidentReportNumber = trim(GENERAL.Fields.Item("IncidentReportNumber").value)
CoverageYear = GENERAL.Fields.Item("CoverageYear").value
IncidentOccurrenceDate = GENERAL.Fields.Item("IncidentOccurrenceDate").value
ClaimStatus = trim(GENERAL.Fields.Item("ClaimStatus").value)
IncidentReportedDate = GENERAL.Fields.Item("IncidentReportedDate").value
SupportingDocuments = trim(GENERAL.Fields.Item("SupportingDocuments").value)
LastName = trim(GENERAL.Fields.Item("LastName").value)
FirstName = trim(GENERAL.Fields.Item("FirstName").value)
Age = trim(GENERAL.Fields.Item("Age").value)
Address = trim(GENERAL.Fields.Item("Address").value)
City = trim(GENERAL.Fields.Item("City").value)
Zip = trim(GENERAL.Fields.Item("Zip").value)
HomePhone = trim(GENERAL.Fields.Item("HomePhone").value)
WorkPhone = trim(GENERAL.Fields.Item("WorkPhone").value)
DOB = GENERAL.Fields.Item("DOB").value
Sex = trim(GENERAL.Fields.Item("Sex").value)
SSN = trim(GENERAL.Fields.Item("SSN").value)
InsuranceType = trim(GENERAL.Fields.Item("InsuranceType").value)
Status = trim(GENERAL.Fields.Item("Status").value)
NatureIncident = trim(GENERAL.Fields.Item("NatureIncident").value)
ServiceType = trim(GENERAL.Fields.Item("ServiceType").value)
ProgramInstructor = trim(GENERAL.Fields.Item("ProgramInstructor").value)
Supervisor = trim(GENERAL.Fields.Item("Supervisor").value)
LocationIncident = trim(GENERAL.Fields.Item("LocationIncident").value)
LocationCode = trim(GENERAL.Fields.Item("LocationCode").value)
WWW = trim(GENERAL.Fields.Item("WWW").value)
InjuryOccur = trim(GENERAL.Fields.Item("InjuryOccur").value)
InjuryComments = trim(GENERAL.Fields.Item("InjuryDescribe").value)
DoTo = trim(GENERAL.Fields.Item("DueTo").value)
DoToDescribe = trim(GENERAL.Fields.Item("DoToDescribe").value)
FirstAidGiven = trim(GENERAL.Fields.Item("FirstAidGiven").value)
FirstAidBy = trim(GENERAL.Fields.Item("FirstAidBy").value)
Doctor = trim(GENERAL.Fields.Item("Doctor").value)
DoctorAddress = trim(GENERAL.Fields.Item("DoctorAddress").value)
Instructions = trim(GENERAL.Fields.Item("Instructions").value)
DateReturn = GENERAL.Fields.Item("DateReturn").value
FollowUpCare = trim(GENERAL.Fields.Item("FollowUpCare").value)
NameWitness = trim(GENERAL.Fields.Item("NameWitness").value)
Author = trim(GENERAL.Fields.Item("Author").value)
CompletedBy = trim(GENERAL.Fields.Item("CompletedBy").value)
DateComplete = GENERAL.Fields.Item("DateComplete").value
CorrectiveAction = trim(GENERAL.Fields.Item("CorrectiveAction").value)
Comments = trim(GENERAL.Fields.Item("Comments").value)
GENERAL.Close
Set General = Nothing
End If
End If
%>
THEN THE HTML
<input type="text" name="FirstName" size="27" value="<%=FirstName%>" maxlength="15">
AND SO ON...

161
asp/Data_Access_DateTime/Retrieve Text-Image fields using OpenX.asp Normal file
View File

@ -0,0 +1,161 @@
<%@ Language=VBScript %>
<%
Set oConn = Server.CreateObject("OpenX2.Connection")
Set oCommand = Server.CreateObject("OpenX2.Command")
Dim sResult, sRetrieveSQL, sSetTextSize
Dim bError
Dim i
sSetTextSize = "SET TEXTSIZE "
sRetrieveSQL = "SELECT publishers.pub_name, publishers.city, publishers.state, publishers.country, pub_info.pub_id, pub_info.pr_info FROM pub_info, publishers WHERE ( pub_info.pub_id = publishers.pub_id ) ORDER BY publishers.pub_name"
On Error Goto 0
Sub ProcessErr
If Err.number <> 0 Then
bError = true
sResult = ""
If oConn.ErrorCode <> 0 Then
sResult = "OpenX2 Connection Error: " & oConn.ErrorInfo & ". Error #" & oConn.ErrorCode & " (" & oConn.ErrorCodeEx & ")<br />"
Else
If oCommand.ErrorCode <> 0 Then
sResult = "OpenX2 Command Error: " & oCommand.ErrorInfo & ". Error #" & oCommand.ErrorCode & " (" & oCommand.ErrorCodeEx & ")<br />"
End If
End If
If sResult = "" Then
Rem you may reRaise the Error here if you want to allow IIS process rest of errors
sResult = "ASP Error: #" & CStr(Err.Number) & ". " & Err.description & "<br />"
End If
End If
End Sub
Sub ProcessQuery
i = 0
oConn.Connect("ms_ox1")
oCommand.Connection = oConn
oConn.autoCommit = true
oCommand.CommandText = sSetTextSize & "12000"
oCommand.Execute
oCommand.CommandText = sRetrieveSQL
oCommand.Execute
Do While oCommand.MoveNext
sResult = sResult & "<tr>"
sResult = sResult & "<td style='font-size: 10pt; cursor: hand;' onClick='ShowDesc(row" & oCommand.FieldValueAsString(5) & ")'><b>Show/Hide Info</b></td>"
sResult = sResult & "<td style='font-size: 10pt;'>" & oCommand.FieldValueAsString(1) & " </td>"
sResult = sResult & "<td style='font-size: 10pt;'>" & oCommand.FieldValueAsString(2) & " </td>"
sResult = sResult & "<td style='font-size: 10pt;'>" & oCommand.FieldValueAsString(3) & " </td>"
sResult = sResult & "<td style='font-size: 10pt;'>" & oCommand.FieldValueAsString(4) & " </td>"
sResult = sResult & "</tr>"
sResult = sResult & "<tr id='row" & oCommand.FieldValueAsString(5) & "' class='hiddentr'>"
sResult = sResult & "<td colspan='5'>" & oCommand.FieldValueAsString(6) & " </td>"
sResult = sResult & "</tr>"
i = i + 1
If i = 3 Then
Exit Do
End If
Loop
oCommand.CommandText = sSetTextSize & "0"
oCommand.Execute
End Sub
REM // Main Processing
On Error Resume Next
ProcessQuery
ProcessErr
%>
<html>
<head><title>OpenX2 Test #10 - TEXT (CLOb/LongChar) Fields Reading </title>
<STYLE TYPE="text/css">
tr.visibletr { font-size: 8pt; visibility: visible; position: static; }
tr.hiddentr { font-size: 8pt; visibility: hidden; position: absolute; }
</STYLE>
<script type="text/javascript" language="JavaScript">
<!--
function ShowDesc(theTR)
{
if(theTR) {
if(theTR.className == "visibletr")
theTR.className = "hiddentr";
else
theTR.className = "visibletr";
}
}
-->
</script>
</head>
<body>
<table border="1">
<tr>
<td><b>Info</b></td>
<td><b>Name</b></td>
<td><b>City</b></td>
<td><b>State</b></td>
<td><b>Country</b></td>
</tr>
<%=sResult%>
</table>
</body>
</html>
ASP file to retrieve image from the database (OX2ImageVB.asp)
<%@ Language=VBScript %>
<%
Set oConn = Server.CreateObject("OpenX2.Connection")
Set oCommand = Server.CreateObject("OpenX2.Command")
Dim sResult, sRetrieveSQL, sSetTextSize
Dim bError
Dim pub_id
pub_id = Request("pub_id")
sSetTextSize = "SET TEXTSIZE "
sRetrieveSQL = "SELECT pub_info.logo FROM pub_info WHERE pub_info.pub_id = '" & pub_id & "'"
On Error Goto 0
Sub ProcessErr
If Err.number <> 0 Then
bError = true
sResult = ""
If oConn.ErrorCode <> 0 Then
sResult = "OpenX2 Connection Error: " & oConn.ErrorInfo & ". Error #" & oConn.ErrorCode & " (" & oConn.ErrorCodeEx & ")<br />"
Else
If oCommand.ErrorCode <> 0 Then
sResult = "OpenX2 Command Error: " & oCommand.ErrorInfo & ". Error #" & oCommand.ErrorCode & " (" & oCommand.ErrorCodeEx & ")<br />"
End If
End If
If sResult = "" Then
Rem you may reRaise the Error here if you want to allow IIS process rest of errors
sResult = "ASP Error: #" & CStr(Err.Number) & ". " & Err.description & "<br />"
End If
End If
End Sub
Sub ProcessQuery
oConn.Connect("ms_ox1")
oCommand.Connection = oConn
oConn.autoCommit = true
oCommand.CommandText = sSetTextSize & "32768"
oCommand.Execute
oCommand.CommandText = sRetrieveSQL
oCommand.Execute
If Not oCommand.isEmpty Then
Response.Clear
Response.ContentType = "image/gif"
Response.BinaryWrite(oCommand.FieldValueAsBinary(1))
End If
oCommand.CommandText = sSetTextSize & "0"
oCommand.Execute
End Sub
REM // Main Processing
On Error Resume Next
ProcessQuery
ProcessErr
%>

22
asp/Data_Access_DateTime/StripHTML.asp Normal file
View File

@ -0,0 +1,22 @@
<%
' stripHTML vers 1 - VBScript
function stripHTML(txt)
set Reg = new RegExp
Reg.pattern = "[<][^>]*[>]"
Reg.IgnoreCase = true
Reg.Global = true
stripHTML = Reg.Replace(txt,"")
end function
%>
<%
// stripHTML vers 1 - Jscript
function stripHTML(string) {
var strip = new RegExp();
strip = /[<][^>]*[>]/gi;
return string.replace(strip, "");
}
%>

20
asp/Data_Access_DateTime/SwapDate Function.asp Normal file
View File

@ -0,0 +1,20 @@
<%
Private Function SwapDate(ByVal dateinput)
Dim strWorkingDate, tmpArray, assemblystring, del, i
strWorkingDate = dateinput
If InStr(strWorkingDate, "/") Then
tmpArray = Split( strWorkingDate, "/" ) : del = "/"
ElseIf InStr(strWorkingDate, "-") Then
tmpArray = Split( strWorkingDate, "-" ) : del = "-"
ElseIf InStr(strWorkingDate, " ") Then
tmpArray = Split( strWorkingDate, " " ) : del = " "
End If
For i = 0 To UBound(tmpArray)
tmpArray( i ) = Replace( tmparray( i ), ",", "" )
Next
assemblystring = tmpArray(1) & del & tmpArray(0)
If del = " " Then assemblystring = assemblystring & ","
assemblystring = assemblystring & del & tmpArray(2)
SwapDate = Trim( assemblystring )
End Function
%>

20
asp/Data_Access_DateTime/SwapDate Function~.asp Normal file
View File

@ -0,0 +1,20 @@
<%
Private Function SwapDate(ByVal dateinput)
Dim strWorkingDate, tmpArray, assemblystring, del, i
strWorkingDate = dateinput
If InStr(strWorkingDate, "/") Then
tmpArray = Split( strWorkingDate, "/" ) : del = "/"
ElseIf InStr(strWorkingDate, "-") Then
tmpArray = Split( strWorkingDate, "-" ) : del = "-"
ElseIf InStr(strWorkingDate, " ") Then
tmpArray = Split( strWorkingDate, " " ) : del = " "
End If
For i = 0 To UBound(tmpArray)
tmpArray( i ) = Replace( tmparray( i ), ",", "" )
Next
assemblystring = tmpArray(1) & del & tmpArray(0)
If del = " " Then assemblystring = assemblystring & ","
assemblystring = assemblystring & del & tmpArray(2)
SwapDate = Trim( assemblystring )
End Function
%>

35
asp/Data_Access_DateTime/simplifying ADO parameters.asp Normal file
View File

@ -0,0 +1,35 @@
<%@ Language="Javascript" %>
<%
//setup connection:
var connectionString = "File Name=" + Server.MapPath("go.udl");
var connection = Server.CreateObject("ADODB.Connection");
connection.connectionString = connectionString;
connection.open();
connection.defaultDatabase = "Northwind";
var SqlCommand = "SELECT * FROM [Customers] WHERE [CustomerId]=? AND [CompanyName]=?";
//THE LONG WAY:
var adVarChar = 200;
var adParamInput = 1;
var command = Server.CreateObject("ADODB.Command");
command.activeConnection = connection;
command.commandText = SqlCommand;
command.parameters.append(command.createParameter("", adVarChar, adParamInput, 255, "ALFKI"));
command.parameters.append(command.createParameter("", adVarChar, adParamInput, 255, "Alfreds Futterkiste"));
var rs = command.execute();
//THE SHORT WAY (parameters are passed as an array to the execute method):
var command2 = Server.CreateObject("ADODB.Command");
command2.activeConnection = connection;
command2.commandText = SqlCommand;
var rs2 = command2.execute(null, ["ALFKI", "Alfreds Futterkiste"]);
%>
using the Long way, you have to create and append a parameter for every parameter in the commandtext. but in the short way you just add another value to the array, and you don't have to worry about datatypes.

17
asp/FilesMaths/ASP source viewer.asp Normal file
View File

@ -0,0 +1,17 @@
<%option explicit%>
<%
Const ForReading=1
Dim fso,ts,file,i
file=Request.QueryString("file")
Set fso = Server.CreateObject("Scripting.FileSystemObject")
Set ts = fso.OpenTextFile( Server.MapPath(file), ForReading)
%>
<H1><CENTER><%=file%></CENTER></H1>
<%
While Not ts.AtEndOfStream
i=i+1
Response.Write "<B>" & i & ". </B>" & Server.HTMLEncode(ts.readline) & "<BR>"
Wend
Set ts=Nothing
Set fso=Nothing
%>

66
asp/FilesMaths/Base 64 Encode - Decode.asp Normal file
View File

@ -0,0 +1,66 @@
Const sBASE_64_CHARACTERS = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/
' ---------------------------------------
Function Base64decode(ByVal asContents)
Dim lsResult
Dim lnPosition
Dim lsGroup64, lsGroupBinary
Dim Char1, Char2, Char3, Char4
Dim Byte1, Byte2, Byte3
If Len(asContents) Mod 4 > 0 Then asContents = asContents & String(4 - (Len(asContents) Mod 4), " ")
lsResult = ""
For lnPosition = 1 To Len(asContents) Step 4
lsGroupBinary = ""
lsGroup64 = Mid(asContents, lnPosition, 4)
Char1 = InStr(sBASE_64_CHARACTERS, Mid(lsGroup64, 1, 1)) - 1
Char2 = InStr(sBASE_64_CHARACTERS, Mid(lsGroup64, 2, 1)) - 1
Char3 = InStr(sBASE_64_CHARACTERS, Mid(lsGroup64, 3, 1)) - 1
Char4 = InStr(sBASE_64_CHARACTERS, Mid(lsGroup64, 4, 1)) - 1
Byte1 = Chr(((Char2 And 48) 16) Or (Char1 * 4) And &HFF)
Byte2 = lsGroupBinary & Chr(((Char3 And 60) 4) Or (Char2 * 16) And &HFF)
Byte3 = Chr((((Char3 And 3) * 64) And &HFF) Or (Char4 And 63))
lsGroupBinary = Byte1 & Byte2 & Byte3
lsResult = lsResult + lsGroupBinary
Next
Base64decode = lsResult
End Function
' --------------------------------------
Function Base64encode(ByVal asContents)
Dim lnPosition
Dim lsResult
Dim Char1
Dim Char2
Dim Char3
Dim Char4
Dim Byte1
Dim Byte2
Dim Byte3
Dim SaveBits1
Dim SaveBits2
Dim lsGroupBinary
Dim lsGroup64
If Len(asContents) Mod 3 > 0 Then asContents = asContents & String(3 - (Len(asContents) Mod 3), " ")
lsResult = ""
For lnPosition = 1 To Len(asContents) Step 3
lsGroup64 = ""
lsGroupBinary = Mid(asContents, lnPosition, 3)
Byte1 = Asc(Mid(lsGroupBinary, 1, 1)): SaveBits1 = Byte1 And 3
Byte2 = Asc(Mid(lsGroupBinary, 2, 1)): SaveBits2 = Byte2 And 15
Byte3 = Asc(Mid(lsGroupBinary, 3, 1))
Char1 = Mid(sBASE_64_CHARACTERS, ((Byte1 And 252) 4) + 1, 1)
Char2 = Mid(sBASE_64_CHARACTERS, (((Byte2 And 240) 16) Or (SaveBits1 * 16) And &HFF) + 1, 1)
Char3 = Mid(sBASE_64_CHARACTERS, (((Byte3 And 192) 64) Or (SaveBits2 * 4) And &HFF) + 1, 1)
Char4 = Mid(sBASE_64_CHARACTERS, (Byte3 And 63) + 1, 1)
lsGroup64 = Char1 & Char2 & Char3 & Char4
lsResult = lsResult + lsGroup64
Next
Base64encode = lsResult
End Function

27
asp/FilesMaths/Binary to Integer.asp Normal file
View File

@ -0,0 +1,27 @@
Function BinToInt(binvalue)
Dim i, s, v, neg, ilen, value
value = Null
If IsBin(binvalue) Then
value = 0
s = binvalue
ilen = Len(s)
If (ilen=32) Then
v = Left(s, 1)
neg = (CByte(v) = 1)
If neg Then
s = BinNot(s)
End If
End If
s = StrReverse(s)
For i = 1 To ilen
value = value + CByte(Mid(s, i, 1)) * Power(2, i-1)
Next
If neg Then
value = -(value + 1)
End If
End If
BinToInt = value
End Function

54
asp/FilesMaths/CBit Function.asp Normal file
View File

@ -0,0 +1,54 @@
<%
Private Function CBit(ByVal variantIn)
Dim re, bTest, bOut
bOut = Null
On Error Resume Next
Set re = New RegExp
With re
.Global = False
.IgnoreCase = True
.Pattern = "^([A-Z-_d]+)$"
bTest = .test(variantIn)
End With
Set re = Nothing
If Err Then bTest = False
On Error GoTo 0
If IsNull(bOut) And bTest Then
'alpha-numeric
Select Case CStr(LCase(Trim(variantIn)))
Case "on", "true", "y", "t"
bOut = 1
Case "off", "false", "n", "f", ""
bOut = 0
End Select
End If
If IsNull(bOut) And IsNumeric(variantIn) Then
On Error Resume Next
variantIn = CLng(variantIn)
If Err Then
bOut = 0
Else
If variantIn > 0 Then _
bOut = 1 Else bOut = 0
End If
On Error GoTo 0
End If
If IsNull(bOut) And (IsNull(variantIn) Or _
IsEmpty(variantIn) Or IsArray(variantIn)) Then bOut = 0
If IsNull(bOut) And IsObject(variantIn) Then
If variantIn Is Nothing Then _
bOut = 0 Else bOut = 1
End If
If IsNull(bOut) Then bOut = 0
CBit = bOut
End Function
%>

37
asp/FilesMaths/CalcArea Function.asp Normal file
View File

@ -0,0 +1,37 @@
<%
Private Function CalcArea(ByVal formula, ByVal values)
Const Pi = 3.1415926535897932
Dim mth, b, b1, b2, h, r, r1, r2, s, s1, s2
Select Case LCase( formula )
Case "triangle"
b = CDbl( values(0) )
h = CDbl( values(1) )
mth = b * h * 0.5
Case "square"
s = CDbl( values(0) )
mth = s ^ 2
Case "rectangle"
s1 = CDbl( values(0) )
s2 = CDbl( values(1) )
mth = s1 * s2
Case "parallelogram"
b = CDbl( values(0) )
h = CDbl( values(1) )
mth = b * h
Case "trapezoid"
b1 = CDbl( values(0) )
b2 = CDbl( values(1) )
h = CDbl( values(2) )
mth = h / 2 * (b1 + b2)
Case "circle"
r = CDbl( values(0) )
mth = pi * r ^ 2
Case "ellipse"
r1 = CDbl( values(0) )
r2 = CDbl( values(1) )
mth = pi * r1 * r2
End Select
mth = CDbl( mth )
CalcArea = mth
End Function
%>

49
asp/FilesMaths/Convert Bytes.asp Normal file
View File

@ -0,0 +1,49 @@
<%
Function ConvertBytes(ByRef anBytes)
Dim lnSize ' File Size To be returned
Dim lsType ' Type of measurement (Bytes, KB, MB, GB, TB)
Const lnBYTE = 1
Const lnKILO = 1024 ' 2^10
Const lnMEGA = 1048576 ' 2^20
Const lnGIGA = 1073741824 ' 2^30
Const lnTERA = 1099511627776 ' 2^40
' Const lnPETA = 1.12589990684262E+15 ' 2^50
' Const lnEXA = 1.15292150460685E+18 ' 2^60
' Const lnZETTA = 1.18059162071741E+21 ' 2^70
' Const lnYOTTA = 1.20892581961463E+24 ' 2^80
If anBytes = "" Or Not IsNumeric(anBytes) Then Exit Function
If anBytes < 0 Then Exit Function
' If anBytes < lnKILO Then
' ' ByteConversion
' lnSize = anBytes
' lsType = "bytes"
' Else
If anBytes < lnMEGA Then
' KiloByte Conversion
lnSize = (anBytes / lnKILO)
lsType = "kb"
ElseIf anBytes < lnGIGA Then
' MegaByte Conversion
lnSize = (anBytes / lnMEGA)
lsType = "mb"
ElseIf anBytes < lnTERA Then
' GigaByte Conversion
lnSize = (anBytes / lnGIGA)
lsType = "gb"
Else
' TeraByte Conversion
lnSize = (anBytes / lnTERA)
lsType = "tb"
End If
' End If
' Remove fraction
'lnSize = CLng(lnSize)
lnSize = FormatNumber(lnSize, 2, True, False, True)
' Return the results
ConvertBytes = lnSize & " " & lsType
End Function
%>

129
asp/FilesMaths/Delete Files.asp Normal file
View File

@ -0,0 +1,129 @@
<HTML>
<HEAD>
<TITLE>Delete a File</TITLE>
<!-- This style creates the buttons For the script -->
<style>
<!--
body, td, li, p, table, Input
{
font-family: Verdana, Arial, Helvetica, sans-serif;
font-size: 8pt;
}
a:hover.Button
{
color: #FF0000;
background: #CCCCCC;
}
A.Button
{
Text-decoration: none;
color: #000000;
background: #CCCCCC;
}
.Button
{
Text-align: center;
Text-decoration: none;
color: #000000;
background: #CCCCCC;
border-top: 2px solid #EEEEEE;
border-Left: 2px solid #EEEEEE;
border-Right: 2px solid #999999;
border-bottom: 2px solid #999999;
font-family: Verdana, Arial, Helvetica, sans-serif;
font-size: 8pt;
padding-Left: 4;
padding-Right: 4;
padding-top: 2;
padding-bottom: 2;
}
-->
</style>
</HEAD>
<BODY>
<P align="center"><FONT size="6" color="#FF0000">File Deletion</FONT></P>
<%
strdelete = Request.QueryString("delete")
strFN = Request.QueryString("FN")
strFT = Request.QueryString("file")
'display the SHOW-ME-THE-FILE screen
If strdelete = "Show" Then
If strFT = "image" Then
Response.Write "<P align=center> <Img width=320 height=240 src=" & strFN & "><BR><BR>"
Response.Write "<A class=button href=default.asp?file=image&delete=Sure&FN=" & strFN & ">Delete?</A> "
Response.Write "<A class=button href=default.asp>List Files</A> <BR><BR></P>"
Else
Response.Write "<P align=center><FONT color=Blue size=5>" & strFN & "</FONT><BR><BR>"
Response.Write "<A class=button href=default.asp?file=file&delete=Sure&FN=" & strFN & ">Delete?</A> "
Response.Write "<A class=button href=default.asp>List Files</A> <BR><BR></P>"
End If
Response.End
End If
'display the ARE-YOU-SURE screen
If strdelete = "Sure" Then
If strFT = "image" Then
Response.Write "<P align=center> <Img width=320 height=240 src=" & strFN & "><BR><BR>"
Response.Write "<FONT color=Red size=5>Are You Sure You Want To Delete This File?</FONT><BR>"
Response.Write "<A class=button href=default.asp?delete=Yes&FN=" & strFN & ">Yes, Delete It.</A> "
Response.Write "<A class=button href=default.asp>NO, Do Not Delete It!</A> <BR><BR></P>"
Else
Response.Write "<P align=center><FONT color=Blue size=5>" & strFN & "</FONT><BR><BR>"
Response.Write "<FONT color=Red size=5>Are You Sure You Want To Delete This File?</FONT><BR>"
Response.Write "<A class=button href=default.asp?delete=Yes&FN=" & strFN & ">Yes, Delete It.</A> "
Response.Write "<A class=button href=default.asp>NO, Do Not Delete It!</A> <BR><BR></P>"
End If
Response.End
End If
'call the delete function
If strdelete = "Yes" Then
Call functionDF()
End If
'the delete function
Sub functionDF()
Dim fso, f1
Set fso = CreateObject("Scripting.FileSystemObject")
Set f1 = fso.GetFile(Server.MapPath(strFN))
f1.Delete
Response.Write "<P align=center>File <B>" & strFN & "</B> Deleted! <BR><BR>"
Response.Write "<A class=button href=default.asp>Return To List</A><BR></P>"
Response.End
End Sub
'view files in this directory
dirtowalk = "./"
'display the files
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(Server.MapPath(dirtowalk))
Set fc = f.Files
Response.Write "<HR>"
Response.Write "<P><FONT size=5 >File List</FONT></P> "
For Each tobdel In fc
'dont display this page
If tobdel.name = "default.asp" Then
Response.Write ""
'is the file an image?
ElseIf Right(tobdel.name, 4) = ".jpg" Then
Response.Write "<A class=button href=default.asp?file=image&delete=Show&FN=" & tobdel.name & "><I><B>View</B></I></A> "
Response.Write "<A class=button href=default.asp?file=image&delete=Sure&FN=" & tobdel.name & "><I><B>Del</B></I></A> " & tobdel.name & "<BR><BR>"
ElseIf Right(tobdel.name, 4) = ".gif" Then
Response.Write "<A class=button href=default.asp?file=image&delete=Show&FN=" & tobdel.name & "><I><B>View</B></I></A> "
Response.Write "<A class=button href=default.asp?file=image&delete=Sure&FN=" & tobdel.name & "><I><B>Del</B></I></A> " & tobdel.name & "<BR><BR>"
ElseIf Right(tobdel.name, 4) = "jpeg" Then
Response.Write "<A class=button href=default.asp?file=image&delete=Show&FN=" & tobdel.name & "><I><B>View</B></I></A> "
Response.Write "<A class=button href=default.asp?file=image&delete=Sure&FN=" & tobdel.name & "><I><B>Del</B></I></A> " & tobdel.name & "<BR><BR>"
'...or another file type
Else
Response.Write "<A class=button href=default.asp?file=file&delete=Show&FN=" & tobdel.name & "><I><B>View</B></I></A> "
Response.Write "<A class=button href=default.asp?file=file&delete=Sure&FN=" & tobdel.name & "><I><B>Del</B></I></A> " & tobdel.name & "<BR><BR>"
End If
Next
%>
</P>
</BODY>
</HTML>

94
asp/FilesMaths/Directory Search Object.asp Normal file
View File

@ -0,0 +1,94 @@
<%
Class DirSrch
Private strTmp1, strTmp2, gblMatches, bExecuted
Private Sub Class_Initialize()
bExecuted = False
End Sub
Private Function FindDir(ByVal directory, ByVal DirToFind)
If Len( directory ) = 0 And Len( dirtofind ) = 0 Then
FindDir = "" & vbCrLf
Exit Function
End If
Dim objFSO, fldr, folder, tmp
Set objFSO = Server.CreateObject(_
"Scripting.FileSystemObject")
Set fldr = objfso.getfolder(directory)
For Each folder In fldr.subfolders
If UCase( folder.name ) = _
UCase( DirToFind ) Then
tmp = tmp & folder.path & vbCrLf
ElseIf InStr( UCase( folder.path ), _
UCase( DirToFind ) ) Then
tmp = tmp & folder.path & vbCrLf
Else
' tmp = join(tmp, vbCrLf)
tmp = tmp & FindDir( _
folder.path, DirToFind )
End If
Next
Set fldr = Nothing
Set objfso = Nothing
FindDir = tmp
End Function
Public Sub Execute()
Dim a, b
a = Split( FindDir( StartDirectory, _
LookingFor ), vbCrLf )
b = UBound(a) - 1
ReDim Preserve a(b)
gblMatches = a
bExecuted = True
End Sub
Public Function MatchingDirs()
If Not bExecuted Then
Err.Raise 5199, "DirSrch Class", _
"Cannot Call 'MatchingDirs' before " & _
"calling the 'Execute' method."
Exit Function
End If
MatchingDirs = gblMatches
End Function
Public Function CountMatches()
If Not bExecuted Then
Err.Raise 5199, "DirSrch Class", _
"Cannot Call 'CountMatches' before " & _
"calling the 'Execute' method."
Exit Function
End If
CountMatches = CLng( UBound( gblMatches ) + 1 )
End Function
Public Property Let StartDirectory(ByVal strInput)
strTmp1 = strInput
End Property
Public Property Let LookingFor(ByVal strInput)
strTmp2 = strInput
End Property
Public Property Get StartDirectory()
If Len( strTmp1 ) = 0 Then
Err.Raise 5199, "DirSrch Class", _
"You must set the 'StartDirectory' property " & _
"before calling the 'Execute' method."
Exit Property
End If
StartDirectory = strTmp1
End Property
Public Property Get LookingFor()
If Len( strTmp2 ) = 0 Then
Err.Raise 5199, "DirSrch Class", _
"You must set the 'LookingFor' property " & _
"before calling the 'Execute' method."
Exit Property
End If
LookingFor = strTmp2
End Property
End Class
%>

208
asp/FilesMaths/Directory Viewer.asp Normal file
View File

@ -0,0 +1,208 @@
<%@ Language=VBScript %>
<%
' Always display the navigation path?
Const bShowPath = True 'False
' Always display the root directory?
Const bShowRoot = False 'True
' Page font tag
Const sFont = "<font face=""Verdana, Arial, Helvetica"" size=""2"">"
' Column header font tag
Const sColFont = "<font face=""Verdana, Arial, Helvetica"" size=""2"" COLOR=""#FFFFFF"">"
' Column header color
Const TblHeader = "#BFBFBF" 'Grey
' Directory grid alternating colors
Const FileRow1 = "#b6cbeb" 'Dark Blue
Const FileRow2 = "#cadfff" 'Light Blue
Const FolderRow1 = "#879966" 'Dark Green
Const FolderRow2 = "#c5e095" 'Light Green
' Some nice color pairs
'#91619b 'Dark Purple
'#be9cc5 'Light Purple
'#b6cbeb 'Dark Blue
'#cadfff 'Light Blue
'#879966 'Dark Green
'#c5e095 'Light Green
'#a7342a 'Dark Red
'#df867f 'Light Red
'#f8bc03 'Dark Yellow
'#f8e094 'Light Yellow
' ***** Begin Script
Dim sError
On Error Resume Next
sDirectory = Trim(sDirectory)
If Right(sDirectory,1) <> "/" Then sDirectory = sDirectory & "/"
' ***** Get subfolder from passed querystring
sDir = sDirectory & Request.QueryString("dir")
sDir = Trim(sDir)
If Right(sDir,1) <> "/" Then sDir = sDir & "/"
' ***** Important! Make sure the subfolder path is in the shared folder. This keeps
' users from browsing directories outside of the shared. ie: dir=../
' You may want to include some logging code if this happens, here we just
' put the user back into the default directory.
sFolder = Server.MapPath( sDir )
sDirFolder = Server.MapPath( sDirectory )
sSubFolder = Right(sDir,Len(sDir)-Len(sDirectory))
If InStr( sFolder , sDirFolder ) = 0 Then
sFolder = sDirFolder
sSubFolder = ""
sError = sError & " Path not authorized;"
End If
' ***** Load the file system and navigate to our shared folder.
Set objFileObject = Server.CreateObject("Scripting.FileSystemObject")
Set objFolder = objFileObject.GetFolder( sFolder )
' ***** Oops, missing or misspelled folder path.
If IsEmpty( objFolder ) Then
sFolder = sDirFolder
sSubFolder = ""
sDir = sDirectory
Set objFolder = objFileObject.GetFolder( sFolder )
sError = sError & " Folder not found;"
End If
%>
<HTML><BODY BGCOLOR="#FFFFFF" Text="#000000" LINK="#000000" VLINK="#000000">
<font face="Verdana, Arial, Helvetica" size="2">
<BR><B>Welcome To my file archive:</B><BR><BR></font>
<TABLE BORDER=0 bgcolor="#f0f0f0" CELLPADDING=0 CELLSPACING=1>
<% ' ***** Feel free to edit the above table tag
' ***** Build path navigation
aNames = Split( sSubFolder , "/")
If bShowPath Then
If UBound( aNames ) > 0 Or bShowRoot Then %>
<TR BGCOLOR="#ffffff">
<TD><%= sFont %> </font></TD>
<TD COLSPAN="4"><%= sFont %>
<B> <A HREF="<%= Request.ServerVariables("SCRIPT_NAME") %>"><%= Left(sDirectory,len(sDirectory)-1) %></A></B>
<% End If
For count = 0 To UBound( aNames ) -1
aURL = aURL & aNames(count) & "/"
%> <%= sChevron %> <B><A HREF="<%= Request.ServerVariables("SCRIPT_NAME") %>?dir=<%= Server.URLEncode( aURL ) %>"><%= aNames(count) %></A></B><%
Next %></font></TD></TR><%
End If
For count = 0 To UBound( aNames ) -2
aDirUp = aDirUp & aNames(count) & "/"
Next %>
<TR BGCOLOR="<%= TblHeader %>">
<TD BGCOLOR="#ffffff"><A HREF="<%= Request.ServerVariables("SCRIPT_NAME") %>?dir=<%= Server.URLEncode( aDirUp ) %>"><font face="Wingdings" COLOR="<%= TblHeader %>"><3E></font></a></TD>
<TD><%= sColFont %> <B>Filename:</B> </FONT></TD>
<TD><%= sColFont %> <B>Size:</B> </FONT></TD>
<TD><%= sColFont %> <B>File Type:</B> </FONT></TD>
<TD><%= sColFont %> <B>Date created:</B> </FONT></TD>
<%
' ***** Iterate through the subfolders in our shared folder.
For Each objFile In objFolder.SubFolders
' ***** Alternate between these two row colors.
If iAlternate = 0 Then
Response.Write "<TR BGCOLOR=""" & FolderRow1 & """>"
iAlternate = 1
Else
Response.Write "<TR BGCOLOR=""" & FolderRow2 & """>"
iAlternate = 0
End If
' ***** Display folder with link to navigate
%> <TD align="center" BGCOLOR="<%= TblHeader %>"><font face="Wingdings" COLOR="#ffffff">0</font></TD>
<TD><%= sFont %> <A HREF="<%= Request.ServerVariables("SCRIPT_NAME") %>?dir=<%= Server.URLEncode( sSubFolder & objFile.Name )%>"><%= objFile.Name %></A> </font></TD>
<TD align="right"><%= sFont %> <%= ByteConversion( objFile.Size ) %> </font></TD>
<TD><%= sFont %> <%= objFile.Type %> </font></TD>
<TD><%= sFont %> <%= objFile.DateCreated %> </font></TD>
</TR>
<%
' ***** Next Folder
Next
' ***** Iterate through the files in our shared folder / subfolder.
For Each objFile In objFolder.Files
sFileName = objFile.name
' ***** Only continue if it's a valid extension
If ( IsValidFile (sFileName) ) Then
' ***** Alternate between these two row colors.
' We'll use the same counter variable to continue alternating between
' the light / dark shade according to the previous folder row color.
If iAlternate = 0 Then
Response.Write "<TR BGCOLOR=""" & FileRow1 & """>"
iAlternate = 1
Else
Response.Write "<TR BGCOLOR=""" & FileRow2 & """>"
iAlternate = 0
End If
' ***** Display file with link to execute / dowload.
%> <TD align="center" BGCOLOR="<%= TblHeader %>"><font face="Wingdings" COLOR="#ffffff"><</font></TD>
<TD><%= sFont %> <A HREF="<%= sDir %><%= sFileName %>"><%= sFileName %></A> </font></TD>
<TD ALIGN=Right><%= sFont %> <%= ByteConversion( objFile.Size ) %> </font></TD>
<TD><%= sFont %> <%= objFile.Type %> </font></TD>
<TD><%= sFont %> <%= objFile.DateCreated %> </font></TD>
</TR><%
End If
' ***** Next File
Next
' ***** Clean up those nasty memory leaks
Set objFileObject = Nothing
Set objFolder = Nothing
' ***** Iterate through and approve extensions
Function IsValidFile(FileName)
If Not AllowExt <> "" Or LCase( AllowExt ) = "all" Then
IsValidFile = True
Else
aAllowExt = Split( AllowExt & "," , ",")
IsValidFile = False
For iCnt = 0 To UBound( aAllowExt ) -1
If Right( FileName , Len( FileName ) - InStrRev( FileName , "." ) ) = Trim(aAllowExt( iCnt )) Then IsValidFile = True
Next
End If
If DenyExt <> "" Then
aDenyExt = Split( DenyExt & "," , ",")
For iCnt = 0 To UBound( aDenyExt ) -1
If Right( FileName , Len( FileName ) - InStrRev( FileName , "." ) ) = Trim(aDenyExt( iCnt )) Then IsValidFile = False
Next
End If
End Function
' ***** Display friendly byte size
Function ByteConversion(NumberOfBytes)
If NumberOfBytes < 1024 Then
sDisplayBytes = NumberOfBytes & " Bytes"
End If
If NumberOfBytes >= 1024 Then
sDisplayBytes = FormatNumber( NumberOfBytes / 1024, 2) & " KB"
End If
If NumberOfBytes > 1048576 Then
sDisplayBytes = FormatNumber( NumberOfBytes / 1048576, 2) & " MB"
End If
Response.Write sDisplayBytes
End Function
' ***** Did we encounter an Error?
If Err <> 0 Or sError <> "" Then
Response.Write "<TR><TD bgcolor=""#ffffff"" colspan=""5""><font face=""Verdana, Arial, Helvetica"" color=""red"" size=""1"">ERROR: " & sError & Space(1) & "ASP: " & Err.description & ";</font></TD></TR>"
End If
%>
</TABLE>
</BODY></HTML>

19
asp/FilesMaths/Drive Function.asp Normal file
View File

@ -0,0 +1,19 @@
<%
Private Function Drive(ByVal driveSpec)
Dim objFSO, boolFound, objDrive
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
boolFound = objFSO.DriveExists(driveSpec)
If boolFound Then
Set objDrive = objFSO.GetDrive(driveSpec)
If objDrive.IsReady Then
Drive = objDrive.DriveLetter
Else
Drive = Null
End If
Set objDrive = Nothing
Else
Drive = Empty
End If
Set objFSO = Nothing
End Function
%>

16
asp/FilesMaths/File Length Function.asp Normal file
View File

@ -0,0 +1,16 @@
<%
Private Function FileLen(ByVal pathname)
Dim objFSO, objFile
On Error Resume Next
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.GetFile(pathname)
If Err Then
FileLen = Null
Else
FileLen = CLng( objFile.Size )
End If
Set objFile = Nothing
Set objFSO = Nothing
On Error GoTo 0
End Function
%>

158
asp/FilesMaths/File Upload.asp Normal file
View File

@ -0,0 +1,158 @@
<html>
<head>
<title>File Upload</title>
</head>
<body>
<%response.buffer=True
Func = Request("Func")
If IsEmpty(Func) Then
Func = 1
End If
Select Case Func
Case 1
'You do not need to use this form to sen
' d your files.
'However you should not give your submit
' button a NAME or ID.
%>
<font face=verdana>
<H2>Please Select a File To Upload.</H1>
<FORM ENCTYPE="multipart/form-data" ACTION="saveany.asp?func=2" METHOD=POST id=form1 name=form1>
<TABLE>
<TR><TD>Type In the full path And name of the file To upload.</TD></TR>
<TR><TD>-Or-</TD></TR>
<TR><TD>Hit the [Browse] button To find the file On your computer.<BR><BR></TD></TR>
<TR><TD>Then hit the [Upload] button.<BR><BR></TD></TR>
<TR><TD><STRONG>File Name...</STRONG></TD></TR>
<TR><TD><Input NAME=File1 SIZE=30 Type=file><BR></TD></TR>
<TR><TD><Input NAME=File2 SIZE=30 Type=file><BR></TD></TR>
<TR><TD><Input NAME=File2 SIZE=30 Type=file><BR></TD></TR>
<TR><TD align=Left><Input Type="submit" value="Upload File"><BR><BR></TD></TR>
<TR><TD>NOTE: Please be patient, you will Not receive any notification until the file Is completely transferred.<BR><BR></TD></TR>
</TABLE>
</font>
<%
Case 2
ForWriting = 2
adLongVarChar = 201
lngNumberUploaded = 0
'Get binary data from form
noBytes = Request.TotalBytes
binData = Request.BinaryRead (noBytes)
'convery the binary data to a string
Set RST = CreateObject("ADODB.Recordset")
LenBinary = LenB(binData)
If LenBinary > 0 Then
RST.Fields.Append "myBinary", adLongVarChar, LenBinary
RST.Open
RST.AddNew
RST("myBinary").AppendChunk BinData
RST.Update
strDataWhole = RST("myBinary")
End If
'Creates a raw data file for with all da
' ta sent. Uncomment for debuging.
'Set fso = CreateObject("Scripting.FileSystemObject")
'Set f = fso.OpenTextFile(server.mappath(".") & "
aw.txt", ForWriting, True)
'f.Write strDataWhole
'set f = nothing
'set fso = nothing
'get the boundry indicator
strBoundry = Request.ServerVariables ("HTTP_CONTENT_TYPE")
lngBoundryPos = InStr(1,strBoundry,"boundary=") + 8
strBoundry = "--" & Right(strBoundry,Len(strBoundry)-lngBoundryPos)
'Get first file boundry positions.
lngCurrentBegin = InStr(1,strDataWhole,strBoundry)
lngCurrentEnd = InStr(lngCurrentBegin + 1,strDataWhole,strBoundry) - 1
Do While lngCurrentEnd > 0
'Get the data between current boundry an
' d remove it from the whole.
strData = Mid(strDataWhole,lngCurrentBegin, lngCurrentEnd - lngCurrentBegin)
strDataWhole = Replace(strDataWhole,strData,"")
'Get the full path of the current file.
lngBeginFileName = InStr(1,strdata,"filename=") + 10
lngEndFileName = InStr(lngBeginFileName,strData,Chr(34))
'Make sure they selected at least one fi
' le.
If lngBeginFileName = lngEndFileName And lngNumberUploaded = 0 Then
Response.Write "<font face=verdana><H2> The following Error occured.</H2>"
Response.Write "You must Select at least one file To upload"
Response.Write "<BR><BR>Hit the back button, make the needed corrections and resubmit your information."
Response.Write "<BR><BR><INPUT type='button' onclick='history.go(-1)' value='<< Back' id='button'1 name='button'1></font>"
Response.End
End If
'There could be one or more empty file b
' oxes.
If lngBeginFileName <> lngEndFileName Then
strFilename = Mid(strData,lngBeginFileName,lngEndFileName - lngBeginFileName)
'Creates a raw data file with data betwe
' en current boundrys. Uncomment for debug
' ing.
'Set fso = CreateObject("Scripting.FileSystemObject")
'Set f = fso.OpenTextFile(server.mappath(".") & "
aw_" & lngNumberUploaded & ".txt", ForWriting, True)
'f.Write strData
'set f = nothing
'set fso = nothing
'Loose the path information and keep jus
' t the file name.
tmpLng = InStr(1,strFilename,"")
Do While tmpLng > 0
PrevPos = tmpLng
tmpLng = InStr(PrevPos + 1,strFilename,"")
Loop
FileName = Right(strFilename,Len(strFileName) - PrevPos)
'Get the begining position of the file d
' ata sent.
'if the file type is registered with the
' browser then there will be a Content-Typ
' e
lngCT = InStr(1,strData,"Content-Type:")
If lngCT > 0 Then
lngBeginPos = InStr(lngCT,strData,Chr(13) & Chr(10)) + 4
Else
lngBeginPos = lngEndFileName
End If
'Get the ending position of the file dat
' a sent.
lngEndPos = Len(strData)
'Calculate the file size.
lngDataLenth = lngEndPos - lngBeginPos
'Get the file data
strFileData = Mid(strData,lngBeginPos,lngDataLenth)
'Create the file.
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile(Server.MapPath(".") & "" & FileName, ForWriting, True)
f.Write strFileData
Set f = Nothing
Set fso = Nothing
lngNumberUploaded = lngNumberUploaded + 1
End If
'Get then next boundry postitions if any
' .
lngCurrentBegin = InStr(1,strDataWhole,strBoundry)
lngCurrentEnd = InStr(lngCurrentBegin + 1,strDataWhole,strBoundry) - 1
Loop
Response.Write "<H2>File(s) Uploaded</H2>"
Response.Write lngNumberUploaded & " files have been uploaded.<BR>"
Response.Write "<BR><BR><INPUT type='button' onclick='document.location=" & Chr(34) & "saveany.asp" & Chr(34) & "' value='<< Back to Listings' id='button'1 name='button'1>"
End Select
%>
</BODY>
</HTML>

17
asp/FilesMaths/File-Path-Extension Stripping.asp Normal file
View File

@ -0,0 +1,17 @@
<%option explicit%>
<%
Const ForReading=1
Dim fso,ts,file,i
file=Request.QueryString("file")
Set fso = Server.CreateObject("Scripting.FileSystemObject")
Set ts = fso.OpenTextFile( Server.MapPath(file), ForReading)
%>
<H1><CENTER><%=file%></CENTER></H1>
<%
While Not ts.AtEndOfStream
i=i+1
Response.Write "<B>" & i & ". </B>" & Server.HTMLEncode(ts.readline) & "<BR>"
Wend
Set ts=Nothing
Set fso=Nothing
%>

23
asp/FilesMaths/FileCopy Statement.asp Normal file
View File

@ -0,0 +1,23 @@
<%
Private Sub FileCopy(ByVal source, ByVal destination)
Dim objFSO, objToCopy, boolErr, strErrDesc
On Error Resume Next
Set objFSO = Server.CreateObject("scripting.filesystemobject")
If InStr( Right( source, 4 ), "." ) Then
' probably a file
Set objToCopy = objFSO.GetFile(source)
Else
' probably a directory or folder
Set objToCopy = objFSO.GetFolder(source)
End If
objToCopy.Copy destination
If Err Then
boolErr = True
strErrDesc = Err.description
End If
Set objToCopy = Nothing
Set objFSO = Nothing
On Error GoTo 0
If boolErr Then Err.Raise 5104, "FileCopy Statement", strErrDesc
End Sub
%>

16
asp/FilesMaths/FileDateTime Function.asp Normal file
View File

@ -0,0 +1,16 @@
<%
Private Function FileDateTime(ByVal pathname)
Dim objFSO, objFile
On Error Resume Next
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.GetFile(pathname)
If Err Then
FileDateTime = Null
Else
FileDateTime = CDate( objFile.DateLastModified )
End If
Set objFile = Nothing
Set objFSO = Nothing
On Error GoTo 0
End Function
%>

18
asp/FilesMaths/FileRead Function.asp Normal file
View File

@ -0,0 +1,18 @@
<%
Private Function FileRead(ByVal pathname)
Dim objFSO, objFile, tmp
On Error Resume Next
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(pathname, 1, False)
tmp = objFile.ReadAll
If Err Then
FileRead = Null
Else
FileRead = tmp
End If
objFile.Close
Set objFile = Nothing
Set objFSO = Nothing
On Error GoTo 0
End Function
%>

23
asp/FilesMaths/FileWrite Statement.asp Normal file
View File

@ -0,0 +1,23 @@
<%
Private Sub FileWrite(ByVal pathname, ByVal strToWrite, ByVal boolOverWrite)
Dim objFSO, objFile, boolErr, strErrDesc, lngWriteMethod
On Error Resume Next
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
If boolOverWrite Then
lngWriteMethod = 2
Else
lngWriteMethod = 8
End If
Set objFile = objFSO.OpenTextFile(pathname, lngWriteMethod, False)
objFile.Write strToWrite
If Err Then
boolErr = True
strErrDesc = Err.description
End If
objFile.Close
Set objFile = Nothing
Set objFSO = Nothing
On Error GoTo 0
If boolErr Then Err.Raise 5107, "FileWrite Statement", strErrDesc
End Sub
%>

24
asp/FilesMaths/Find And Delete.asp Normal file
View File

@ -0,0 +1,24 @@
Const ForReading = 1
Const ForWriting = 2
Set fso = Wscript.CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder("d:inetpubwwwroot")
Set files = folder.files
varText = "Script that you want to delete"
For Each f1 In files
If InStr(f1,".asp") > 0 Or InStr(f1,".htm") > 0 Or InStr(f1,".html") > 0
Then
Set f = fso.OpenTextFile(f1,ForReading)
If Not f.AtEndOfStream Then
varNew = Replace(f.ReadAll,varText,"")
Set f = fso.OpenTextFile(f1,ForWriting )
f.Write varNew
End If
Set f = Nothing
End If
Next
MsgBox "Change OK"

33
asp/FilesMaths/Format Numbers.asp Normal file
View File

@ -0,0 +1,33 @@
<html><head>
<TITLE>formatnumbers2.asp</TITLE>
</head><body bgcolor="#FFFFFF">
<%
' My ASP formatting number sample
mynumber=123.4567
Response.Write "<hr>" & mynumber & "<br>"
Response.Write "formatnumber(mynumber,0)" & "<br>"
Response.Write FormatNumber(mynumber,0) & "<hr>"
Response.Write "formatnumber(mynumber,2)" & "<br>"
Response.Write FormatNumber(mynumber,2) & "<hr>"
Response.Write "formatnumber(mynumber,6)" & "<br>"
Response.Write FormatNumber(mynumber,6) & "<hr>"
mynumber=.4567
Response.Write mynumber & "<br>"
'0 means means no leading zeroes
Response.Write "formatnumber(mynumber,2,0)" & "<br>"
Response.Write FormatNumber(mynumber,2,0) & "<hr>"
'1 means means pad with leading zeroes
'response.write "formatnumber(mynumber,2,1)" & "<br>"
'response.write formatnumber(mynumber,2,1) & "<hr>"
'mynumber=-123.4567
'response.write mynumber & "<br>"
'0 means means no parentheses for negative numbers
'response.write "formatnumber(mynumber,2,0,0)" & "<br>"
'response.write formatnumber(mynumber,2,0,0) & "<hr>"
'1 means means yes parentheses for negative numbers
'response.write "formatnumber(mynumber,2,0,1)" & "<br>"
'response.write formatnumber(mynumber,2,0,1) & "<hr>"
%>
</body></html>

74
asp/FilesMaths/GUID Generator - 26 Characters.asp Normal file
View File

@ -0,0 +1,74 @@
GUID Generator - 26 Characters
'Generate 26 charcter Unique ID
Function GetUniqueId()
Dim strUniqueID, GUID
Dim iCount, strBinary, strUniqueChar
'Set GUID = Server.CreateObject("GuidMak
' r.GUID")
Set GUID = Server.CreateObject("GuidMakr.GUID")
strUniqueID = Trim(GUID.GetGUID) 'Returns something like E06019F5A31311D4902B00A0C9ECF1DF
'Remove -, { in the generated number
strUniqueID = Right(Left(Replace(strUniqueID, "-", ""), 33), 32)
'Convert to binary
strBinary = ""
For iCount = 1 To 32
strBinary = strBinary & ConvertHexToBin(Mid(strUniqueID, iCount, 1))
Next
'make it to 130 bit number
strBinary = strBinary & "00"
'Regroup binary into 5bits and convert t
' o number
For iCount = 1 To 130 Step 5
strNo = (CInt(Mid(strBinary, iCount, 1)) * 16) + (CInt(Mid(strBinary, iCount + 1, 1)) * 8) + (CInt(Mid(strBinary, iCount + 2, 1)) * 4) + (CInt(Mid(strBinary, iCount + 3, 1)) * 2) + (CInt(Mid(strBinary, iCount + 4, 1)))
'If greater than 9 convert the number To alphabet. Where A maps to 10
If strNo > 9 Then
strChar = Chr(strNo + 56)
Else
strChar = CStr(strNo)
End If
strUniqueChar = strUniqueChar & strChar
Next
GetUniqueId = strUniqueChar 'Something like T1H1KUE32D8U941C02HDKS7IST
End Function
Function ConvertHexToBin(strHex)
Dim strBin
Select Case UCase(strHex)
Case "0"
strBin = "0000"
Case "1"
strBin = "0001"
Case "2"
strBin = "0010"
Case "3"
strBin = "0011"
Case "4"
strBin = "0100"
Case "5"
strBin = "0101"
Case "6"
strBin = "0110"
Case "7"
strBin = "0111"
Case "8"
strBin = "1000"
Case "9"
strBin = "1001"
Case "A"
strBin = "1010"
Case "B"
strBin = "1011"
Case "C"
strBin = "1100"
Case "D"
strBin = "1101"
Case "E"
strBin = "1110"
Case "F"
strBin = "1111"
Case Else
strBin = ""
End Select
ConvertHexToBin = strBin
End Function

37
asp/FilesMaths/Hex to Bin.asp Normal file
View File

@ -0,0 +1,37 @@
Function HexToBin(hexvalue)
Dim i, s, ilen, value, values
Set values = CreateObject("Scripting.Dictionary")
values.Add "0", "0000"
values.Add "1", "0001"
values.Add "2", "0010"
values.Add "3", "0011"
values.Add "4", "0100"
values.Add "5", "0101"
values.Add "6", "0110"
values.Add "7", "0111"
values.Add "8", "1000"
values.Add "9", "1001"
values.Add "A", "1010"
values.Add "B", "1011"
values.Add "C", "1100"
values.Add "D", "1101"
values.Add "E", "1110"
values.Add "F", "1111"
value = Null
s = UCase(hexvalue)
If IsHex(s) Then
value = ""
ilen = Len(s)
For i = 1 To ilen
value = value & values(Mid(s, i, 1))
Next
End If
values.RemoveAll
Set values = Nothing
HexToBin = value
End Function

185
asp/FilesMaths/INITool Object.asp Normal file
View File

@ -0,0 +1,185 @@
<%
Class INITool
Private dHeaders 'Scripting.Dictionary
Private fso 'Scripting.FileSystemObject
Private gblPath
Private Sub Class_Initialize
Set dHeaders = CreateObject("Scripting.Dictionary")
dHeaders.RemoveAll
End Sub
Private Sub Class_Terminate
dHeaders.RemoveAll
Set dHeaders = Nothing
End Sub
Public Sub Load(ByVal fPath)
'load file into dictionary by header
Dim f, s, key, value, dKeysVals, lastHeader
dHeaders.RemoveAll
gblPath = fPath
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.fileexists(fPath) Then
Set f = fso.OpenTextFile(fPath, 1, False)
While Not f.atendofstream
s = Trim(f.readline)
If Not Left(s, 1) = ";" Then
If Left(s, 1) = "[" And Right(s, 1) = "]" Then
lastHeader = Mid(s, 2, Len(s) - 2)
If Not dHeaders.Exists(s) Then
dHeaders.Add UCase(lastHeader), lastHeader
End If
Else
If Len(Trim(s)) > 0 Then
key = Left(s, InStr(s, "=") - 1)
value = Right(s, Len(s) - InStr(s, "="))
If Not dHeaders.Exists(UCase(lastHeader) & _
"~" & UCase(key)) Then
dHeaders.Add UCase(lastHeader) & _
"~" & UCase(key), value
End If
End If
End If
End If
Wend
f.Close
Set f = Nothing
End If
Set fso = Nothing
End Sub
Public Sub DumpHashTable
Dim Item
Response.Write("<PRE>")
For Each Item In dHeaders.Keys
Response.Write( Item & vbCrLf )
Response.Write( dHeaders.Item(Item) & vbCrLf & vbCrLf )
Next
Response.Write("</PRE>")
End Sub
Public Function Read(ByVal header, ByVal key, ByVal defaultvalue)
Dim s
s = ""
If dHeaders.Exists(UCase(header) & "~" & UCase(key)) Then
s = dHeaders.Item(UCase(header) & "~" & UCase(key))
End If
If s = "" Then s = defaultvalue
Read = s
End Function
Public Function Write(ByVal header, ByVal key, ByVal newvalue)
If Not dHeaders.Exists(UCase(header)) Then
'create header
dHeaders.Add UCase(header), header
End If
If dHeaders.Exists(UCase(header) & "~" & UCase(key)) Then
'update value of key
dHeaders.Item(UCase(header) & "~" & UCase(key)) = newvalue
Else
'add key/value combo
dHeaders.Add UCase(header) & "~" & UCase(key), newvalue
End If
End Function
Public Sub Remove(ByVal header, ByVal key)
If dHeaders.Exists(UCase(header) & "~" & UCase(key)) Then
dHeaders.Remove UCase(header) & "~" & UCase(key)
End If
End Sub
Public Function Headers()
Dim Item, s
For Each Item In dHeaders.Keys
If UCase(Item) = UCase(dHeaders.Item(Item)) Then
s = s & dHeaders.Item(Item) & "~"
End If
Next
If Len(s) > 0 Then s = Left(s, Len(s) - 1)
If InStr(s, "~") Then
Headers = Split(s, "~")
Else
Headers = ""
End If
End Function
Public Function Keys(ByVal header)
Dim item, s, re, tmp
Set re = New RegExp
re.ignorecase = True
re.pattern = "^" & header & "~"
For Each Item In dHeaders.Keys
If re.test(Item) Then
tmp = Mid(Item, InStr(Item, "~") + 1)
If Trim(tmp) <> "" Then
s = s & tmp & "~"
End If
End If
Next
Set re = Nothing
If Len(s) > 0 Then s = Left(s, Len(s) - 1)
If InStr(s, "~") Then
Keys = Split(s, "~")
Else
Keys = ""
End If
End Function
Public Sub Clear
dHeaders.RemoveAll
End Sub
Public Sub Save()
Dim Item, oRs, header, key, value, last, f
Set oRs = CreateObject("ADODB.Recordset")
oRs.Fields.Append "Header", 200, 100 ' 100 char limit on headers
oRs.Fields.Append "Key", 200, 65 ' 65 char limit on keys
oRs.Fields.Append "Value", 200, 255 ' 255 char limit on value
oRs.Open
For Each Item In dHeaders.Keys
If Item <> dHeaders.Item(Item) Then
If InStr(Item, "~") > 0 Then
header = Left(Item, InStr(Item, "~") - 1)
key = Mid(Item, InStr(Item, "~") + 1)
value = dHeaders.Item(Item)
oRs.AddNew
oRs.Fields("Header").Value = header
oRs.Fields("Key").Value = key
oRs.Fields("Value").Value = value
oRs.Update
End If
End If
Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile(gblPath, 2, True)
If Not oRs.BOF Then
oRs.Sort = "Header asc, Key asc"
oRs.MoveFirst
While Not oRS.EOF
If last <> oRs.Fields("Header").Value Then
f.WriteLine "[" & oRs.Fields("Header").Value & "]"
last = oRs.Fields("Header").Value
End If
f.WriteLine oRs.Fields("Key").Value & "=" & _
oRs.Fields("Value").Value
oRs.MoveNext
Wend
Else
f.write ""
End If
f.Close
Set f = Nothing
Set fso = Nothing
oRs.Close
Set oRs = Nothing
End Sub
End Class
%>

28
asp/FilesMaths/Kill Statement.asp Normal file
View File

@ -0,0 +1,28 @@
example usage:
Deletes file.txt In directory New Folder off C drive's root.
<% Kill "C:New Folderfile.txt" %>
Deletes file.txt In directory New Folder off the server's root.
<% Kill Server.MapPath("/New Folder/file.txt") %>
Deletes all files In directory New Folder off the C drive's root.
<% Kill "C:New Folder*" %>
Deletes all files In directory New Folder off the server's root.
<% Kill Server.MapPath("/New Folder") & "*" %>
source code:
<%
Private Sub Kill(ByVal pathname)
Dim objFSO, boolErr, strErrDesc
On Error Resume Next
Set objFSO = Server.CreateObject("scripting.filesystemobject")
objFSO.DeleteFile pathname
If Err Then
boolErr = True
strErrDesc = Err.description
End If
Set objFSO = Nothing
On Error GoTo 0
If boolErr Then Err.Raise 5102, "Kill Statement", strErrDesc
End Sub
%>

16
asp/FilesMaths/Make HTML File.asp Normal file
View File

@ -0,0 +1,16 @@
<% Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim strFileName, objFSO, objMenuPage
Set objFSO = CreateObject("Scripting.FileSystemObject")
strFileName = "c: empMyFile2.htm"
Set objMenuPage = objFSO.createtextFile(strFileName, forWriting, True) 'overwrite
'write the HTML page
objMenuPage.WriteLine "<HTML><head><title>Test Creating file</title></title></head>"
objMenuPage.WriteLine "<BODY><P><B>List of files available</B></P>"
objMenuPage.WriteLine Now() //Write out the time Use all VBScript functions!
objMenuPage.WriteLine "</body></html>"
objMenuPage.Close %>

50
asp/FilesMaths/MkDatabase Function.asp Normal file
View File

@ -0,0 +1,50 @@
click an example below
VBScript: SQLServerTools ...
MkDatabase Function
< prev proc
MkArchive Function Next proc >
MkDir Statement
syntax:
MkDatabase pathname
example usage:
<%
MkDatabase "C:database.mdb"
%>
source code:
<%
Private Sub MkDatabase(ByVal pathname)
Dim objAccess, objFSO
If LCase( Right( pathname, 4 ) ) <> ".mdb" Then
Err.Raise 5155, "MkDatabase Statement", _
"Database name must end with '.mdb'"
Exit Sub
End If
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists( pathname ) Then
Set objFSO = Nothing
Err.Raise 5155, "MkDatabase Statement", _
"Specified MS Access database already exists."
Exit Sub
End If
Set objFSO = Nothing
On Error Resume Next
Set objAccess = CreateObject("Access.Application")
If Err Then
On Error GoTo 0
Err.Raise 5155, "MkDatabase Statement", _
"MS Access is not installed on this server."
Exit Sub
End If
With objAccess
.Echo False
.NewCurrentDatabase pathname
.CloseCurrentDatabase
.Quit
End With
Set objAccess = Nothing
On Error GoTo 0
End Sub
%>

22
asp/FilesMaths/MkDir Statement.asp Normal file
View File

@ -0,0 +1,22 @@
example usage:
Create a directory called "New Folder" On the root of the server.
<% MkDir Server.MapPath("/New Folder") %>
source code:
<%
Private Sub MkDir(ByVal path)
Dim objFSO, boolErr, strErrDesc
boolErr = False
On Error Resume Next
Set objFSO = Server.CreateObject("scripting.filesystemobject")
objFSO.CreateFolder path
If Err Then
boolErr = True
strErrDesc = Err.description
End If
Set objFSO = Nothing
On Error GoTo 0
If boolErr Then Err.Raise 5101, "MkDir Statement", strErrDesc
End Sub
%>

27
asp/FilesMaths/MkFile Statement.asp Normal file
View File

@ -0,0 +1,27 @@
<%
' Make an asp file named File in the directory New Folder
MkFile Server.MapPath("/New Folder/File.asp")
%>
source code:
<%
Private Sub MkFile(ByVal pathname)
Dim objFSO, boolErr, strErrDesc
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists(pathname) Then
Err.Raise 5106, "MkFile Statement", "File [" & pathname & "] " & _
"Already Exists. Use the Kill statement to delete files."
Else
On Error Resume Next
objFSO.CreateTextFile pathname, 2, True
If Err Then
boolErr = True
strErrDesc = Err.description
End If
On Error GoTo 0
If boolErr Then Err.Raise 5106, "MkFile Statement", strErrDesc
End If
Set objFSO = Nothing
End Sub
%>

49
asp/FilesMaths/Mortgage Amortization.asp Normal file
View File

@ -0,0 +1,49 @@
<CENTER>
<%
Dim P 'Payment
Dim I 'Interest
Dim L 'Loan Term In Years
Dim J
Dim N
Dim M
Dim H
Dim C
Dim Q
Dim X
'Set the Conter for the Ammoritization
X=0
'Hard Code Some Loan Values HERE
'Replace these with your variables
'Total of Loan Amount
P=100000
'Interest Rate
I=7
'Loan term in years
L=30
'Calculate Monthly Interest
J=I/(12 * 100)
'Length of loan in Months
N=L * 12
'Now the magic.....
M = P * ( J / (1 - (1 + J) ^ -N))
Response.Write "<B>Monthly Payment: " & Round(M, 2) & "</B><BR>"
Response.Write "<TABLE cellSpacing=1 cellPadding=1 width=""55%"" bgColor=silver border=0>"
Response.Write "<TD bgColor=#708090>Interest Paid</TD>"
Response.Write "<TD bgColor=#708090>Principal Paid</TD>"
Response.Write "<TD bgColor=#708090>Remaing Balance</TD></TR>"
Response.Write "<TR>"
'Loop through And Get the Monthly Paymen
' ts for the length of the loan
Do While X < N
H=P*J
Response.Write "<TD bgColor=silver>" & Round(H, 2) & "</TD>"
C=M-H
Response.Write "<TD bgColor=silver>" & Round(C, 2) & "</TD>"
Q=P-C
Response.Write "<TD bgColor=silver>" & Round(Q, 2) & "</TD></TR>"
P=Q
X=X+1
Loop
%>
</TABLE>
</CENTER>

50
asp/FilesMaths/Nautical-Flight Functions.asp Normal file
View File

@ -0,0 +1,50 @@
'miles per hour to knots
Private Function MPHToKt(ByVal mph)
MPHToKt = CDbl(CDbl(mph) / 1.152)
End Function
'knots to miles per hour
Private Function KtToMPH(ByVal kt)
KtToMPH = CDbl(1.152 * CDbl(Kt))
End Function
'miles to nautical miles
Private Function miToNautMi(ByVal miles)
MiToNautMi = CDbl((CDbl(miles) * 5280) / 6076.1)
End Function
'nautical miles to miles
Private Function nautMiToMi(ByVal nautMi)
NautMiToMi = CDbl((CDbl(nautMi) * 6076.1) / 5280)
End Function
'flight time in minutes
Private Function minsInFlight(ByVal nautMi, ByVal kt)
MinsInFlight = CDbl((CDbl(nautMi) / CDbl(kt)) * 60)
End Function
'nautical miles flown
Private Function nautMiFlown(ByVal kt, ByVal mins)
NautMiFlown = (CDbl(mins) / 60) * CDbl(CDbl(kt))
End Function
'average speed in knots
Private Function ktSpeed(ByVal nautMi, ByVal mins)
ktSpeed = CDbl(CDbl(nautMi) / (CDbl(mins) / 60))
End Function
'hours to minutes
Private Function hrMins(ByVal hr)
hrMins = CDbl(CDbl(hr) * 60)
End Function
'seconds to minutes
Private Function sdMins(ByVal sd)
sdMins = CDbl(CDbl(sd) / 60)
End Function
'gallons of fuel needed
Private Function galFuel(ByVal mins, ByVal gph)
galFuel = CDbl((CDbl(mins) / 60) * gph)
End Function

22
asp/FilesMaths/Number to Decimal.asp Normal file
View File

@ -0,0 +1,22 @@
Function Any2Dec(ByVal otherBaseNumber As String, ByVal base As Integer) As Long
Dim index As Long
Dim digits As String
Dim digitValue As Long
' check base
If base < 2 Or base > 36 Then Err.Raise 5
' get the list of valid digits
digits = Left("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ", base)
' convert to decimal
For index = 1 To Len(otherBaseNumber)
' get the digit's value
digitValue = InStr(1, digits, Mid$(otherBaseNumber, index, 1), _
vbTextCompare) - 1
' error if invalid digit
If digitValue < 0 Then Err.Raise 5
' add to running result
Any2Dec = Any2Dec * base + digitValue
Next
End Function

90
asp/FilesMaths/RC4 Class.asp Normal file
View File

@ -0,0 +1,90 @@
<%
Option Explicit
Dim ObjRC4
Set ObjRC4 = New clsRC4
ObjRC4.Key = "Joe"
Response.Write """" & ObjRC4.Crypt("hello") & """"
Set ObjRC4 = Nothing
' --------------------------------------
Class clsRC4
Private mStrKey
Private mBytKeyAry(255)
Private mBytCypherAry(255)
Private Sub InitializeCypher()
Dim lBytJump
Dim lBytIndex
Dim lBytTemp
For lBytIndex = 0 To 255
mBytCypherAry(lBytIndex) = lBytIndex
Next
' Switch values of Cypher arround based off of index and Key value
lBytJump = 0
For lBytIndex = 0 To 255
' Figure index To switch
lBytJump = (lBytJump + mBytCypherAry(lBytIndex) + mBytKeyAry(lBytIndex)) Mod 256
' Do the switch
lBytTemp = mBytCypherAry(lBytIndex)
mBytCypherAry(lBytIndex) = mBytCypherAry(lBytJump)
mBytCypherAry(lBytJump) = lBytTemp
Next
End Sub
Public Property Let Key(ByRef pStrKey)
Dim lLngKeyLength
Dim lLngIndex
If pStrKey = mStrKey Then Exit Property
lLngKeyLength = Len(pStrKey)
If lLngKeyLength = 0 Then Exit Property
mStrKey = pStrKey
lLngKeyLength = Len(pStrKey)
For lLngIndex = 0 To 255
mBytKeyAry(lLngIndex) = Asc(Mid(pStrKey, ((lLngIndex) Mod (lLngKeyLength)) + 1, 1))
Next
End Property
Public Property Get Key()
Key = mStrKey
End Property
Public Function Crypt(ByRef pStrMessage)
Dim lBytIndex
Dim lBytJump
Dim lBytTemp
Dim lBytY
Dim lLngT
Dim lLngX
' Validate data
If Len(mStrKey) = 0 Then Exit Function
If Len(pStrMessage) = 0 Then Exit Function
Call InitializeCypher()
lBytIndex = 0
lBytJump = 0
For lLngX = 1 To Len(pStrMessage)
lBytIndex = (lBytIndex + 1) Mod 256 ' wrap index
lBytJump = (lBytJump + mBytCypherAry(lBytIndex)) Mod 256 ' wrap J+S()
' Add/Wrap those two
lLngT = (mBytCypherAry(lBytIndex) + mBytCypherAry(lBytJump)) Mod 256
' Switcheroo
lBytTemp = mBytCypherAry(lBytIndex)
mBytCypherAry(lBytIndex) = mBytCypherAry(lBytJump)
mBytCypherAry(lBytJump) = lBytTemp
lBytY = mBytCypherAry(lLngT)
' Character Encryption ...
Crypt = Crypt & Chr(Asc(Mid(pStrMessage, lLngX, 1)) Xor lBytY)
Next
End Function
End Class
%>

139
asp/FilesMaths/Recurse and Rename.asp Normal file
View File

@ -0,0 +1,139 @@
<%@ Language=VBScript %>
<%
Option Explicit
Dim bEnabled
Dim fso 'as file system object
Dim nTotalFilesRenamed 'as integer
bEnabled=False '**** Set to false the script will not rename files, change this to true for renaming to take place.
Server.ScriptTimeout=120 'Set the page timeout to 2 mins
Const sStartDirectory="c: emp" '*** This is the starting directory
'Be carefull where you start as this
'script renames any file under this dir
'that contain blanks. ***
'Setup the file system object
Set fso = Server.CreateObject("Scripting.FileSystemObject")
%>
<HTML>
<HEAD>
<title>Document</title>
<style>
Body {
background-color: #FFFFFF;
color: #000000;
font-family: Verdana, Arial, Helvetica, sans-serif, "MS sans serif";
}
TD {
background-color: #FFFFFF;
color: #000000;
font-family: Verdana, Arial, Helvetica, sans-serif, "MS sans serif";
font-size: 70%
}
.TableTitle {
background-color: #FFFFCE;
}
.Summary {
background-color: #FFCE9C;
}
.Rename {
background-color: #FFFF9C;
}
</style>
</HEAD>
<BODY>
<table width="60%" border="1" align="center" cellspacing="0" cellpadding="2">
<tr>
<td Class="TableTitle"><b>X <a href="http://www.X.com"></a></b><br>
<i>Start Directory: <%=sStartDirectory %></i></td>
</tr>
<%
If bEnabled=False Then
Response.Write "<tr><td class=""TableTitle""><b>This script is disabled, please read the instructions (only a couple of lines) to enable it!</b></td></tr>" & vbCrLf
End If
'Start with current folder
Response.Write "<tr><td>" & sStartDirectory & "</td></tr>" & vbCrLf
Call RenameFilesStripBlanks(sStartDirectory)
'Call the RecurseFolder function to recurse down from the start directory.
Call RecurseFolder(sStartDirectory, fso)
%>
<tr>
<td Class="TableTitle">Total Files Renamed: <%=nTotalFilesRenamed %></i></td>
</tr>
</table>
</BODY>
</HTML>
<%
Dim fFolder, fSubFolders, fSubFolder
Set fFolder = fso.GetFolder(sPath)
Set fSubFolders = fFolder.SubFolders
'Now recurse for each subfolder in the sPath folder...
For Each fSubFolder In fSubFolders
Response.Write "<tr><td>" & sPath & "" & fSubFolder.name & "</td></tr>" & vbCrLf
'Rename all files in this directory where filename contains blanks
RenameFilesStripBlanks(sPath & "" & fSubFolder.name)
'*** Call self to recurse down folders
Call RecurseFolder(sPath & "" & fSubFolder.name, fso)
Next
End Sub
Dim nFilesRenamed, drive, folder, filelist, file, sNewFile
nFilesRenamed=0
Set drive = Server.CreateObject("Scripting.FileSystemObject")
Set folder = drive.GetFolder(sPath)
Set filelist = folder.files
For Each file In filelist
sNewFile=Replace(file.name," ","")
If (sNewFile<>file.name And bEnabled=True) Then
Response.Write "<tr><td class=""Rename"">" & "Rename:" & file.name & " to " & sNewFile & "</td></tr>"
'If the new filename does not exist then change file, else flag to user
If Not(fso.FileExists(sPath & "" & sNewFile)) Then
'Rename the file
file.name = sNewFile
Else
Response.Write "<tr><td class=""Rename"">" & "Renamed File Exists:" & file.name & " to " & sNewFile & "</td></tr>"
End If
'Increment the files renamed counter
nFilesRenamed=nFilesRenamed + 1
End If
Next
'Inform user of number of files renamed in current directory
If nFilesRenamed<>0 Then
Response.Write "<tr><td class=""Summary"">" & nFilesRenamed & " Renamed" & "</td></tr>" & vbCrLf
End If
'Increment the total files renamed counter
nTotalFilesRenamed=nTotalFilesRenamed + nFilesRenamed
End Sub
%>

21
asp/FilesMaths/Remove Directory Statement.asp Normal file
View File

@ -0,0 +1,21 @@
example usage:
<% RmDir "C:New Folder" %>
<% RmDir Server.MapPath("/New Folder") %>
source code:
<%
Private Sub RmDir(ByVal path)
Dim objFSO, boolErr, strErrDesc
boolErr = False
On Error Resume Next
Set objFSO = Server.CreateObject("scripting.filesystemobject")
objFSO.DeleteFolder path
If Err Then
boolErr = True
strErrDesc = Err.description
End If
Set objFSO = Nothing
On Error GoTo 0
If boolErr Then Err.Raise 5100, "RmDir Statement", strErrDesc
End Sub
%>

61
asp/FilesMaths/SQL AverageNumber.asp Normal file
View File

@ -0,0 +1,61 @@
<%
'Holds the original Number
Dim strNum
'Holds the new fixed number
Dim strNumFixed
'Get the ID usually an AutoNumber field,
' Just comment out or supply your own
strYourID = Request.QueryString("ID")
'Sets your connection, I used a system D
' SN in this example
Set Con = Server.CreateObject("ADODB.Connection")
'Name of your DSN
Con = "YourDSN"
'Sets the RecordSet
Set RS = Server.CreateObject("ADODB.Recordset")
'Your SQL string, this will generate the
' Average Number "AS" Average all on the S
' erver
SQLString = "SELECT AVG(tblOfRecord.the_colum) AS Average FROM tblOfRecord WHERE "
SQLString = SQLString & "tblOfRecord.Your_ID='" & strYourID & "' "
'Open it all up
RS.Open SQLString,Con
'Get the Averaged number
strNum = RS("Average")
'Fix the number so you dont have a bunch
' of 2.3333333,this will display i.e 2.3
strNumFixed = FormatNumber(strNum,1)
'Display the Correct HTML for your numbe
' r, make it to how you wish.
Response.Write "<HTML>"
Response.Write "<HEAD>"
Response.Write "<TITLE>" & "AverageNumber" & "</TITLE>"
Response.Write "<META http-equiv=""Content-Type"" content=""text/html; charset=iso-8859-1"">" 'Dont have To have this
Response.Write "</HEAD>"
Response.Write "<BODY bgcolor=""#FFFFFF"" text=""#000000"">"
Response.Write "<B>" & strNumFixed & "</B>"
Response.Write "</BODY>"
Response.Write "</HTML>"
' If you are looping through displaying
' more then one average then use the follo
' wing format
' add the same code as above except drop
' the
' strNum = RS("Average") and strNumFixed
' and formatnumber code
' Uncomment this code out
' WHILE NOT RS.EOF
' IF NOT IsNull(RS("Average") ) THEN
' Response.Write "<b>" & FormatNum
' ber(RS("Average"),1) & "</b>"
' ELSE
' Response.Write "no average"
' END IF
' RS.MoveNext
' WEND
'And thats about it works pretty simple
' and alot less code
%>

63
asp/FilesMaths/Scripting.Decoder for Microsoft Encoding.asp Normal file
View File

@ -0,0 +1,63 @@
<%
Class clsScripting_Decoder
' ----------------------------------------
'
Private mBytAsciiAry
Private mStrBase64
' ----------------------------------------
'
Private Sub Class_Initialize()
mStrBase64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
mBytAsciiAry = Array( _
&h00, &h00, &h00, &h01, &h01, &h01, &h02, &h02, &h02, &h03, &h03, &h03, &h04, &h04, &h04, &h05, &h05, &h05, _
&h06, &h06, &h06, &h07, &h07, &h07, &h08, &h08, &h08, &h57, &h6E, &h7B, &h00, &h00, &h00, &h0B, &h0B, &h0B, _
&h0C, &h0C, &h0C, &h00, &h00, &h00, &h0E, &h0E, &h0E, &h0F, &h0F, &h0F, &h10, &h10, &h10, &h11, &h11, &h11, _
&h12, &h12, &h12, &h13, &h13, &h13, &h14, &h14, &h14, &h15, &h15, &h15, &h16, &h16, &h16, &h17, &h17, &h17, _
&h18, &h18, &h18, &h19, &h19, &h19, &h1A, &h1A, &h1A, &h1B, &h1B, &h1B, &h1C, &h1C, &h1C, &h1D, &h1D, &h1D, _
&h1E, &h1E, &h1E, &h1F, &h1F, &h1F, &h2E, &h2D, &h32, &h47, &h75, &h30, &h7A, &h52, &h21, &h56, &h60, &h29, _
&h42, &h71, &h5B, &h6A, &h5E, &h38, &h2F, &h49, &h33, &h26, &h5C, &h3D, &h49, &h62, &h58, &h41, &h7D, &h3A, _
&h34, &h3E, &h35, &h32, &h36, &h65, &h5B, &h20, &h39, &h76, &h7C, &h5C, &h72, &h7A, &h56, &h43, &h7F, &h73, _
&h38, &h6B, &h66, &h39, &h63, &h4E, &h70, &h33, &h45, &h45, &h2B, &h6B, &h68, &h68, &h62, &h71, &h51, &h59, _
&h4F, &h66, &h78, &h09, &h76, &h5E, &h62, &h31, &h7D, &h44, &h64, &h4A, &h23, &h54, &h6D, &h75, &h43, &h71, _
&h00, &h00, &h00, &h7E, &h3A, &h60, &h00, &h00, &h00, &h5E, &h7E, &h53, &h40, &h00, &h40, &h77, &h45, &h42, _
&h4A, &h2C, &h27, &h61, &h2A, &h48, &h5D, &h74, &h72, &h22, &h27, &h75, &h4B, &h37, &h31, &h6F, &h44, &h37, _
&h4E, &h79, &h4D, &h3B, &h59, &h52, &h4C, &h2F, &h22, &h50, &h6F, &h54, &h67, &h26, &h6A, &h2A, &h72, &h47, _
&h7D, &h6A, &h64, &h74, &h39, &h2D, &h54, &h7B, &h20, &h2B, &h3F, &h7F, &h2D, &h38, &h2E, &h2C, &h77, &h4C, _
&h30, &h67, &h5D, &h6E, &h53, &h7E, &h6B, &h47, &h6C, &h66, &h34, &h6F, &h35, &h78, &h79, &h25, &h5D, &h74, _
&h21, &h30, &h43, &h64, &h23, &h26, &h4D, &h5A, &h76, &h52, &h5B, &h25, &h63, &h6C, &h24, &h3F, &h48, &h2B, _
&h7B, &h55, &h28, &h78, &h70, &h23, &h29, &h69, &h41, &h28, &h2E, &h34, &h73, &h4C, &h09, &h59, &h21, &h2A, _
&h33, &h24, &h44, &h7F, &h4E, &h3F, &h6D, &h50, &h77, &h55, &h09, &h3B, &h53, &h56, &h55, &h7C, &h73, &h69, _
&h3A, &h35, &h61, &h5F, &h61, &h63, &h65, &h4B, &h50, &h46, &h58, &h67, &h58, &h3B, &h51, &h31, &h57, &h49, _
&h69, &h22, &h4F, &h6C, &h6D, &h46, &h5A, &h4D, &h68, &h48, &h25, &h7C, &h27, &h28, &h36, &h5C, &h46, &h70, _
&h3D, &h4A, &h6E, &h24, &h32, &h7A, &h79, &h41, &h2F, &h37, &h3D, &h5F, &h60, &h5F, &h4B, &h51, &h4F, &h5A, _
&h20, &h42, &h2C, &h36, &h65, &h57, &h80, &h80, &h80, &h81, &h81, &h81, &h82, &h82, &h82, &h83, &h83, &h83, _
&h84, &h84, &h84, &h85, &h85, &h85, &h86, &h86, &h86, &h87, &h87, &h87, &h88, &h88, &h88, &h89, &h89, &h89, _
&h8A, &h8A, &h8A, &h8B, &h8B, &h8B, &h8C, &h8C, &h8C, &h8D, &h8D, &h8D, &h8E, &h8E, &h8E, &h8F, &h8F, &h8F, _
&h90, &h90, &h90, &h91, &h91, &h91, &h92, &h92, &h92, &h93, &h93, &h93, &h94, &h94, &h94, &h95, &h95, &h95, _
&h96, &h96, &h96, &h97, &h97, &h97, &h98, &h98, &h98, &h99, &h99, &h99, &h9A, &h9A, &h9A, &h9B, &h9B, &h9B, _
&h9C, &h9C, &h9C, &h9D, &h9D, &h9D, &h9E, &h9E, &h9E, &h9F, &h9F, &h9F, &hA0, &hA0, &hA0, &hA1, &hA1, &hA1, _
&hA2, &hA2, &hA2, &hA3, &hA3, &hA3, &hA4, &hA4, &hA4, &hA5, &hA5, &hA5, &hA6, &hA6, &hA6, &hA7, &hA7, &hA7, _
&hA8, &hA8, &hA8, &hA9, &hA9, &hA9, &hAA, &hAA, &hAA, &hAB, &hAB, &hAB, &hAC, &hAC, &hAC, &hAD, &hAD, &hAD, _
&hAE, &hAE, &hAE, &hAF, &hAF, &hAF, &hB0, &hB0, &hB0, &hB1, &hB1, &hB1, &hB2, &hB2, &hB2, &hB3, &hB3, &hB3, _
&hB4, &hB4, &hB4, &hB5, &hB5, &hB5, &hB6, &hB6, &hB6, &hB7, &hB7, &hB7, &hB8, &hB8, &hB8, &hB9, &hB9, &hB9, _
&hBA, &hBA, &hBA, &hBB, &hBB, &hBB, &hBC, &hBC, &hBC, &hBD, &hBD, &hBD, &hBE, &hBE, &hBE, &hBF, &hBF, &hBF, _
&hC0, &hC0, &hC0, &hC1, &hC1, &hC1, &hC2, &hC2, &hC2, &hC3, &hC3, &hC3, &hC4, &hC4, &hC4, &hC5, &hC5, &hC5, _
&hC6, &hC6, &hC6, &hC7, &hC7, &hC7, &hC8, &hC8, &hC8, &hC9, &hC9, &hC9, &hCA, &hCA, &hCA, &hCB, &hCB, &hCB, _
&hCC, &hCC, &hCC, &hCD, &hCD, &hCD, &hCE, &hCE, &hCE, &hCF, &hCF, &hCF, &hD0, &hD0, &hD0, &hD1, &hD1, &hD1, _
&hD2, &hD2, &hD2, &hD3, &hD3, &hD3, &hD4, &hD4, &hD4, &hD5, &hD5, &hD5, &hD6, &hD6, &hD6, &hD7, &hD7, &hD7, _
&hD8, &hD8, &hD8, &hD9, &hD9, &hD9, &hDA, &hDA, &hDA, &hDB, &hDB, &hDB, &hDC, &hDC, &hDC, &hDD, &hDD, &hDD, _
&hDE, &hDE, &hDE, &hDF, &hDF, &hDF, &hE0, &hE0, &hE0, &hE1, &hE1, &hE1, &hE2, &hE2, &hE2, &hE3, &hE3, &hE3, _
&hE4, &hE4, &hE4, &hE5, &hE5, &hE5, &hE6, &hE6, &hE6, &hE7, &hE7, &hE7, &hE8, &hE8, &hE8, &hE9, &hE9, &hE9, _
&hEA, &hEA, &hEA, &hEB, &hEB, &hEB, &hEC, &hEC, &hEC, &hED, &hED, &hED, &hEE, &hEE, &hEE, &hEF, &hEF, &hEF, _
&hF0, &hF0, &hF0, &hF1, &hF1, &hF1, &hF2, &hF2, &hF2, &hF3, &hF3, &hF3, &hF4, &hF4, &hF4, &hF5, &hF5, &hF5, _
&hF6, &hF6, &hF6, &hF7, &hF7, &hF7, &hF8, &hF8, &hF8, &hF9, &hF9, &hF9, &hFA, &hFA, &hFA, &hFB, &hFB, &hFB, _
&hFC, &hFC, &hFC, &hFD, &hFD, &hFD, &hFE, &hFE, &hFE, &hFF, &hFF, &hFF _
)
End Sub
' --------------------------------------
'
Public Function DecodeScriptFile(ByRef pStrExt, ByVal pStrScript, ByRef pLngTemp1, ByRef pStrTemp2)
Dim lStrEncodedScript
Dim lLngStart
Dim lLngEnd
Const lStrStartFlag = "#@

50
asp/FilesMaths/Search Function.asp Normal file
View File

@ -0,0 +1,50 @@
example usage:
Search all files of the entire web site For the exact phrase "request.cookies"
And delete them (also uses the kill statement).
<%
' declare variables
Dim a, b, i
' search the entire web site for the phrase "request.cookies"
a = Search( "request.cookies", Server.MapPath("/") )
' iterate the array of results
b = Split(a , vbCrLf)
For i = 0 To UBound(b) - 1
' delete each matching page
Kill b(i)
Next
%>
source code:
<%
Private Function Search(ByVal phrase, ByVal directory)
Dim objFSO, currentFolder, objFile, currentFile
Dim strSearch, fileContents, objFolder
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set currentFolder = objFSO.GetFolder(directory)
For Each objFile In currentFolder.Files
If LCase( objFile.Path ) = _
LCase( Server.MapPath( _
Request.ServerVariables("SCRIPT_NAME") ) ) Then
Else
Set currentFile = _
objFSO.OpenTextFile( objFile.Path, 1, False )
fileContents = LCase( currentFile.ReadAll() )
currentFile.Close
Set currentFile = Nothing
If InStr( fileContents, phrase ) Then
strSearch = strSearch & objFile.Path & vbCrLf
Else
strSearch = strSearch & ""
End If
End If
Next
For Each objFolder In currentFolder.SubFolders
strSearch = strSearch & Search( phrase, objFolder )
Next
Set currentFolder = Nothing
Set objFSO = Nothing
Search = CStr( strSearch )
End Function
%>

50
asp/FilesMaths/Search Function1.asp Normal file
View File

@ -0,0 +1,50 @@
example usage:
Search all files of the entire web site For the exact phrase "request.cookies"
And delete them (also uses the kill statement).
<%
' declare variables
Dim a, b, i
' search the entire web site for the phrase "request.cookies"
a = Search( "request.cookies", Server.MapPath("/") )
' iterate the array of results
b = Split(a , vbCrLf)
For i = 0 To UBound(b) - 1
' delete each matching page
Kill b(i)
Next
%>
source code:
<%
Private Function Search(ByVal phrase, ByVal directory)
Dim objFSO, currentFolder, objFile, currentFile
Dim strSearch, fileContents, objFolder
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set currentFolder = objFSO.GetFolder(directory)
For Each objFile In currentFolder.Files
If LCase( objFile.Path ) = _
LCase( Server.MapPath( _
Request.ServerVariables("SCRIPT_NAME") ) ) Then
Else
Set currentFile = _
objFSO.OpenTextFile( objFile.Path, 1, False )
fileContents = LCase( currentFile.ReadAll() )
currentFile.Close
Set currentFile = Nothing
If InStr( fileContents, phrase ) Then
strSearch = strSearch & objFile.Path & vbCrLf
Else
strSearch = strSearch & ""
End If
End If
Next
For Each objFolder In currentFolder.SubFolders
strSearch = strSearch & Search( phrase, objFolder )
Next
Set currentFolder = Nothing
Set objFSO = Nothing
Search = CStr( strSearch )
End Function
%>

35
asp/FilesMaths/SetAttr Statement.asp Normal file
View File

@ -0,0 +1,35 @@
example usage:
Makes the directory New Folder On the C drive's root hidden.
<% SetAttr "C:New Folder", 2 %>
Makes the directory New Folder On the server's root hidden.
<%
Const vbHidden = 2
SetAttr Server.MapPath("/New Folder"), vbHidden
%>
source code:
<%
Private Sub SetAttr(ByVal pathname, ByVal attributes)
Dim objFSO, objFile, objFolder, boolErr, strErrDesc
On Error Resume Next
Set objFSO = Server.CreateObject("scripting.filesystemobject")
If InStr( Right( pathname, 4 ), "." ) Then
' probably a file
Set objFile = objFSO.GetFile(pathname)
objFile.Attributes = attributes
Set objFile = Nothing
Else
' probably a directory or folder
Set objFolder = objFSO.GetFolder(pathname)
objFolder.Attributes = attributes
Set objFolder = Nothing
End If
If Err Then
boolErr = True
strErrDesc = Err.description
End If
Set objFSO = Nothing
On Error GoTo 0
If boolErr Then Err.Raise 5103, "SetAttr Statement", strErrDesc
End Sub
%>

40
asp/FilesMaths/StandardToMetric Function.asp Normal file
View File

@ -0,0 +1,40 @@
<%
Private Function StandardToMetric(ByVal StandardMeasure, _
ByVal Conversion, ByVal ExtensionType)
Dim tmp, multiplier, extension, ext
Select Case UCase( Conversion )
Case "IN-CM" : multiplier = 2.54 : _
extension = "centimeters" : ext = "cm"
Case "FT-CM" : multiplier = 30.48 : _
extension = "centimeters" : ext = "cm"
Case "IN-M" : multiplier = 0.00254 : _
extension = "meters" : ext = "m"
Case "YD-M" : multiplier = 0.914 : _
extension = "meters" : ext = "m"
Case "MI-KM" : multiplier = 1.609 : _
extension = "kilometers" : ext = "km"
Case "OZ-G" : multiplier = 28.35 : _
extension = "grams" : ext = "g"
Case "LBS-G" : multiplier = 453.59 : _
extension = "grams" : ext = "g"
Case "OZ-KG" : multiplier = 0.028 : _
extension = "kilograms" : ext = "kg"
Case "LBS-KG" : multiplier = 0.454 : _
extension = "kilograms" : ext = "kg"
Case "PT-L" : multiplier = 0.473 : _
extension = "liters" : ext = "L"
Case "QT-L" : multiplier = 0.946 : _
extension = "liters" : ext = "L"
Case "GAL-L" : multiplier = 3.785 : _
extension = "liters" : ext = "L"
End Select
tmp = FormatNumber(multiplier * StandardMeasure, 2)
Select Case CInt(ExtensionType)
Case 0 : tmp = Trim( tmp )
Case 1 : tmp = tmp & " " & ext
Case 2 : tmp = tmp & " " & extension
Case Else : tmp = Trim( tmp )
End Select
StandardToMetric = tmp
End Function
%>

19
asp/FilesMaths/Title Function.asp Normal file
View File

@ -0,0 +1,19 @@
example usage:
Writes the hard coded HTML title of the document "file.htm".
<% = Title(Server.MapPath("/file.htm")) %>
source code:
<%
Private Function Title(ByVal pathname)
Dim objFSO, objFile, a, tmp, firstCt, secondCt
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(pathname, 1, False)
a = objFile.ReadAll()
objFile.Close
Set objFile = Nothing
Set objFSO = Nothing
firstCt = InStr(UCase(a), "<TITLE>") + 7
secondCt = InStr(UCase(a), "</TITLE>")
tmp = Mid( a, firstCt, secondCt - firstCt )
Title = CStr( Trim( tmp ) )
End Function
%>

27
asp/FilesMaths/WriteLog Statement.asp Normal file
View File

@ -0,0 +1,27 @@
example usage:
<%
Dim strErrEvent
On Error Resume Next
... some code Or event that may fail due To an Error
If Err Then
' in the event of an error, write the page path,
' error number and error description to the log file...
strErrEvent = Request.ServerVariables("PATH_INFO") & vbTab & _
Err.number & vbTab & Err.description
WriteLog Server.MapPath("/website_errors.txt"), strErrEvent
End If
On Error GoTo 0
%>
source code:
<%
Private Sub WriteLog(ByVal pathname, ByVal logevent)
Dim objFSO, objFile
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(pathname, 8, True)
objFile.WriteLine Now() & vbTab & logevent
objFile.Close
Set objFile = Nothing
Set objFSO = Nothing
End Sub
%>

74
asp/Miscellaneous/Better Email and Domain Validation.asp Normal file
View File

@ -0,0 +1,74 @@
Function ValidateEmailAddress(sEmailAddr)
Dim sDomain 'as String
'Get domain portion of email address.
sDomain = Mid(sEmailAddr, Instr(1, sEmailAddr, "@") + 1)
'Create Object for Reg. Expressions matching to validate address.
'This script will first validate that the email address is of valid format
'It then validates the domain portion by doing a nslookup.
Set oRegExp = new RegExp
oRegExp.Pattern = "^\w+(\.\w+)*@\w+\.\w+(\.\w+)*$"
oRegExp.IgnoreCase = true
'Excute the pattern matching to return a collection.
Set colMatches = oRegExp.Execute(sEmailaddr)
'If colMatches = 1 then the email address is of valid format.
Response.write "colMatch = " & colMatches.count & "<BR>"
'Response.write "colMatch = " & colMatches(0). & "<BR>"
If colMatches.Count = 1 then
'If the email address is valid format then we don't
'want to run this and create any more delay or cpu cycles
'than are needed.
If DomainLookup(sDomain) then ValidateEmailAddress = true
Else
'It wasn't Valid
ValidateEmailAddress = false
End If
Set colMatches = Nothing
Set objRegExpr = Nothing
End Function
Function DomainLookup(sDomain)
Dim sReadData 'As String
Dim fIpIsNextLine 'Ad boolean
'Create Shell Object
set oShell = Server.CreateObject("Wscript.Shell")
'Run NSLookup via Command Prompt
'Dump Results into a temp text file
'The text file is unique and stored in the directory specified
'using the %Tmp% environment variable. This file will be deleted
'after validation.
'If you can not validate against the local name server for some reason you can specify a
'Name server by uncommenting this line and replacing the name of the server.
'oShell.Run "%ComSpec% /c nslookup " & sDomain & " WEBTERMINATOR1.Crystaltech.com > %Tmp%" & _
' Session.SessionID & sDomain & ".txt", 0, True
oShell.Run "%ComSpec% /c nslookup " & sDomain & " > %Tmp%" & _
Session.SessionID & sDomain & ".txt", 0, True
'Open the temp Text File and Read out the Data
Set FSO = Server.CreateObject("Scripting.FileSystemObject")
Set oText = Fso.OpenTextFile("%Tmp%" & Session.SessionID & sDomain & ".txt")
Do While Not oText.AtEndOfStream
'Read In the Text Dump
sReadData = Trim(oText.Readline)
'If the domain name was found in the previous line read then this should be the IP.
If fIpIsNextLine then DomainLookup = True
'If the domain name was found in the Read line then the tell it the
'next line is the Ip. If an IP address was not found then it should not
'return the domain we are looking for in the txt file.
Response.write sReadData & "<BR>"
If Instr(1, sReadData, sDomain) then fIpIsNextLine = true
Loop
'Close it
oText.Close
'Delete It
FSO.DeleteFile "%Tmp%" & Session.SessionID & sDomain & ".txt"
Set FSO = Nothing
End Function

58
asp/Miscellaneous/Breakup sentences longer than x Characters.asp Normal file
View File

@ -0,0 +1,58 @@
function mBreakupWordsLongerThanMax(byval vstrSentence, byval vlngMaxWordLength)
Dim lngIndex,strNextWord,strOutput
Dim arrWords
lngIndex=0
'get words into array
arrWords=split(vstrSentence," ")
'go through words
strOutput=""
'Response.Write "UBound(arrWords)" & UBo
'
' und(arrWords)
For lngIndex = 0 To UBound(arrWords)
strNextWord=arrWords(lngIndex)
'check if > max
if len(strNextWord > vlngMaxWordLength) Then
'> max
strOutput=strOutput & mSplitWord(strNextWord,vlngMaxWordLength)
Else
'<= max
strOutput=strOutput & strNextWord
End if
Next
'set return
if right(strOutput,1)=" " Then
'get rid of rightmost space
mBreakupWordsLongerThanMax=mid(strOutput,1,len(strOutput)-1)
Else
'return all
mBreakupWordsLongerThanMax=strOutput
End if
End function
function mSplitWord(byval vstrWord, _
byval vlngLength)
'*********************************
'purpose:split word
'inputs: vstrWord--word to split
' vlngLength--length to split at
'*********************************
Dim strOutput,lngIndex
strOutput=""
For lngIndex = 1 To len(vstrWord) step vlngLength
strOutput=strOutput & _
" " & mid(vstrWord,lngIndex,vlngLength)
Next
'set return
mSplitWord= mid(strOutput,2) & " "
End function

24
asp/Miscellaneous/Compare List.asp Normal file
View File

@ -0,0 +1,24 @@
Function CompareList(Arg As Variant, ParamArray Values() As Variant) As Boolean
Dim index As Long
If IsObject(Arg) Then
' comparison between objects
For index = 0 To UBound(Values)
If Not IsObject(Values(index)) Then
' argument isn't an object, skip it
ElseIf Arg Is Values(index) Then
CompareList = index
Exit Function
End If
Next
Else
' comparison between non-object values
For index = 0 To UBound(Values)
If IsObject(Values(index)) Then
' argument is an object, skip it
ElseIf Arg = Values(index) Then
CompareList = index
Exit Function
End If
Next
End If
End Function

170
asp/Miscellaneous/DB Viewer.asp Normal file
View File

@ -0,0 +1,170 @@
<%@ Language=VBScript %>
<HTML>
<HEAD>
<STYLE TYPE="text/css">
Body {font-size:10;font-family:Verdana, Arial;color:Black;text-decoration:none;}
TD,SELECT,OPTION,TextArea ,Input, {font-size:9;font-family:Verdana, Arial;color:Black;text-decoration:none;}
TH {font-size:8pt;font-family:Verdana, Arial;color:Black;}
</STYLE>
</HEAD>
<BODY>
<%
if Request("Action") = "ShowdB" then
Set objConn = Server.CreateObject("ADODB.Connection")
objConn.Open "Provider=SQLOLEDB; Data Source=martini; Initial Catalog=" & Request("dB") & "; User ID=UserID; Password=Password"
strSQL = "SELECT name,length,xtype,isnullable FROM syscolumns WHERE id=" & Request("id") & " ORDER BY colorder ASC"
Response.Write "<form action='db.asp' method='post'>" & vbCrLf
Set objRS = objConn.Execute(strSQL)
Response.Write "<TABLE BORDER=1 CELLSPACING=1><TR>" & vbCrLf
For Each fld in objRS.Fields
Response.Write "<TH>" & fld.Name & "</TH>" & vbCrLf
Next
Response.Write "</TR><TR>" & vbCrLf
if objRS.EOF then
Response.Write "test"
else
i=0
Do While not objRS.EOF
Response.Write "<TR>" & vbCrLf
For Each fld in objRS.Fields
if fld.Name = "xtype" then
xSQL = "SELECT name FROM systypes WHERE xtype = '" & fld.value & "'"
Set xRS = Server.CreateObject("ADODB.Recordset")
xRS.Open xSQL, objConn
Response.Write "<TD>" & xRS("name") & "</TD>" & vbCrLf
xRS.Close
Set xRS = Nothing
elseif fld.Name = "name" then
Response.Write "<TD><input type='checkbox' name='field" & i & "' value='" & fld.value & "'>" & fld.Value & "</TD>" & vbCrLf
else
Response.Write "<TD>" & fld.Value & "</TD>" & vbCrLf
end if
Next
Response.Write "</TR>" & vbCrLf
i=i+1
objRS.MoveNext
Loop
end if
Response.Write "</TABLE><table border=1>"
Response.Write "<tr><td><input type='radio' name='Type' value='Insert' checked>Insert Statement</td></tr>" & vbCrLf
Response.Write "<tr><td><input type='radio' name='Type' value='Select'>Select Statement</td></tr>" & vbCrLf
Response.Write "<tr><td><input type='submit' value='Make Statement'></td></tr>" & vbCrLf
Response.Write "</table>"
Response.Write "<input type='hidden' name='Action' value='Statement'>" & vbCrLf
Response.Write "<input type='hidden' name='Table' value='" & Request("Table") & "'>" & vbCrLf
Response.Write "</form>"
sSQL = "SELECT * FROM " & Trim(Request("Table"))
'Response.Write sSQL & "<P>"
Set sConn = Server.CreateObject("ADODB.Connection")
sConn.Open "Provider=SQLOLEDB; Data Source=martini; Initial Catalog=" & Request("dB") & "; User ID=UserName; Password=Password"
Set sRS = Server.CreateObject("ADODB.Recordset")
sRS.Open sSQL, sConn
Response.Write "<P><b>Copy & Paste:</b></P>"
sFldString = "<textarea cols=50 rows=15 wrap=hard id=textarea1 name=textarea1>"
intCount = sRS.Fields.Count - 1
for i=0 to intCount
sFldString = sFldString & sRS(i).Name & ","
next
sFldString = Left(sFldString,Len(sFldString)-1) & "</textarea>"
Set RS = Nothing
Set Conn = Nothing
Response.Write "<P>" & sFldString
objConn.Close
Set objConn = Nothing
elseif Request("Action") = "Statement" then
if Request("Type") = "Select" then
sSQL = "SELECT "
for each item in Request.Form
if instr(1,Left(item,5),"field") then
if i=0 then
sFields = Request.Form(item)
i=1
else
sFields = sFields & "," & Request.Form(item)
end if
end if
next
sSQL = sSQL & sFields & " FROM " & Request("Table")
Response.Write "<textarea cols=60 rows=10>" & sSQL & "</textarea>"
else
sSQL = "INSERT INTO " & Request("Table") & "("
for each item in Request.Form
if instr(1,Left(item,5),"field") then
if i=0 then
sFields = Request.Form(item)
sValues = "'"" & Request(""" & Request.Form(item) & """) & ""'"
i=1
else
sFields = sFields & "," & Request.Form(item)
sValues = sValues & ",'"" & Request(""" & Request.Form(item) & """) & ""'"
end if
end if
next
sSQL = sSQL & sFields & ") VALUES (" & sValues & ")"""
Response.Write "<textarea cols=60 rows=10>" & sSQL & "</textarea>"
end if
elseif Request("Action") = "ShowT" then
Set objConn = Server.CreateObject("ADODB.Connection")
objConn.Open "Provider=SQLOLEDB; Data Source=martini; Initial Catalog=" & Request("dB") & "; User ID=UserName; Password=Password"
Dim strSQL
strSQL = "SELECT id,name,crdate AS Create_Date FROM sysobjects WHERE xtype='U' ORDER BY name ASC"
'Response.Write strSQL
Dim objRS
Set objRS = objConn.Execute(strSQL)
Response.Write "<TABLE BORDER=1 CELLSPACING=1><TR>" & vbCrLf
Dim fld
For Each fld in objRS.Fields
if fld.Name = "id" then
'do nothing
else
Response.Write "<TH>" & fld.Name & "</TH>" & vbCrLf
end if
Next
Response.Write "</TR><TR>" & vbCrLf
Do While not objRS.EOF
Response.Write "<TR>" & vbCrLf
For Each fld in objRS.Fields
if fld.Name = "name" then
Response.Write "<TD><a href='db.asp?Action=ShowdB&id=" & objRS("id") & "&dB=" & Request("dB") & "&Table=" & fld.Value & "'>" & fld.Value & "</a></TD>" & vbCrLf
elseif fld.Name = "id" then
'do nothing
else
Response.Write "<TD>" & fld.Value & "</TD>" & vbCrLf
end if
Next
Response.Write "</TR>" & vbCrLf
objRS.MoveNext
Loop
Response.Write "</TABLE>"
objRS.Close
Set objRS = Nothing
objConn.Close
Set objConn = Nothing
else
SQL = "SELECT name FROM sysdatabases ORDER BY name ASC"
Set dConn = Server.CreateObject("ADODB.Connection")
dConn.Open "Provider=SQLOLEDB; Data Source=martini; Initial Catalog=Master; User ID=UserName; Password=Password"
Set dRS = Server.CreateObject("ADODB.Recordset")
dRS.Open SQL , dConn
Response.Write "<table border=0>" & vbCrLf
While Not dRS.EOF
Response.Write "<Tr><td><a href='db.asp?Action=ShowT&dB=" & dRS("name") & "'>" & dRS("name") & "</a></td></tr>" & vbCrLf
dRS.MoveNext
Wend
Response.Write "</table>" & vbCrLf
dRS.Close
Set dRS = Nothing
end if
%>
</BODY>
</HTML>

29
asp/Miscellaneous/Detects if user has Flash.asp Normal file
View File

@ -0,0 +1,29 @@
<HTML>
<HEAD>
<TITLE>Document</TITLE>
</HEAD>
<BODY BGCOLOR=#000000 Text=FFFFFF LINK=FFFFFF>
<SCRIPT LANGUAGE="JavaScript">
<!--
var useFlash = navigator.mimeTypes &&
navigator.mimeTypes["application/x-shockwave-flash"] &&
navigator.mimeTypes["application/x-shockwave-flash"].enabledPlugin;
//-->
</SCRIPT>
<SCRIPT LANGUAGE="VBScript">
<!--
On Error Resume Next
useFlash = Not IsNull(CreateObject("ShockwaveFlash.ShockwaveFlash"))
-->
</SCRIPT>
<SCRIPT LANGUAGE="JavaScript">
<!--
If ( useFlash ) {
window.location = "pagewithflash.htm";
} Else {
window.location = "otherpage.htm";
}
//-->
</SCRIPT>
</BODY>
</HTML>

80
asp/Miscellaneous/Disk Space Usage.asp Normal file
View File

@ -0,0 +1,80 @@
<HTML>
<HEAD>
<TITLE>New Page 1</TITLE>
</HEAD>
<BODY>
<P><%<BR>
'Capture the name of the page as well as
' directory structure <BR>
script_name=Request.ServerVariables("script_name")<BR>
<BR>
'Split the directory tree into an arry b
' y /<BR>
split_name=Split(script_name,"/")<BR>
<BR>
' Sets the number of directory levels do
' wn<BR>
num_directory=UBound(split_name)-1<BR>
<BR>
%><BR>
<HTML><BR>
<TITLE>CodeAve.com(Directory Size)</TITLE><BR>
<BODY bgcolor="#FFFFFF"><BR>
<BR>
<TABLE align="center"><BR>
<TR><BR>
<TD width=150><BR>
<B>Directory</B><BR>
</TD><BR>
<TD width=150><BR>
<B>Megabytes</B><BR>
</TD><BR>
<TD width=150><BR>
<B>Kilobytes</B><BR>
</TD><BR>
<TD width=150><BR>
<B>Bytes</B><BR>
</TD><BR>
</TR><BR>
<%<BR>
' Create a file system object to read al
' l the directories<BR>
' beneath the current directory split_na
' me(num_directory)<BR>
' You can hard code the directory name i
' f you like<BR>
Set directory=Server.CreateObject("scripting.filesystemobject")<BR>
Set allfiles=directory.getfolder(Server.MapPath("../"& split_name(num_directory)& "/"))<BR>
<BR>
' Lists all the files found in the direc
' tory<BR>
For Each directory In allFiles.subfolders<BR>
' Removes certain MSFrontPage was direct
' ories <BR>
If Right(directory.Name,3) <> "cnf" Then <BR>
'Adds the folder sizes up for a total<
' ;BR>
total_size=total_size + directory.size %><BR>
<BR>
<TR><BR>
<TD width=150><BR>
<%= directory.name %><BR>
</TD><BR>
<TD width=150><%= FormatNumber((directory.size/1024/1024),2) %></TD><BR>
<TD width=150><%= FormatNumber((directory.size/1024),0) %></TD> <BR>
<TD width=150><%= FormatNumber(directory.size,0) %></TD> <BR>
</TR><BR>
<% End If 'end check For FrontPage directories <BR>
Next 'end of the For next Loop %><BR>
<TR><BR>
<TD width=150><B>Total</B></TD><BR>
<TD width=150><%= FormatNumber((total_size/1024/1024),2) %></TD><BR>
<TD width=150><%= FormatNumber((total_size/1024),0) %></TD> <BR>
<TD width=150><%= FormatNumber(total_size,0) %></TD> <BR>
</TR><BR>
</TABLE><BR>
<BR>
</BODY><BR>
</HTML></P>
</BODY>
</HTML>

165
asp/Miscellaneous/Display States according to Country selection....asp Normal file
View File

@ -0,0 +1,165 @@
Display States according to Country selection...
------we should have two tables in sql-------
table: tblcountry
create table tblcountry
(
countryid varchar(20) primary key,
country varchar(20)
)
insert into tblcountry values('1','Canada')
insert into tblcountry values('2','USA')
insert into tblcountry values('3','Nepal')
table: tblState
create table tblstate
(
stateid varchar(20) primary key,
state varchar(20),
countryid varchar(20) foreign key references tblcountry(countryid)
)
insert into tblstate values('1','Alaska','2')
insert into tblstate values('2','Puerto Rico','2')
insert into tblstate values('3','Saint Thomas','2')
--------------run above codes on sql-------------
------------------------------------------------------->
<!-------real coding goes from here-------------------->
<!--#include file="adovbs.inc"-->
<%
ConnString="Provider=SQLOLEDB.1;Persist Security Info=False;"
ConnString=ConnString & "User ID=sa;Initial Catalog=master;"
ConnString=ConnString & "Data Source=computername"
'give your computer name instead of computername
'on "Data Source=computername" on above string
Set Conn=server.createobject("ADODB.Connection")
Conn.open ConnString
Set rs=Server.CreateObject("ADODB.RECORDSET")
rs.Open "select * from tblstate",Conn,3
Response.write "<script language=javascript>"& vbcrlf
Response.write "var i=0;" & vbcrlf
Response.write "stateIDList=new Array();" & vbcrlf
Response.write "statelists=new Array();" & vbcrlf
for i=0 to rs.RecordCount-1
Response.write "stateIDList["&i&"]='" & rs("countryid") & "';" & vbcrlf
Response.write "statelists["&i&"]='" & rs("state") & "';" & vbcrlf
rs.MoveNext
Next
rs.Close
Response.write vbcrlf & "</script>"
strSQL="select * from tblcountry order by country"
rs.Open strSQL,Conn
StrCountry=rs("countryid")
Set rsstate=server.createobject("ADODB.RECORDSET")
rsstate.CursorLocation=adUseClient
strSQL="select * from tblstate where countryid='" & StrCountry & "'"
rsstate.Open strSQL,Conn
%>
<html>
<body>
<form name=frm>
<tr height=25>
<td width=90 class=dblue>
<font face="Verdana, Arial, Helvetica" size="1" color="darkblue">
Country
</font>
</td>
<td width="180">
<font face=verdana,arial size=1.8>
<select name=cmbcountry onchange="javascript:Loadstate()">
<Option value="">---------- Select Country --------</Option>
<% For i=1 to rs.RecordCount %>
<Option value="<%=rs.Fields("countryid")%>"
<%if cint(rs("countryid"))=cint(StrCountry) then%>Selected<%End if%>>
<%=rs.Fields("country")%>
</Option>
<%rs.MoveNext
Next
rs.Close
%>
</select>
</font>
</td>
<td width=90 class=dblue>
<font face="Verdana, Arial, Helvetica" size="1" color="darkblue">
State/Province</font>
</td>
<td class=dblue width="200">
<select name="cmbstate" onchange="javascript:BlankState()">
<%if rsstate.RecordCount<>0 then%>
<%Do while not rsstate.EOF%>
<option value="<%=rsstate("stateid")%>"><%=rsstate("state")%></option>
<%rsstate.movenext
loop
else
%>
<option value="">------- County/State N/A -------</option>
<%end if%>
</select>
<%
rsstate.close
Set RsState=nothing
Conn.close
Set Conn=nothing
%>
</td>
</tr>
</form>
</body>
</html>
<Script language=javascript>
var k=100;
var m;
function clear_dropdowns()
{
document.frm.cmbstate.options[0] = new Option('---------------','')
document.frm.cmbstate.selectedIndex=0
}
function Loadstate()
{
clear_dropdowns();
StatesValue=new Array();
for (var i=k;0<=i;i--)
document.frm.cmbstate.options[i]=null;
m=0;
for(j=0;j<stateIDList.length;j++)
{
if(document.frm.cmbcountry
[document.frm.cmbcountry.selectedIndex].value==stateIDList[j])
{
StatesValue[m]=statelists[j];
m++;
}
}
if(m==0)
document.frm.cmbstate.options
[m]=new Option('------- County/State N/A -------','');
else
{
for(k=0;k<StatesValue.length;k++)
document.frm.cmbstate.options
[k]=new Option(StatesValue[k],StatesValue[k]);
document.frm.cmbstate.options[k]=new Option(' ',' ');
}
}
function BlankState()
{
if(document.frm.cmbstate.value==" ")
document.frm.cmbstate.selectedIndex=0;
}
</Script>

81
asp/Miscellaneous/Display a list of image files for viewing.asp Normal file
View File

@ -0,0 +1,81 @@
<%@LANGUAGE="VBSCRIPT"%>
<%
Dim oFSO
Dim oFolder
Dim oFolders
Dim oFile
Dim strPhysicalPath
'Initialize counter for file counting
intCount = 0
'Get a reference to the scripting library
Set oFSO = Server.CreateObject("Scripting.FileSystemObject")
'Set the path to the images
strPhysicalPath = Server.MapPath("/Images/Product")
'Set a reference to the folder with the images
Set oFolder = oFSO.GetFolder(strPhysicalPath)
'Create a files collections
Set oFolders = oFolder.Files
%>
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=windows-1252">
<title>Display image filenames and hyperlink to the images</title>
<link rel="stylesheet" type="text/css" href="Main.css">
</head>
<body topmargin="0" leftmargin="0" >
<table border="1" width="502" cellspacing="0" cellpadding="0" height="1">
<%
'Begin enumerating through the files
For Each oFile in oFolders
Response.Write "<tr><td width='50%' colspan='2'><font size='2'><a href=Images\Product\" & oFile.Name & " class='screenlink'>" & _
oFile.Name & "</font></a></td></tr>"
Next
%>
</table>
<%
'Destory the objects and clean up
Set oFSO = Nothing
Set oFolder = Nothing
Set oFolders = Nothing
Set oFile = Nothing
%>
******** This is the style sheet - save this as Main.css in the save directory as the page **************
.screenlink:A {
color: blue;
text-decoration: none;
}
.screenlink:A:visited {
color: blue;
text-decoration: none;
}
.screenlink:A:active {
color: blue;
text-decoration: none;
}
.screenlink:A:hover {
color: red;
text-decoration: underline;
font-weight: none;
}

Some files were not shown because too many files have changed in this diff Show More