er ikke haj til asp men har dette script (noget af det) som gør begge de ting du beder om
<%
Function CreateFileName
Dim Tname, Rs, conn, Rno, DNS
DNS = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=d:\home\ditdomæne\db\database.mdb;"
Conn.Open DNS
Set rs = Server.CreateObject("ADODB.Recordset")
Rs.Open "indhold", conn,3 ,3
Rno = Rs.recordcount+1
Rs.Addnew
'.... hvis der er flere felter,som skal opdateres
Rs.Update
Rs.Close
Set Rs = Nothing
Tname = Trim(CStr(Rno))
While Len(Tname)<8 Do
Tname = "0" & Tname
Loop
CreateFilename = Tname & ".JPEG"
End function
Class to get data of a form with ENCTYPE="multipart/form-data"
'Usage:
' Set variable = New BinForm
'Methods:
' Read()
' Reads the input of the multipart encoded form
' NOTE All other methods are only available after you call this method
' Save(Inputname)
' Saves the file input in File field labeled Inputname
' Inputname should be a string equal to the label of a formfield of type
' "FILE". NOTE: Only to be used after .Read
' Example: .Save("UploadFile")
' Form(Inputname)
' Returns the value entered in the specified formfield. Use this method '
' the same as Request.Form. NOTE: Only to be used after .Read '
' Example: .Form("inputtext") '
'Properties: '
' Read / Write '
' Extensions '
' Array of strings with extensions allowed. Seperator included. If Only '
' "*" is specified all datatypes are allowed '
' Default: .txt, .gif, .jpg, .mp3, .wma '
' Example .Extensions = Array(".txt", ".gif", ".jpg", ".mp3", ".wma")
' Directory
' String with the absolute path for download.NOTE: Inetuser should have '
' correct rights on folder.
' Default: Server.Mappath(\upload)
' Create
' Boolean which states wether or not non exsisting folders should be '
' created.
' Default: FALSE
' OverWrite
' Boolean which states wether or not exsisting files should be
' overwritten.
' Default: FALSE
' MaxSize
' Double with the maximum size in bytes of the files selected in the post '
' form.
' Default: 100,000 (97.7 k)
' SaveAs
' String which holds the name on how the file should be saved. Do not '
' include extension. SaveAs is reset to Empty after Save is called '
' Default: Empty (No rename)
' Read-only
' Success
' Boolean stating wether or not the last Save, SaveAs or SaveToDb Method '
' was successfull. NOTE: Only contains valid data after one of the Methods'
' is called
' Version
' String with software version of the class.
' Log
' String with the result log. On success it holds the data of all
' read-only Properties on failure it holds one or more error messages
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Class BinForm
'Class Declarations (used througout this class)
Private aExtensions, sDirectory, bCreate, bOverWrite, bSuccess, sLog, dicUpload, bReadSuccess
Private bNoInput, nTotalBytes, sFilePathExt, sNewFile, nMaxSize, z, sSaveAs, sWhere, svnm
'Properties setting
Public Property LET Extensions(byVal arrayInput)
aExtensions = arrayInput
End Property
Public Property LET Directory(byVal strInput)
sDirectory = strInput
End Property
Public Property LET Create(byVal boolInput)
bCreate = boolInput
End Property
Public Property LET OverWrite(byVal boolInput)
bOverWrite = boolInput
End Property
Public Property LET MaxSize(byVal lngInput)
nMaxSize = lngInput
End Property
Public Property LET SaveAs(byVal strInput)
sSaveAs = "" & strInput
End Property
'Properties reading
Public Property GET Extensions()
'The following lines are commented by johnson so that all the files can be uploaded
'If IsArray( aExtensions ) then
'Extensions = aExtensions
'Else
'If Len(arrExt) = 1 AND aExtensions = "*" Then
'Extensions = "*"
'Else
' default extensions
'Extensions = Array(".txt", ".jpg", ".gif")
Extensions = "*"
'End If
'End If
End Property
Public Property GET flName()
flName=svnm
end Property
Public Property GET Directory()
Directory = sDirectory
End Property
Public Property GET Create()
Create = CBool(bCreate)
End Property
Public Property GET OverWrite()
OverWrite = CBool(bOverWrite)
End Property
Public Property GET MaxSize()
If nMaxSize = 0 Then
' nMaxSize = 100000
nMaxSize = 10000000000000000000000000000000000000000000000
End If
MaxSize = nMaxSize
End Property
Public Property GET SaveAs()
SaveAs = sSaveAs
End Property
Public Property GET Success()
Success = bSuccess
End Property
Public Property GET Version()
Version = "Copyright"
End Property
Public Property GET Log()
Log = sLog
End Property
'Events (automatically invoked)
Private Sub Class_Initialize()
Call ClearVariables()
Call ClearDictionary()
End Sub
Private Sub Class_Terminate()
Call ClearVariables()
Call ClearDictionary()
End Sub
'Methods to be called by programmer always call Read first
Public Default Sub Read()
' Checks for input (error 3), filesize (error 4)
' and extensions (error 5) and initializes the
' reading of all the binary data
nTotalBytes = Request.TotalBytes
If nTotalBytes <= 0 Then
'Log the error of no data input
Call BinForm_Log(3)
bSuccess = False
ElseIf nTotalBytes > 0 And nTotalBytes <= MaxSize Then
'Goto Readbinary sub
Call ReadBinary(nTotalBytes)
Else
'Log the error of too much data and stop
Call BinForm_Log(4)
bSuccess = False
End If
End Sub
Public Sub Save(byVal sFormInput)
If bReadSuccess Then
Dim nFileLength, sFilePathName, sSaveName, sContentType
Dim spStr
sContentType = dicUpload.Item(sFormInput).Item("ContentType")
sFilePathName = dicUpload.Item(sFormInput).Item("FileName")
' spStr=split(Replace(sFilePathName,"\","*",1),"*")
spStr=split(sFilePathName,"\")
' sSaveName = Right(sFilePathName,Len(sFilePathName)-InStrRev(sFilePathName,"\"))
sSaveName = spStr(ubound(spStr))
sFilePathExt = Right(sFilePathName, 4)
nFileLength = LenB(dicUpload.Item(sFormInput).Item("Value"))
If IsArray(Extensions) Then
'check the extension
bSuccess = ExtensionCheck( sFilePathExt )
Else
If Extensions = "*" Then
bSuccess = True
End If
End If
If not bSuccess Then
'Illigal extension posted
Call BinForm_Log(5)
End If
'Response.write "Directory="&Directory&"<br>"
If sSaveAs <> "" Then
sSaveName = Directory & "\" & sSaveAs & Right(sSaveName, 4)
svnm=sSaveAs&right(sSaveName,4) 'added by miks
Else
sSaveName = Directory & "\" & sSaveName
svnm=sSaveName 'added by miks
End If
' create the new file on the server
Call WriteFile( sSaveName, dicUpload.Item(sFormInput).Item("Value") )
sSaveAs = ""
End If
End Sub
Public Function Form(sFormInput)
If not bReadSuccess Then
Form = ""
Else
Form = dicUpload.Item(sFormInput).Item("Value")
End If
End Function
'Routines (for internal class use)
Private Sub ClearVariables()
aExtensions = Array(".txt", ".jpg", ".gif", ".wma", ".mp3")
sDirectory = Server.MapPath("/upload")
bReadSuccess = False
sSaveAs = ""
bCreate = False
bOverWrite = False
'nMaxSize = 100000
bSuccess = True
sLog = ""
bNoInput = True
End Sub
Private Sub ClearDictionary()
' clear dictionary
Set dicUpload = Server.CreateObject("Scripting.Dictionary")
dicUpload.RemoveAll
Set dicUpload = Nothing
End Sub
Private Sub ReadBinary(byVal MaxBytes)
Dim nByteCount, sAllBinary
nByteCount = MaxBytes
sAllBinary = Request.BinaryRead (nByteCount)
Set dicUpload = Server.CreateObject("Scripting.Dictionary")
On Error Resume Next
BuildUpload sAllBinary
If not bSuccess Then
Call BinForm_Log(9)
End If
On Error Goto 0
End Sub
Private Function ExtensionCheck(byVal Ext)
Dim Item
For each Item in Extensions
If LCase( Ext ) = LCase( Item ) Then
ExtensionCheck = True
Exit Function
End if
Next
ExtensionCheck = False
End Function
Private Sub BinForm_Log(nMessage)
'First line in Logs with any error
Select Case nMessage
Case 0
sLog = "The posted data was succesfully read." &vbCrLf
Case 1
sLog = sLog & "File " & sNewFile & " was saved succesfully." &vbCrLf
Case 2
sLog = sLog & "File " & sNewFile & " was succesfully uploaded to database." &vbCrLf
Case 3
sLog = "The posted data was not read." &vbCrLf
sLog = sLog & "No data has been posted." &vbCrLf
Case 4
sLog = "The posted data was not read." &vbCrLf
sLog = sLog & "The total bytes of the post (" & CStr(nTotalBytes) & " bytes) is larger than set maximum of " & CStr(nMaxSize) & "." &vbCrLf
Case 5
sLog = sLog & "Upload failed. Illegal Extension posted." &vbCrLf
Case 6
sLog = sLog & "Upload failed. " & Directory & " directory not found. Unable to create directory. Check the rights of Internet User." &vbCrLf
Case 7
sLog = sLog & "Upload failed. " & Directory & " directory not found. Set Create to True if directory should be created." &vbCrLf
Case 8
sLog = sLog & "Upload failed. File already exsists and OverWrite is set to False" &vbCrLf
Case 9
bSuccess = False
sLog = sLog & "Upload failed. Error parsing file failed. Probably due to filesize" &vbCrLf
Exit Sub
End Select
End Sub
Private Sub BuildUpload(RequestBin)
dim PosBeg,PosEnd,boundary,boundaryPos,Pos,Name,PosFile
dim PosBound,FileName,ContentType,Value
bSuccess = False
PosBeg = 1
PosEnd = InstrB(PosBeg,RequestBin,getByteString(chr(13)))
boundary = MidB(RequestBin,PosBeg,PosEnd-PosBeg)
boundaryPos = InstrB(1,RequestBin,boundary)
Do until (boundaryPos=InstrB(RequestBin,boundary & getByteString("--")))
Dim UploadControl
Set UploadControl = Server.CreateObject("Scripting.Dictionary")
Pos = InstrB(BoundaryPos,RequestBin,getByteString("Content-Disposition"))
Pos = InstrB(Pos,RequestBin,getByteString("name="))
PosBeg = Pos+6
PosEnd = InstrB(PosBeg,RequestBin,getByteString(chr(34)))
Name = getString(MidB(RequestBin,PosBeg,PosEnd-PosBeg))
PosFile = InstrB(BoundaryPos,RequestBin,getByteString("filename="))
PosBound = InstrB(PosEnd,RequestBin,boundary)
If PosFile<>0 AND (PosFile<PosBound) Then
PosBeg = PosFile + 10
PosEnd = InstrB(PosBeg,RequestBin,getByteString(chr(34)))
FileName = getString(MidB(RequestBin,PosBeg,PosEnd-PosBeg))
UploadControl.Add "FileName", FileName
Pos = InstrB(PosEnd,RequestBin,getByteString("Content-Type:"))
PosBeg = Pos+14
PosEnd = InstrB(PosBeg,RequestBin,getByteString(chr(13)))
ContentType = getString(MidB(RequestBin,PosBeg,PosEnd-PosBeg))
UploadControl.Add "ContentType",ContentType
PosBeg = PosEnd+4
PosEnd = InstrB(PosBeg,RequestBin,boundary)-2
Value = MidB(RequestBin,PosBeg,PosEnd-PosBeg)
Else
Pos = InstrB(Pos,RequestBin,getByteString(chr(13)))
PosBeg = Pos+4
PosEnd = InstrB(PosBeg,RequestBin,boundary)-2
Value = getString(MidB(RequestBin,PosBeg,PosEnd-PosBeg))
End If
UploadControl.Add "Value" , Value
dicUpload.Add name, UploadControl
BoundaryPos=InstrB(BoundaryPos+LenB(boundary),RequestBin,boundary)
Loop
bSuccess = True
bReadSuccess = True
Call BinForm_Log(0)
Exit Sub
End Sub
Private Sub WriteFile(byVal NAME, byVal CONTENTS)
' create the file on the server
dim soWriteFile, sTmpDir
Set soWriteFile = Server.CreateObject("Scripting.FileSystemObject")
If Not soWriteFile.FolderExists( Directory ) Then
'If create new directories is allowed
If bCreate Then
' start from root and work your way down
sTmpDir = Left( Directory, 3)
Do While sTmpDir <> Directory
' if arrived at final subdirectory
If InStr( Mid( Directory, ( Len( sTmpDir ) + 2 ), (Len(Directory) - ( Len( sTmpDir ) + 2 ))), "\" ) = 0 Then
sTmpDir = Directory
Else
'volume to subdirectory below
sTmpDir = Left( Directory,( Len( sTmpDir ) + InStr(Mid( Directory, ( Len( sTmpDir ) + 2 ), (Len(Directory) - ( Len( sTmpDir ) + 2 ))), "\")) )
End If
If Not soWriteFile.FolderExists( sTmpDir ) Then
'create subdirectory with internal error creation
On Error Resume Next
soWriteFile.CreateFolder( sTmpDir )
If Not soWriteFile.FolderExists( sTmpDir ) Then
' error creating directory (probably rights on server)
Call BinForm_Log(6)
bSuccess = False
End If
On Error Goto 0
End If
Loop
Else
' error creating directory since no rights in Class
Call BinForm_Log(7)
bSuccess = False
End If
End If
If NOT OverWrite AND soWriteFile.FileExists( NAME ) Then
' don't allow file overwrite
Call BinForm_Log(8)
bSuccess = False
End If
If bSuccess Then
Set sNewFile = soWriteFile.CreateTextFile( NAME )
For z = 1 to LenB( CONTENTS )
' translate binary data into ASCII characters and write them into the file.
sNewFile.Write chr( AscB( MidB( CONTENTS, z, 1) ) )
Next
' clean up and inform the user of successful upload
sNewFile.Close
Set sNewFile = Nothing
sNewFile = NAME
Call BinForm_Log(1)
End If
Set soWriteFile = Nothing
End Sub
Private Function getByteString(StringStr)
dim char, i
For i = 1 to Len(StringStr)
char = Mid(StringStr,i,1)
getByteString = getByteString & chrB(AscB(char))
Next
End Function
Private Function getString(StringBin)
dim intCount
getString =""
For intCount = 1 to LenB(StringBin)
getString = getString & chr(AscB(MidB(StringBin,intCount,1)))
Next
End Function
End Class
%>
