<% ' Sub MakePageForm() ' Sub selectSQLType() ' Sub buildPage(fileName,strSQL) ' Sub writePage(strFileName,str) ' Sub PK_FKTable() ' Sub clearQueries() ' Function makeQueryOptionBox(strSQL,strAlias) ' Sub saveQuery(strSQL) ' Function createTableStatement() ' Sub createTable() ' Sub reset() ' Sub CompactDB(dbpath) ' Sub makeSQLStatement(strTableName,strCreate) ' Sub makeUpdate(strHeadings) ' Sub makeInsert(strHeadings) ' Sub makeSelect(strHeadings) ' Sub findFolder() ' Function recursive(strPath,blnSearchSubFolders) ' Sub logIn() ' Sub tableDropDown() ' Sub Connect() ' Sub runQuery(strSQL) ' Function autoNumber(filespec,count) ' Sub tableInfo() ' Sub tabledetails(strTable) ' Function FindHeadings(filespec,strThisTable) ' Function autoNumber(filespec,count) Sub MakePageForm() %>

" method=POST> Name of New Page: Number of Records per Page: ">

<% End Sub Sub selectSQLType() %> " method="POST">
<% tableDropDown() %>     <% End Sub Sub buildPage(fileName,strSQL) Dim str,x,pagesize pagesize = request("pagesize") If pagesize = "" Then pagesize = 10 End If strSQL = replace(strSQL,vbCrLf,"") str = chr(60) & chr(37) & VbCrLf str = str & "Option Explicit" & VbCrLf & VbCrLf str = str & " If adCmdText = """" Then" & VbCrLf str = str & " Const adOpenStatic = 3" & VbCrLf str = str & " Const adCmdText = &H0001" & VbCrLf str = str & " End If" & VbCrLf & VbCrLf str = str & " Dim objConn, objRS, strSQL, pagesize, pageno" & VbCrLf str = str & " Dim intRecordCnt, intpages, intpage, x, intRecord" & VbCrLf & VbCrLf str = str & " Set objConn = Server.CreateObject(""ADODB.Connection"")" & VbCrLf str = str & " objConn.ConnectionString = ""Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & request("choosetable") & """" & VbCrLf str = str & " strSQL=""" & strSQL & """"& VbCrLf str = str & " pageno = Request.QueryString(""pageno"")" & VbCrLf & VbCrLf str = str & " pagesize = " & pagesize & VbCrLf & VbCrLf str = str & " If pageno = """" then" & VbCrLf str = str & " pageno = 1 " & VbCrLf str = str & " End if" & VbCrLf & VbCrLf & VbCrLf str = str & " Set objRS = server.createobject(""ADODB.Recordset"")" & VbCrLf str = str & " objConn.open" & VbCrLf str = str & " objRS.Open strSQL,objConn ,adOpenStatic , adCmdText" & VbCrLf str = str & " objRS.PageSize = pagesize" & VbCrLf str = str & " intRecordCnt = objRS.recordcount" & VbCrLf str = str & " intpages = objRS.pagecount" & VbCrLf str = str & " objRS.AbsolutePage = pageno" & VbCrLf & VbCrLf str = str & " If objRS.eof Then" & VbCrLf str = str & " response.write(""No Matching records Database is empty"")" & VbCrLf str = str & " objRS.close" & VbCrLf str = str & " Set objRS = nothing" & VbCrLf str = str & " objConn.close" & VbCrLf str = str & " Set objConn = nothing" & VbCrLf str = str & " Else" & VbCrLf & VbCrLf str = str & " response.write("""") & VbCrLf" & VbCrLf str = str & " response.write(""ASPAlliance.com/mbrink1111/"") & VbCrLf" & VbCrLf str = str & " response.write(""

This is page "" & pageno & "" of "") & VbCrLf" & VbCrLf str = str & " response.write(intpages & "" pages - "" & intRecordCnt & "" Total Records, "") & VbCrLf" & VbCrLf str = str & " response.write(pagesize & "" records per page.

"")" & VbCrLf str = str & " response.write(""

Click to select page:   "") & VbCrLf" & VbCrLf str = str & " For intPage = 1 to intpages" & VbCrLf& VbCrLf str = str & " If intPage = intpages And CInt(intPage) = CInt(pageno) Then" & VbCrLf str = str & " response.write(""  "" & CInt(intPage) & """") & VbCrLf" & VbCrLf str = str & " ElseIf intPage = intpages Then" & VbCrLf str = str & " response.write(""""&intPage&"""") & VbCrLf" & VbCrLf str = str & " ElseIf CInt(intPage) = CInt(pageno) Then" & VbCrLf str = str & " response.write(""  "" & intPage & ""  | "") & VbCrLf" & VbCrLf str = str & " Else" & VbCrLf str = str & " response.write(""""&intPage&"" | "") & VbCrLf" & VbCrLf str = str & " End If" & VbCrLf & VbCrLf str = str & " Next" & VbCrLf & VbCrLf str = str & " response.write(""

"")" & VbCrLf str = str & " response.write("""") & VbCrLf" & VbCrLf & VbCrLf str = str & " For each x in objRS.Fields" & VbCrLf & VbCrLf str = str & " response.write("""") & VbCrLf" & VbCrLf & VbCrLf str = str & " Next" & VbCrLf & VbCrLf str = str & " response.write("""") & VbCrLf" & VbCrLf & VbCrLf str = str & " For intRecord = 1 to objRS.PageSize " & VbCrLf & VbCrLf str = str & " Response.write("""") & VbCrLf" & VbCrLf str = str & " for each x in objRS.Fields" & VbCrLf str = str & " response.write("""") & VbCrLf" & VbCrLf str = str & " Next" & VbCrLf str = str & " Response.write("""") & VbCrLf" & VbCrLf str = str & " objRS.MoveNext" & VbCrLf str = str & " If objRS.EOF then exit for " & VbCrLf & VbCrLf str = str & " Next" & VbCrLf & VbCrLf str = str & " Response.write(""
"" & x.name & ""
"" & x.value & ""

"")" & VbCrLf & VbCrLf str = str & " If CInt(pageno)> 1 Then" & VbCrLf str = str & " response.write(""<< Previous"") & VbCrLf" & VbCrLf str = str & " End If" & VbCrLf & VbCrLf str = str & " response.write(""  |  "") & VbCrLf" & VbCrLf & VbCrLf str = str & " If CInt(intpages) > CInt(pageno) Then" & VbCrLf str = str & " response.write(""Next >>

"") & VbCrLf" & VbCrLf str = str & " End If" & VbCrLf & VbCrLf str = str & " objRS.Close" & VbCrLf str = str & " set objRS = Nothing" & VbCrLf str = str & " objConn.Close" & VbCrLf str = str & " Set objConn = nothing" & VbCrLf & VbCrLf str = str & "End If" & VbCrLf & VbCrLf str = str & chr(37) & chr(62) str = str & "

BuildAccess Author: Michael Brinkley - mbrink1111@yahoo.com

" & VbCrLf str = str & " " Call writePage(fileName,str) End Sub Sub writePage(strFileName,str) Const ForReading = 1, ForWriting = 2, ForAppending = 8 Dim fso, f, strPath, newFile strPath = server.mappath(strFileName &".asp") Set fso = CreateObject("Scripting.FileSystemObject") If (fso.FileExists(strPath)) Then Response.write("

") Response.write("File already exists

") Set fso = nothing Exit Sub Else Set newFile = fso.CreateTextFile(strPath, True) Set newFile = nothing End If Set f = fso.OpenTextFile(strPath, ForWriting, True) f.Write str f.Close Set f = nothing response.write("

Here is your new page: ") response.write(""&strFileName&"") response.write("

") Set fso = nothing End Sub SUB PK_FKTable() Dim strConn Dim conntemp Dim rsSchema Dim PKT Dim PKC Dim FKT Dim FKC Const adSchemaForeignKeys = 27 response.write("

" & vbCrLf) response.write("" & vbCrLf) response.write("" & vbCrLf) connect() objConn.open set rsSchema = objConn.OpenSchema(adSchemaForeignKeys) DO UNTIL rsSchema.eof PKT = rsSchema.fields("PK_TABLE_NAME") PKC = rsSchema.fields("PK_COLUMN_NAME") FKT = rsSchema.fields("FK_TABLE_NAME") FKC = rsSchema.fields("FK_COLUMN_NAME") If PKT <> "" Then response.write("" & vbCrLf) End If rsSchema.MoveNext LOOP response.write("
Primary KeyForeign Key
PK TablePK FieldFK TableFK Field
" &PKT & " " & PKC & " " & FKT& " " & FKC & "

" & vbCrLf) rsSchema.Close set rsSchema = nothing objConn.close set objConn = nothing END SUB Sub clearQueries() Dim argtxt Dim whatnot Dim counter Dim strBox For counter = 1 to request.cookies.count() argtxt = Request.Cookies.Item(counter) whatnot = Request.Cookies.Key(counter) If argtxt <> "" Then If instr(whatnot,"QOB")Then If whatnot <> "" Then Response.Cookies.Item(counter) = "" End If End If End if Next response.cookies("isgood") = "" End Sub Function makeQueryOptionBox(strSQL,strAlias) Dim argtxt Dim whatnot Dim counter Dim strBox ' put alias and sql statement in cookie. the "QOB" acts as filter to keep other cookies out response.cookies("QOB" & strAlias) = strSQL ' indicates if there are any saved querys response.cookies("isgood") = "True" strBox = "" & vbCrLf strBox = strBox & "  " & vbCrLf If instr(strBox,"") > 3 Then makeQueryOptionBox = strBox Else makeQueryOptionBox = "" End If End Function Sub saveQuery(strSQL) response.write("

Pick an alias for your query

" & vbCrLf) response.write("

" & vbCrLf) response.write("" & vbCrLf) response.write("" & vbCrLf) response.write(" Query Name: " & vbCrLf) response.write("" & vbCrLf) End Sub Function createTableStatement() Dim dbpath, noOfTables, strtablename, strSQLCreate, i, j, noOfColumns, strName,strType,strNull Dim strSize, strPK, strFieldNames, strDBname,strDBlink, strUnique, fileName strtablename = request(i & "tablename") noOfColumns = request(i & "columnnumber") strSQLCreate = "CREATE TABLE [" & strtablename & "]" & vbCrLf For j = 1 to noOfColumns strName = "[" & request("colum"&j) & "] " strType = request("dtype"&j) & " " If strType = "Text " Then strSize = request("size"&j) If Not IsNumeric(strSize) Then strSize = "" Else If strSize > 255 Then strSize = 255 End If strSize = "(" & strSize & ") " End If End If strNull = request("nullbox"&j) If strNull = "DISALLOW NULL" then strNull = " NOT NULL" Else strNull = "" End If strUnique = request("Unique"&j) If strUnique <> "" then strUnique = " UNIQUE" End If strPK = request("PK") If len(strPK) > 2 Then If CInt(right(strPK,instr(strPK,"PK"))) = j Then strPK = " PRIMARY KEY" Else strPK = "" End If End If If j = 1 Then strSQLCreate = strSQLCreate & " (" & strName & strType & strSize & strNull & strUnique & strPK&", " & vbCrLf ElseIf j = Cint(noOfColumns) Then strSQLCreate = strSQLCreate & " " & strName & strType & strSize & strNull & strUnique & strPK& ") " Else strSQLCreate = strSQLCreate & " " & strName & strType & strSize & strNull & strUnique & strPK&", "& vbCrLf End If strSize = "" Next createTableStatement = strSQLCreate End Function Sub createTable() %>

Name of new table:
Number of columns:


<% End Sub Sub reset() Dim strSQL,strDBPath strDBPath = server.mappath("master.mdb") strSQL = "DELETE FROM tables" On Error Resume Next Set objConn=Server.CreateObject("ADODB.Connection") objConn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDBPath Response.Write(strSQL & "
") objConn.Open objConn.Execute strSQL, intRecordsAffected If Err.description <> "" Then Response.write("
" & Err.description & "

") End If Response.Write("SQL Statement executed. " & intRecordsAffected & " record(s) affected.
" & vbcrlf) objConn.Close Set objConn = Nothing CompactDB( strDBPath) End Sub Sub CompactDB(dbpath) Dim fso, Engine, folderPath folderPath = left(dbpath,instrrev(dbpath,"\")) Set Engine = CreateObject("JRO.JetEngine") Engine.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbpath, _ "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & folderpath & "temp.mdb" Set fso = CreateObject("Scripting.FileSystemObject") fso.CopyFile folderpath & "temp.mdb",dbpath fso.DeleteFile(folderpath & "temp.mdb") Set fso = nothing Set Engine = nothing Response.write dbpath & " ... has been Compacted!!

" End Sub Sub makeSQLStatement(strTableName,strCreate) Dim strHeadings strHeadings = FindHeadings(strTableName,strTable) Select Case strCreate Case "Select" Call makeSelect(strHeadings) Case "Insert" Call makeInsert(strHeadings) Case "Update" Call makeUpdate(strHeadings) End Select End Sub Sub makeUpdate(strHeadings) Dim arrHeadings, intArrSize, intCounter, strAuto, strIsComma strHeadings = replace(strHeadings,strTable & ".","") strSQL = "" arrHeadings = split(strHeadings,",",-1,0) intArrSize = UBound(arrHeadings) strAuto = autoNumber(strTableName,strTable) If strAuto <> "" Then strHeadings = replace(strHeadings,strAuto,"") strHeadings = replace(strHeadings,"[],","") End If Dim i If strAuto = "" Then i = 0 Else i = 1 End If For intCounter = i to intArrSize If intCounter <> intArrSize Then strIsComma = "," Else strIsComma = "" End If If inStr(arrHeadings(intCounter),"STR") Then strSQL = strSQL & " " & arrHeadings(intCounter) & " = ''" & strIsComma & vbcrlf ElseIf inStr(arrHeadings(intCounter),"DAT") Then strSQL = strSQL & " " & arrHeadings(intCounter) & " = ##" & strIsComma & vbcrlf Else strSQL = strSQL & " " & arrHeadings(intCounter) & " = " & strIsComma & vbcrlf End If Next Dim strID, strType strID = arrHeadings(0) strType = strID strID = replace(strID,"STR","") strID = replace(strID,"DAT","") If inStr(strType,"STR") Then strType = "''" ElseIf inStr(strType,"DAT") Then strType = "##" Else strType = "" End If If strHeadings = " * " Then strSQL = " The table is empty" Else strSQL = replace(strSQL,"STR","") strSQL = replace(strSQL,"DAT","") strSQL = strSQL & "WHERE " & strID & " = " & strType strSQL = "UPDATE [" & strTable & "] SET" & vbcrlf & strSQL End If End Sub Sub makeInsert(strHeadings) Dim arrHeadings, intArrSize, intCounter, strAuto, strIsComma strHeadings = replace(strHeadings,strTable & ".","") strSQL = "" arrHeadings = split(strHeadings,",",-1,0) intArrSize = UBound(arrHeadings) strAuto = autoNumber(strTableName,strTable) If strAuto <> "" Then strHeadings = replace(strHeadings,strAuto,"") strHeadings = replace(strHeadings,"[],","") End If Dim i If strAuto = "" Then i = 0 Else i = 1 End If For intCounter = i to intArrSize If intCounter <> intArrSize Then strIsComma = "," Else strIsComma = "" End If If inStr(arrHeadings(intCounter),"STR") Then strSQL = strSQL & "''" & strIsComma ElseIf inStr(arrHeadings(intCounter),"DAT") Then strSQL = strSQL & "##" & strIsComma Else strSQL = strSQL & strIsComma End If Next strHeadings = replace(strHeadings,"STR","") strHeadings = replace(strHeadings,"DAT","") strSQL = "(" & strSQL & ")" strSQL = "INSERT INTO [" & strTable & "]" & vbcrlf & "(" & strHeadings & ") " & vbcrlf & "VALUES " & strSQL End Sub Sub makeSelect(strHeadings) Dim arrHeadings, intArrSize, intCounter strHeadings = replace(strHeadings,"STR","") strHeadings = replace(strHeadings,"DAT","") strSQL = "" arrHeadings = split(strHeadings,",",-1,0) intArrSize = UBound(arrHeadings) For intCounter = 0 to intArrSize - 1 strSQL = strSQL & arrHeadings(intCounter) & "," Next strSQL = strSQL & arrHeadings(intArrSize) & " " strSQL = strSQL & vbcrlf & "FROM [" & strTable & "]" strSQL = "SELECT " & strSQL End Sub Function FindHeadings(filespec,strThisTable) ' returns a comma delimited list of column headings for a table Dim objConn,objRS,strSQL,x,strHeadings Set objConn = Server.CreateObject("ADODB.Connection") objConn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & filespec set objRS = Server.CreateObject("ADODB.Recordset") objConn.open strSQL = "Select * from " & "[" & strThisTable & "]" objRS.open strSQL, objConn for each x in objRS.Fields If x.type = 202 Or x.type = 203 Then strheadings = strheadings & "[" & strThisTable & "." & x.name & "STR]," ElseIf x.type = 7 Then strheadings = strheadings & "[" & strThisTable & "." & x.name & "DAT]," Else strheadings = strheadings & "[" & strThisTable & "." & x.name & "]," End If next objRS.close Set objRS = nothing objConn.close Set objConn = nothing If strHeadings <> "" Or strHeadings <> " * " Then strHeadings = left(strHeadings,len(strHeadings) - 1) ' removes the trailing comma End If FindHeadings = strHeadings End Function Function autoNumber(filespec,count) Dim objCatalog,objColumn Set objConn = Server.CreateObject("ADODB.Connection") objConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & filespec Set objCatalog = Server.CreateObject("ADOX.Catalog") objCatalog.ActiveConnection = objConn If instr(objCatalog.Tables(count).Name,"MSys") = 0 Then For each objColumn in objCatalog.Tables(count).Columns If objColumn.Properties("AutoIncrement") = True then autoNumber = objColumn.Name End If Next End If Set objCatalog = Nothing objConn.Close Set objConn = Nothing End Function Sub tabledetails(strTable) Dim count On Error Resume Next count = 0 Call Connect() objConn.Open If Err Then response.write("DB Path or DB name not correct
") End If Err.Clear strSQL = "SELECT * FROM ["& strTable & "]" Set objRS = objConn.Execute(strSQL) If Err Then response.write("Table name is not correct") End If Response.Write("") Response.Write("" & vbCrLf) Response.Write("
"&strTable&"
") Response.Write("
" & vbCrLf) objRS.Close Set objRS = Nothing objConn.Close Set objConn = Nothing End Sub Sub tableInfo() Dim strSchema Dim objConnSchema Dim objSchema Dim strPrevTable Dim strThisTable Dim strSchemaDB Dim adSchemaColumns Dim strSubFolders Dim count If request("choosetable") <> "" Then ' Begin If 3, load table dropdown strDB = request("choosetable") adSchemaColumns = 4 strSchema = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDB & ";" strSchema = strSchema & "User Id=" & request("login") & ";Password="& request("pword") &";" set objConnSchema=server.createobject("adodb.connection") objConnSchema.open strSchema If len(Err.description) > 2 Then Response.write Err.description End If Set objSchema = objConnSchema.OpenSchema(adSchemaColumns) Response.write("
") DO UNTIL objSchema.EOF strPrevTable = strThisTable strThisTable = objSchema("Table_Name") IF Not mid(strThisTable,1,4) = "MSys" And strPrevTable <> strThisTable THEN AutoFlag = autoNumber(strDB,strThisTable) If count > 2 And count Mod 3 = 0 Then response.write("") End If count = count + 1 Response.write("") END IF objSchema.MoveNext LOOP objSchema.Close set objSchema=nothing objConnSchema.close set objConnSchema=nothing response.write("
") tabledetails(strThisTable) Response.write("
") End If Response.Flush If strError <> "" Then response.write(strError) End If End Sub Function autoNumber(filespec,count) Dim objCatalog,objColumn Set objConn = Server.CreateObject("ADODB.Connection") objConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & filespec Set objCatalog = Server.CreateObject("ADOX.Catalog") objCatalog.ActiveConnection = objConn If instr(objCatalog.Tables(count).Name,"MSys") = 0 Then For each objColumn in objCatalog.Tables(count).Columns If objColumn.Properties("AutoIncrement") = True then autoNumber = objColumn.Name End If Next End If Set objCatalog = Nothing objConn.Close Set objConn = Nothing End Function Sub runQuery(strSQL) On Error Resume Next If strSQL <> "" then strQueryType = LTrim(UCase(mid(strSQL,1,5))) Call Connect() Select Case strQueryType Case "SELEC" If request("button") <> "Table Info" Then Response.Write(strSQL & "
") objConn.Open If Err Then response.write("DB Path or DB name not correct
") End If Err.Clear Set objRS = objConn.Execute(strSQL) If Err.description <> "" Then Response.write("
" & Err.description & "

") End If If objRS.EOF and objRS.BOF then Response.Write("No records matched or table is empty") objRS.Close Set objRS = Nothing objconn.Close Set objconn=Nothing Else Response.Write("" & vbcrlf & _ "" & vbcrlf) ' Put Headings On The Table of Field Names For Each strFieldName in objRS.Fields Response.Write("" & vbcrlf) Next Response.Write("" & vbcrlf) ' Now lets grab all the records and close objects arrData=objRS.Getrows objRS.Close Set objRS=Nothing objConn.Close Set objConn=Nothing For intRowCounter= 0 to UBound(arrData,2) 'intnumrows Response.Write("" & vbcrlf) For intColCounter=0 to UBound(arrData,1) strFieldValue =arrdata(intcolcounter,introwcounter) If isNull(strFieldValue) then strFieldValue ="<NULL>" ElseIf trim(strFieldValue)="" then strFieldValue="<BLANK>" ElseIf VarType(strFieldValue) = "8209" Then strFieldValue = "*** Ole Object ***" End If Response.Write("" & vbcrlf) Next Response.Write("" & vbcrlf) Next Response.Write("
" & strFieldName.name & "
" & strFieldValue & "
" & vbcrlf) End if End If Case Else Response.Write(strSQL & "
") objConn.Open objConn.Execute strSQL, intRecordsAffected If Err.description <> "" Then Response.write("
" & Err.description & "

") End If Response.Write("SQL Statement executed. " & intRecordsAffected & " record(s) affected.
" & vbcrlf) objConn.Close Set objConn = Nothing End Select End if End Sub Sub Connect() Set objConn=Server.CreateObject("ADODB.Connection") objConn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & request("choosetable") & ";" objConn.ConnectionString = objConn.ConnectionString & "User Id=" & request("login") & ";Password="& request("pword") &";" End Sub Sub tableDropDown() On Error Resume Next Dim strSchema Dim objConnSchema Dim objSchema Dim strPrevTable Dim strThisTable Dim strSchemaDB Dim adSchemaColumns Dim strSubFolders If request("choosetable") <> "" Then ' Begin If 3, load table dropdown strDB = request("choosetable") adSchemaColumns = 4 strSchema = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDB & ";" strSchema = strSchema & "User Id=" & request("login") & ";Password="& request("pword") &";" set objConnSchema=server.createobject("adodb.connection") objConnSchema.open strSchema If len(Err.description) > 2 Then Response.write Err.description End If Set objSchema = objConnSchema.OpenSchema(adSchemaColumns) Response.write("" & vbCrLf) %> " & vbCrLf) objSchema.Close set objSchema=nothing objConnSchema.close set objConnSchema=nothing End If ' End If 3 Response.Flush If strError <> "" Then response.write(strError) End If End Sub Sub logIn() Response.write("") %>   <% response.write("  User Id:  " & vbCrLf) response.write("  Password:  " & vbCrLf) Response.write("
") End Sub Function recursive(strPath,blnSearchSubFolders) On Error Resume Next Dim objConn Dim strdbpath Dim objFileSysObject Dim objParentFolder Dim objSubFolder Dim objFolder Dim strBuildPath Dim objFiles Dim strTableName Dim regEx Dim retVal Dim strSQL strdbpath = server.mappath("master.mdb") Set objConn=Server.CreateObject("ADODB.Connection") objConn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strdbpath & ";" objConn.Open Set objFileSysObject = CreateObject("Scripting.FileSystemObject") Set objParentFolder = objFileSysObject.GetFolder(strPath) Set objSubFolder = objParentFolder.SubFolders For each objFiles in objParentFolder.Files If UCase(right(objFiles.Name,4)) = ".MDB" Then strBuildPath = strPath & "/" strBuildPath = strBuildPath & objParentFolder.name strTableName = objFiles.name & String(20 - Len(objFiles.name), "_") & FormatNumber(Int(objFiles.size) / 1000,0) & " K" If instr(objFiles.path,"_vti_cnf") = 0 Then strSQL = "insert into tables" & "(" & "db,dbname " strSQL = strSQL & ")" strSQL = strSQL & " values " strSQL = strSQL & "('" & objFiles.path & "','" & strTableName &" ')" objConn.Execute strSQL End If End If Next For Each objFolder in objSubFolder If blnSearchSubFolders = "true" Then strBuildPath = strPath & "/" strBuildPath = strBuildPath & objFolder.name Call recursive(strBuildPath,blnSearchSubFolders) End If Next objConn.Close Set objConn = Nothing End Function Sub findFolder() ' This Sub allows the user to navigate the file system and ' returns the folder to be searched by recursive.asp Dim strFolderPath ' string to hold path to folder Dim strSubFolder Dim objFileSysObject Dim objSysDriveObject Dim strDriveLetter Dim objSubFolder Dim objDrive Dim objFolder Dim objFile ' On Error Resume Next If request("selectdrive") = "Select Drive" Then strSubFolder = "" strFolderPath = request("drive") & ":/" else strSubFolder = request("folders") End If if strSubFolder & "x" <> "x" then strSubFolder = strSubFolder & "\" strFolderPath = strFolderPath & strSubFolder end if Set objFileSysObject = CreateObject("Scripting.FileSystemObject") response.write("
") If strSubFolder = "" Then response.write(" Start >> ") End If response.write("" & vbCrLf) response.write("" & vbCrLf) response.write("" & vbCrLf) If request("drive") = "" Then response.write("
" & vbCrLf) End If If strFolderPath <> "" Then Set objFolder = objFileSysObject.GetFolder(strFolderPath) Set objSubFolder = objFolder.subfolders If objSubFolder.count = 0 Then response.write(" No more folders - Arm Photon Torpedos!" & vbCrLf) Else response.write("" & vbCrLf) response.write("" & vbCrLf) End If response.write("" & vbCrLf) response.write("
" & vbCrLf) response.write("" & strFolderPath & "" & vbCrLf) %> Check to search Sub-Folders
<% End If End Sub %>