Snitz Forums 2000
Snitz Forums 2000
Home | Profile | Register | Active Topics | Members | Search | FAQ
Username:
 Password:
Save Password
Forgot your Password?

 All Forums
 Snitz Forums 2000 MOD-Group
 MOD Add-On Forum (W/Code)
 HTML Hard Disk Directory		  New Topic  Reply to Topic
 Printer Friendly
Author Previous Topic Topic Next Topic  

Carefree
Advanced Member

Philippines
4207 Posts
Posted - 08 February 2015 :  18:35:15  Show Profile  Reply with Quote
I needed a webpage directory, output to an html file (which could then be attached to Email, etc.), of multiple hard drives which were to be specified by the user. I wrote this utility to do the trick. It is restricted to files larger than 1 MB, because the files they need are all large. In order to use the tool, you would have to be hosting your own site, because you need access to IIS, etc.

Use is fairly simple. Run the file, specify the drives to include (if they aren't available, they won't be displayed). After the indexing is complete, the report will be created and the page will be redirected to the final report.

You need a sub-directory called "uploads" which has "users" (not IIS-based) write permissions. Then create virtual directories (each named using this pattern: "HPart" & the drive letter (e.g., HPartI, HPartJ) within your forum pointing to the allowed hard disks. All allowed hard disks must have "IUSR" read permissions.

Finally, you'll need a table titled "FileDir" which has the following fields:
  • TITLE varchar(255)
  • FSIZE Double
  • LABEL varchar(255)
  • CREATION varchar(255)

"hd.asp"

<html>
	<head>
		<title>Disk Directory</title>
	</head>
	<body>
<%
Set my_Conn = Server.CreateObject("ADODB.Connection")
my_Conn.Errors.Clear
Err.Clear
my_Conn.Open("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath("database.mdb"))
If Request("report") = "1" Then
	strPath=Server.Mappath("uploads")
	strFile="Directory.htm"
	strFilePath=strPath&"\"&strFile
	Const FSOForWriting = 2
	Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
	If not objFSO.FolderExists(strPath) Then
		Response.Write	"Folder: " & strPath & " does not exist.  Create folder and set write permissions to include "<i>users</i>"."
		Set objFSO = Nothing
		my_Conn.Close
		Set my_Conn = Nothing
		Response.End
	End If
	With objFSO.GetFolder(strPath)
		If .Attributes and ReadOnly Then
			Response.Write	"Folder: " & strPath & " cannot be written to.  Set write permissions to include "<i>users</i>"."
			Set objFSO = Nothing
			my_Conn.Close
			Set my_Conn = Nothing
			Response.End
		End If
	End With
	If objFSO.FileExists(strFilePath) Then 
		objFSO.DeleteFile(strFilePath)
	End If
	Set objTextStream = objFSO.OpenTextFile(strFilePath,FSOForWriting,true)
	objTextStream.Write	"<HTML>" & Chr(13)
	objTextStream.Write	Chr(9) & "<HEAD>" & Chr(13)
	objTextStream.Write	Chr(9) & Chr(9) & "<TITLE>Directory Report</TITLE>" & Chr(13)
	objTextStream.Write	Chr(9) & "</HEAD>" & Chr(13)
	objTextStream.Write	Chr(9) & "<BODY>" & Chr(13)
	objTextStream.Write	Chr(9) & Chr(9) & "<TABLE width=100% align=center style=border-collapse: collapse; bgcolor=transparent border=0 cellspacing=0 cellpadding=0>" & Chr(13)
	objTextStream.Write	Chr(9) & Chr(9) & Chr(9) & "<TR>" & Chr(13)
	objTextStream.Write	Chr(9) & Chr(9) & Chr(9) & Chr(9) & "<TD bgcolor=black>" & Chr(13)
	objTextStream.Write	Chr(9) & Chr(9) & Chr(9) & Chr(9) & Chr(9) & "<TABLE width=100% align=center style=border-collapse: collapse; border=1 cellspacing=1 cellpadding=4>" & Chr(13)
	Response.Write		"	<table border=""0"" bgColor=""transparent"" style=""border-collapse:collapse;"" width=""100%"" cellspacing=""0"" cellpadding=""0"" align=""center"">" & vbNewLine & _
		"		<tr>" & vbNewLine & _
		"			<td bgcolor=""black"">" & vbNewLine & _
		"		  	<table width=""100%"" border=""1"" style=""border-collapse:collapse;"" cellspacing=""1"" cellpadding=""4"">" & vbNewLine
	strSql = "SELECT * FROM FILEDIR ORDER BY TITLE ASC"
	Set rs=my_Conn.Execute(strSql)
	If not rs.EOF Then
		rs.MoveFirst
		intI = 0
		Do while not rs.EOF
			strTitle=rs("Title")
			strSize=rs("FSize")
			strLabel=rs("Label")
			strDate=rs("Creation")
			If intI = 0 Then CColor = "white" Else CColor = "lightblue"
			Response.Write	"				<tr bgcolor=""" & CColor & """>" & vbNewLine & _
				"					<td align=""left"">" & strTitle & "</td>" & _
				"					<td align=""right"">" & strSize &" "& strLabel & "</td>" & _
				"					<td align=""right"">" & strDate & " </td>" & _
				"				</tr>"
			objTextStream.Write	Chr(9) & Chr(9) & Chr(9) & Chr(9) & Chr(9) & Chr(9) & "<tr bgcolor=" & CColor & ">" & Chr(13)
			objTextStream.Write	Chr(9) & Chr(9) & Chr(9) & Chr(9) & Chr(9) & Chr(9) & Chr(9) & "<td align=left>" & strTitle & "</td>" & Chr(13)
			objTextStream.Write	Chr(9) & Chr(9) & Chr(9) & Chr(9) & Chr(9) & Chr(9) & Chr(9) & "<td align=right>" & strSize & " " & strLabel & "</td>" & Chr(13)
			objTextStream.Write	Chr(9) & Chr(9) & Chr(9) & Chr(9) & Chr(9) & Chr(9) & Chr(9) & "<td align=right>" & strDate & "</td>" & Chr(13)
			objTextStream.Write	Chr(9) & Chr(9) & Chr(9) & Chr(9) & Chr(9) & Chr(9) & "</tr>" & Chr(13)
			intI = 1- intI
			rs.MoveNext
		Loop
		rs.Close
	End If
	Set rs=Nothing
	objTextStream.Write	Chr(9) & Chr(9) & Chr(9) & Chr(9) & Chr(9) & "</table>" & Chr(13)
	objTextStream.Write	Chr(9) & Chr(9) & Chr(9) & Chr(9) & "</td>" & Chr(13)
	objTextStream.Write	Chr(9) & Chr(9) & Chr(9) & "</tr>" & Chr(13)
	objTextStream.Write	Chr(9) & Chr(9) & "</table>" & Chr(13)
	objTextStream.Write	Chr(9) & "</body>" & Chr(13)
	objTextStream.Write	"</html>" & Chr(13)
	objTextStream.Close
	Set objTextStream = Nothing
	Set objFSO = Nothing
	my_Conn.Close
	Set my_Conn = Nothing
	Response.Write	"			</table>" & vbNewLine & _
		"		</td>" & vbNewLine & _
		"	</tr>" & vbNewLine & _
		"</table>" & vbNewLine & _
		"</body>" & _
		"</html>" & _
		"<meta http-equiv=""Refresh"" content=""2;URL=uploads/directory.htm"" />"
End If
If Request("submit") > "" Then
	my_Conn.Execute("DELETE FROM filedir")
	Response.Write	"<font family=""courier new"" size=""5"">"
	Server.ScriptTimeout = 900
	Const FOR_READING = 1
	dim ng
	Dim objFSO    			' FileSystemObject variable
	Dim objFolder 			' Folder variable
	Dim objItem   			' Variable used to loop through the contents of the folder
	Dim strQuery  			' Search string
	Dim strLink					'	Name Comparison
	Dim intSize					'	File size
	Dim strSize					'	B, KB, MB, GB
	For i = 67 to 90		' Drives C - Z
		If Request.Form("HPart" & chr(i)) = "on" Then
			strPath = "HPart" & chr(i) & "/"
			If strQuery = "" Then strQuery = Request.Form("query")
			Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
			On Error Resume Next
			Set objFolder = objFSO.GetFolder(Server.MapPath(strPath))
			Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
			SET objFolder = objFSO.GetFolder(Server.MapPath(strPath))
			If not ((objFolder.Attributes AND 2) or (objFolder.Attributes AND 4) or (objFolder.Attributes AND 32)  or (objFolder.Attributes AND 64) or (objFolder.Attributes AND 2048)) Then
				Set colFiles = objFolder.Files
				On Error Resume Next
				For Each objItem In colFiles
					If objItem.Path=strLink Then Exit For
					If not (objItem.Name="") Then
						intSize=objItem.Size
						If intSize<1024 Then
							strSize=" "
						ElseIf intSize<1048576 Then
							strSize=" KB"
							intSize=Round(intSize/1024,2)
						ElseIf intSize<1073741824 Then
							strSize=" MB"
							intSize=Round(intSize/1048576,2)
						Else
							strSize=" GB"
							intSize=Round(intSize/1073741824,2)
						End If
						strLink=objItem.Path
					End If
				Next
				ShowSubFolders(objFolder)
			End If
			Response.Write	"</table>"
		End If
	Next
	Set objItem = Nothing
	Set objFolder = Nothing
	Set objFSO = Nothing
	my_Conn.Close
	Set my_Conn = Nothing
	Response.Write	"</table>" & vbNewLine & _
		"<meta http-equiv=""Refresh"" content=""2;URL=hd.asp?report=1"" />" & _
		"</body>" & _
		"</html>"
Else			
	Response.Write	"<form action=""hd.asp"" method=""post"" id=""authenticate"">" & vbNewLine & _
		"	<table align=""center"" width=""50%"" style=""border-collapse: collapse"" border=""1"" cellpadding=""5"" cellspacing=""1"">" & vbNewLine & _
		"		<tr valign=""middle"">" & vbNewLine & _
		"			<td align=""center"" colspan=""2"" bgcolor=""cyan"">" & vbNewLine & _
		"				<font family=""arial"" size=""2"" color=""navy""><b>Drives to Include:</b>" & vbNewLine & _
		"				</font>" & vbNewLine & _
		"			</td>" & vbNewLine & _
		"		</tr>" & vbNewLine & _
		"		<tr valign=""middle"">" & vbNewLine & _
		"			<td align=""center"" colspan=""2"" bgcolor=""cyan"">" & vbNewLine & _
		"				<font family=""arial bold"" size=""2"" color=""black"">" & vbNewLine
	For i = 67 to 90
		Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
		strI=chr(i)&":"
		If objFSO.DriveExists(strI) Then
			Response.Write	"				<input type=""checkbox"" name=""HPart"& chr(i) &""">" & chr(i) & vbNewLine
		End If
		Set objFSO=Nothing
	Next
	Response.Write	"				</font>" & vbNewLine & _
		"			</td>" & vbNewLine & _
		"		</tr>" & vbNewLine & _
		"		<tr valign=""middle"">" & vbNewLine & _
		"			<td bgColor=""cyan"" colspan=""2"" align=""center""><input type=""submit"" value=""Submit"" id=""submit"" name=""submit"">" & vbNewLine & _
		"		</tr>" & vbNewLine & _
		"	</table>" & vbNewLine & _
		"</form>" & vbNewLine
End If
my_Conn.Close
Set my_Conn = Nothing
Response.Write	"</font>" & _
	"</body>" & _
	"</html>"

Sub ShowSubFolders(objFolder)
	Set colFolders = objFolder.SubFolders
	For Each objSubFolder In colFolders
		strTitle=""
		If not ((objSubFolder.Attributes AND 2) or (objSubFolder.Attributes AND 4) or (objSubFolder.Attributes AND 32) or (objSubFolder.Attributes AND 64) or (objSubFolder.Attributes AND 2048)) Then
			Set colFiles = objSubFolder.Files
			strTitle=mid(objSubFolder,4)
			strTitle=replace(strTitle,"\","/") & "/"
			strLink = strPath & strTitle
			If not ((objSubFolder.Attributes AND 2) or (objSubFolder.Attributes AND 4) or (objSubFolder.Attributes AND 32) or (objSubFolder.Attributes AND 64) or (objSubFolder.Attributes AND 2048)) Then
				strTitle=mid(objSubFolder,4)
				strTitle=replace(strTitle,"\","/") & "/"
				On Error Resume Next
				intJ = 0
				For Each objItem In colFiles
					intj = 1 - intj
					strDate = cStr(objItem.DateLastModified)
					If len(strDate) < 22 Then
						If mid(strDate,2,1) = "/" Then strDate = "0" & strDate
						If mid(strDate,5,1) = "/" Then strDate = left(strDate,3) & "0" & mid(strDate,4)
						If mid(strDate,13,1) = ":" Then strDate = left(strDate,11) & "0" & mid(strDate,12)
					End If
					Set objFile=objFSO.GetFile(objItem)
					strLink = strPath & strTitle & objItem.Name
					If (not (objItem.Name="") or isNull(objItem.Name) or (objFile.Attributes AND 2) or (objFile.Attributes AND 4) or (objFile.Attributes AND 32) or (objFile.Attributes AND 64) or (objFile.Attributes AND 2048)) Then
						Set objFile = Nothing
						intSize=objItem.Size
						If intSize<1024 Then
							strSize="B"
						ElseIf intSize<1048576 Then
							strSize="KB"
							intSize=Round(intSize/1024,2)
						ElseIf intSize<1073741824 Then
							strSize="MB"
							intSize=Round(intSize/1048576,2)
						Else
							strSize="GB"
							intSize=Round(intSize/1073741824,2)
						End If
						If objItem.Size > 1048576 Then
								my_Conn.Execute("INSERT INTO FILEDIR (TITLE,FSIZE,LABEL,CREATION) VALUES ('" & objItem.Name & "'," & intSize & ",'" & Right(strSize,2) & "', '" & cStr(objItem.DateLastModified) & "')")
						End If
					End If
				Next
			End If
			ShowSubFolders(objSubFolder)
		End If
		Set colFiles = Nothing
	Next
End Sub
%>
Edited by - Carefree on 08 February 2015 19:23:53
  Previous Topic Topic Next Topic  
 New Topic  Reply to Topic
 Printer Friendly
Jump To:
Snitz Forums 2000 © 2000-2021 Snitz™ Communications Go To Top Of Page
This page was generated in 0.14 seconds. Powered By: Snitz Forums 2000 Version 3.4.07