Script freeASPupload

[simonetromboni]

Qualcuno di voi conosce questo script?
Una volta effettuato l'upload del file la pagina viene ricaricata con un response.write che indica il nome del file, la dimensione etc.
Avrei bisogno di inserire in automatico il nome del file uploadato in un campo di testo nella pagina appena ricaricata o in una successiva, ma non so qual è la variabile giusta (anche perchè le variabili sono tutte all'interno di funzioni). Ho provato tutte le variabili (almeno mi sembra) ma senza successo.
In pratica, nel mio campo di testo io dovrei mettere:

<%=directory/(variabile nome file)%>

Il tutto mi serve per far si che l'utente, dopo aver uploadato il file, abbia accesso ad un form dove mettere un titolo, una descrizione ed infine registrare tutto (compreso il link al nome del file) in un db.

Ringrazio tutti anticipatamente!!!

Saluti
Simone

[simonetromboni]

sto girando tutti i forum sulle ASP, non riesco a trovare niente...vi prego aiutatemi....

[diegoctn]

Vediamo il codice............

[simonetromboni]

Allora, questa è la pagina pubblica, quella dove si trova il form di inserimento:

<%@ Language=VBScript %>
<%
option explicit
Response.Expires = -1
Server.ScriptTimeout = 600
%>

<%


' ************************************************** **
' Change the value of the variable below to the pathname
' of a directory with write permissions, for example "C:\Inetpub\wwwroot"
Dim uploadsDirVar
uploadsDirVar = "D:\wwwroot\mmartins.com\www\database"
' ************************************************** **

' Note: this file uploadTester.asp is just an example to demonstrate
' the capabilities of the freeASPUpload.asp class. There are no plans
' to add any new features to uploadTester.asp itself. Feel free to add
' your own code. If you are building a content management system, you
' may also want to consider this script: http://www.webfilebrowser.com/

function OutputForm()
%>
<form name="frmSend" method="POST" enctype="multipart/form-data" action="uploadTester.asp" onSubmit="return onSubmitForm();">
File 1: <input name=attach1 type=file size=35>

File 2: <input name=attach2 type=file size=35>

File 3: <input name=attach3 type=file size=35>

File 4: <input name=attach4 type=file size=35>



<input style="margin-top:4" type=submit value="Upload">
</form>
<%
end function

function TestEnvironment()
Dim fso, fileName, testFile, streamTest
TestEnvironment = ""
Set fso = Server.CreateObject("Scripting.FileSystemObject")
if not fso.FolderExists(uploadsDirVar) then
TestEnvironment = "Folder " & uploadsDirVar & " does not exist.
The value of your uploadsDirVar is incorrect. Open uploadTester.asp in an editor and change the value of uploadsDirVar to the pathname of a directory with write permissions."
exit function
end if
fileName = uploadsDirVar & "\test.txt"
on error resume next
Set testFile = fso.CreateTextFile(fileName, true)
If Err.Number<>0 then
TestEnvironment = "Folder " & uploadsDirVar & " does not have write permissions.
The value of your uploadsDirVar is incorrect. Open uploadTester.asp in an editor and change the value of uploadsDirVar to the pathname of a directory with write permissions."
exit function
end if
Err.Clear
testFile.Close
fso.DeleteFile(fileName)
If Err.Number<>0 then
TestEnvironment = "Folder " & uploadsDirVar & " does not have delete permissions, although it does have write permissions.
Change the permissions for IUSR_computername on this folder."
exit function
end if
Err.Clear
Set streamTest = Server.CreateObject("ADODB.Stream")
If Err.Number<>0 then
TestEnvironment = "The ADODB object Stream is not available in your server.
Check the Requirements page for information about upgrading your ADODB libraries."
exit function
end if
Set streamTest = Nothing
end function

function SaveFiles
Dim Upload, fileName, fileSize, ks, i, fileKey

Set Upload = New FreeASPUpload
Upload.Save(uploadsDirVar)

' If something fails inside the script, but the exception is handled
If Err.Number<>0 then Exit function

SaveFiles = ""
ks = Upload.UploadedFiles.keys
if (UBound(ks) <> -1) then
SaveFiles = "Files uploaded: "
for each fileKey in Upload.UploadedFiles.keys
SaveFiles = SaveFiles & Upload.UploadedFiles(fileKey).FileName & " (" & Upload.UploadedFiles(fileKey).Length & "B) "
next
else
SaveFiles = "The file name specified in the upload form does not correspond to a valid file in the system."
end if
end function
%>

<HTML>
<HEAD>
<TITLE>Test Free ASP Upload</TITLE>
<style>
BODY {background-color: white;font-family:arial; font-size:12}
</style>
<script>
function onSubmitForm() {
var formDOMObj = document.frmSend;
if (formDOMObj.attach1.value == "" && formDOMObj.attach2.value == "" && formDOMObj.attach3.value == "" && formDOMObj.attach4.value == "" )
alert("Please press the browse button and pick a file.")
else
return true;
return false;
}
</script>

</HEAD>

<BODY>




<div style="border-bottom: #A91905 2px solid;font-size:16">Upload files to your server</div>
<%
Dim diagnostics
if Request.ServerVariables("REQUEST_METHOD") <> "POST" then
diagnostics = TestEnvironment()
if diagnostics<>"" then
response.write "<div style=""margin-left:20; margin-top:30; margin-right:30; margin-bottom:30;"">"
response.write diagnostics
response.write "

After you correct this problem, reload the page."
response.write "</div>"
else
response.write "<div style=""margin-left:150"">"
OutputForm()
response.write "</div>"
end if
else
response.write "<div style=""margin-left:150"">"
OutputForm()
response.write SaveFiles()
response.write "

</div>"
end if

%>


<div style="border-bottom: #A91905 2px solid;font-size:10">Powered by Free ASP Upload</div>







<table cellspacing=10>
<tr><td>
<table width="140" border="1" cellpadding="0" cellspacing="0" bordercolor="#840300" bgcolor="#D70500">
<form action="http://www.hotscripts.com/cgi-bin/rate.cgi" method="POST">
<tr>
<td><table width="100%" border="0" cellspacing="0" cellpadding="2" style="font-size:8pt">
<tr align="center" bgcolor="#AA0400">
<td colspan="2"><font color="#FFFFFF">Rate Our Program
at Hotscripts.com
<input type="hidden" name="ID" value="21966">
<input type="hidden" name="external2" value="1">
</font></td>
</tr>
<tr>
<td align="right"><input type="radio" value="5" name="rate"></td>
<td><font color="#FFFFFF">Excellent!</font></td>
</tr>
<tr>
<td align="right"><input type="radio" value="4" name="rate"></td>
<td><font color="#FFFFFF">Very Good</font></td>
</tr>
<tr>
<td align="right"><input type="radio" value="3" name="rate"></td>
<td><font color="#FFFFFF">Good</font></td>
</tr>
<tr>
<td align="right"><input type="radio" value="2" name="rate"></td>
<td><font color="#FFFFFF">Fair</font></td>
</tr>
<tr>
<td align="right"><input type="radio" value="1" name="rate"></td>
<td><font color="#FFFFFF">Poor</font></td>
</tr>
<tr align="center">
<td colspan="2"><input name="submit2" type="submit" value="Cast My Vote!"></td>
</tr>
</table></td>
</tr>
</form>
</table>

<td valign=top>

<table border=0 cellpadding=1 cellspacing=0 bgcolor=000000>
<tr><td align=center>
<table border=0 cellpadding=3 cellspacing=0 bgcolor=eeeedd>
<tr><td align=center nowrap>
<font style="font-size:10pt;font-family:Arial;">Rated: <img src=http://ratings.Aspin.com/getstars?id=5380510 border=0>
<font style="font-size:8pt;">
by Aspin.com users
</font></font>
</td></tr><tr nowrap><form action="http://www.Aspin.com/func/review/write?id=5380510" method=post><td align=center>
<font style="font-size:10pt;font-family:Arial;">What do you think?</font>

<select name="VoteStars"><option>5 Stars<option>4 Stars<option>3 Stars<option>2 Stars<option>1 Star</select><input type=submit value="Vote">
</td></form></tr></table>
</td></tr></table>

<td valign=top style="font-size:10pt" width=300>

Please support this free script by rating it with the boxes on the left.


To remove these boxes from this page please follow the instructions in the source HTML. The code to remove is clearly indicated and very easy to find.


Thank you.
</table>


</BODY>
</HTML>

[simonetromboni]

Quest'altra invece è la pagina (suppongo) che fa il lavoro in background:

<%
' For examples, documentation, and your own free copy, go to:
' http://www.freeaspupload.net
' Note: You can copy and use this script for free and you can make changes
' to the code, but you cannot remove the above comment.

Class FreeASPUpload
Public UploadedFiles
Public FormElements

Private VarArrayBinRequest
Private StreamRequest
Private uploadedYet

Private Sub Class_Initialize()
Set UploadedFiles = Server.CreateObject("Scripting.Dictionary")
Set FormElements = Server.CreateObject("Scripting.Dictionary")
Set StreamRequest = Server.CreateObject("ADODB.Stream")
StreamRequest.Type = 1 'adTypeBinary
StreamRequest.Open
uploadedYet = false
End Sub

Private Sub Class_Terminate()
If IsObject(UploadedFiles) Then
UploadedFiles.RemoveAll()
Set UploadedFiles = Nothing
End If
If IsObject(FormElements) Then
FormElements.RemoveAll()
Set FormElements = Nothing
End If
StreamRequest.Close
Set StreamRequest = Nothing
End Sub

Public Property Get Form(sIndex)
Form = ""
If FormElements.Exists(LCase(sIndex)) Then Form = FormElements.Item(LCase(sIndex))
End Property

Public Property Get Files()
Files = UploadedFiles.Items
End Property

'Calls Upload to extract the data from the binary request and then saves the uploaded files
Public Sub Save(path)
Dim streamFile, fileItem

if Right(path, 1) <> "\" then path = path & "\"

if not uploadedYet then Upload

For Each fileItem In UploadedFiles.Items
Set streamFile = Server.CreateObject("ADODB.Stream")
streamFile.Type = 1
streamFile.Open
StreamRequest.Position=fileItem.Start
StreamRequest.CopyTo streamFile, fileItem.Length
streamFile.SaveToFile path & fileItem.FileName, 2
streamFile.close
Set streamFile = Nothing
fileItem.Path = path & fileItem.FileName
Next
End Sub

Public Function SaveBinRequest(path) ' For debugging purposes
StreamRequest.SaveToFile path & "\debugStream.bin", 2
End Function

Public Sub DumpData() 'only works if files are plain text
Dim i, aKeys, f
response.write "Form Items:
"
aKeys = FormElements.Keys
For i = 0 To FormElements.Count -1 ' Iterate the array
response.write aKeys(i) & " = " & FormElements.Item(aKeys(i)) & "
"
Next
response.write "Uploaded Files:
"
For Each f In UploadedFiles.Items
response.write "Name: " & f.FileName & "
"
response.write "Type: " & f.ContentType & "
"
response.write "Start: " & f.Start & "
"
response.write "Size: " & f.Length & "
"
Next
End Sub

Private Sub Upload()
Dim nCurPos, nDataBoundPos, nLastSepPos
Dim nPosFile, nPosBound
Dim sFieldName, osPathSep, auxStr

'RFC1867 Tokens
Dim vDataSep
Dim tNewLine, tDoubleQuotes, tTerm, tFilename, tName, tContentDisp, tContentType
tNewLine = Byte2String(Chr(13))
tDoubleQuotes = Byte2String(Chr(34))
tTerm = Byte2String("--")
tFilename = Byte2String("filename=""")
tName = Byte2String("name=""")
tContentDisp = Byte2String("Content-Disposition")
tContentType = Byte2String("Content-Type:")

uploadedYet = true

on error resume next
VarArrayBinRequest = Request.BinaryRead(Request.TotalBytes)
if Err.Number <> 0 then
response.write "

System reported this error:

"
response.write Err.Description & "

"
response.write "The most likely cause for this error is the incorrect setup of AspMaxRequestEntityAllowed in IIS MetaBase. Please see instructions in the requirements page of freeaspupload.net.

"
Exit Sub
end if
on error goto 0 'reset error handling

nCurPos = FindToken(tNewLine,1) 'Note: nCurPos is 1-based (and so is InstrB, MidB, etc)

If nCurPos <= 1 Then Exit Sub

'vDataSep is a separator like -----------------------------21763138716045
vDataSep = MidB(VarArrayBinRequest, 1, nCurPos-1)

'Start of current separator
nDataBoundPos = 1

'Beginning of last line
nLastSepPos = FindToken(vDataSep & tTerm, 1)

Do Until nDataBoundPos = nLastSepPos

nCurPos = SkipToken(tContentDisp, nDataBoundPos)
nCurPos = SkipToken(tName, nCurPos)
sFieldName = ExtractField(tDoubleQuotes, nCurPos)

nPosFile = FindToken(tFilename, nCurPos)
nPosBound = FindToken(vDataSep, nCurPos)

If nPosFile <> 0 And nPosFile < nPosBound Then
Dim oUploadFile
Set oUploadFile = New UploadedFile

nCurPos = SkipToken(tFilename, nCurPos)
auxStr = ExtractField(tDoubleQuotes, nCurPos)
' We are interested only in the name of the file, not the whole path
' Path separator is \ in windows, / in UNIX
' While IE seems to put the whole pathname in the stream, Mozilla seem to
' only put the actual file name, so UNIX paths may be rare. But not impossible.
osPathSep = "\"
if InStr(auxStr, osPathSep) = 0 then osPathSep = "/"
oUploadFile.FileName = Right(auxStr, Len(auxStr)-InStrRev(auxStr, osPathSep))

if (Len(oUploadFile.FileName) > 0) then 'File field not left empty
nCurPos = SkipToken(tContentType, nCurPos)

auxStr = ExtractField(tNewLine, nCurPos)
' NN on UNIX puts things like this in the streaa:
' ?? python py type=?? python application/x-python
oUploadFile.ContentType = Right(auxStr, Len(auxStr)-InStrRev(auxStr, " "))
nCurPos = FindToken(tNewLine, nCurPos) + 4 'skip empty line

oUploadFile.Start = nCurPos-1
oUploadFile.Length = FindToken(vDataSep, nCurPos) - 2 - nCurPos

If oUploadFile.Length > 0 Then UploadedFiles.Add LCase(sFieldName), oUploadFile
End If
Else
Dim nEndOfData
nCurPos = FindToken(tNewLine, nCurPos) + 4 'skip empty line
nEndOfData = FindToken(vDataSep, nCurPos) - 2
If Not FormElements.Exists(LCase(sFieldName)) Then FormElements.Add LCase(sFieldName), String2Byte(MidB(VarArrayBinRequest, nCurPos, nEndOfData-nCurPos))
End If

'Advance to next separator
nDataBoundPos = FindToken(vDataSep, nCurPos)
Loop
StreamRequest.Write(VarArrayBinRequest)
End Sub

Private Function SkipToken(sToken, nStart)
SkipToken = InstrB(nStart, VarArrayBinRequest, sToken)
If SkipToken = 0 then
Response.write "Error in parsing uploaded binary request."
Response.End
end if
SkipToken = SkipToken + LenB(sToken)
End Function

Private Function FindToken(sToken, nStart)
FindToken = InstrB(nStart, VarArrayBinRequest, sToken)
End Function

Private Function ExtractField(sToken, nStart)
Dim nEnd
nEnd = InstrB(nStart, VarArrayBinRequest, sToken)
If nEnd = 0 then
Response.write "Error in parsing uploaded binary request."
Response.End
end if
ExtractField = String2Byte(MidB(VarArrayBinRequest, nStart, nEnd-nStart))
End Function

'String to byte string conversion
Private Function Byte2String(sString)
Dim i
For i = 1 to Len(sString)
Byte2String = Byte2String & ChrB(AscB(Mid(sString,i,1)))
Next
End Function

'Byte string to string conversion
Private Function String2Byte(bsString)
Dim i
String2Byte =""
For i = 1 to LenB(bsString)
String2Byte = String2Byte & Chr(AscB(MidB(bsString,i,1)))
Next
End Function
End Class

Class UploadedFile
Public ContentType
Public Start
Public Length
Public Path
Private nameOfFile

' Need to remove characters that are valid in UNIX, but not in Windows
Public Property Let FileName(fN)
nameOfFile = fN
nameOfFile = SubstNoReg(nameOfFile, "\", "_")
nameOfFile = SubstNoReg(nameOfFile, "/", "_")
nameOfFile = SubstNoReg(nameOfFile, ":", "_")
nameOfFile = SubstNoReg(nameOfFile, "*", "_")
nameOfFile = SubstNoReg(nameOfFile, "?", "_")
nameOfFile = SubstNoReg(nameOfFile, """", "_")
nameOfFile = SubstNoReg(nameOfFile, "<", "_")
nameOfFile = SubstNoReg(nameOfFile, ">", "_")
nameOfFile = SubstNoReg(nameOfFile, "|", "_")
End Property

Public Property Get FileName()
FileName = nameOfFile
End Property

'Public Property Get FileN()ame
End Class


' Does not depend on RegEx, which is not available on older VBScript
' Is not recursive, which means it will not run out of stack space
Function SubstNoReg(initialStr, oldStr, newStr)
Dim currentPos, oldStrPos, skip
If IsNull(initialStr) Or Len(initialStr) = 0 Then
SubstNoReg = ""
ElseIf IsNull(oldStr) Or Len(oldStr) = 0 Then
SubstNoReg = initialStr
Else
If IsNull(newStr) Then newStr = ""
currentPos = 1
oldStrPos = 0
SubstNoReg = ""
skip = Len(oldStr)
Do While currentPos <= Len(initialStr)
oldStrPos = InStr(currentPos, initialStr, oldStr)
If oldStrPos = 0 Then
SubstNoReg = SubstNoReg & Mid(initialStr, currentPos, Len(initialStr) - currentPos + 1)
currentPos = Len(initialStr) + 1
Else
SubstNoReg = SubstNoReg & Mid(initialStr, currentPos, oldStrPos - currentPos) & newStr
currentPos = oldStrPos + skip
End If
Loop
End If
End Function
%>


Spero tu mi possa aiutare, ho due siti fermi in attesa di godere di questo script...grazie mille!