uploadsiden skal hedde: uploadform.asp
og ser således ud:
<%@ Language=VBScript %>
<HEAD>
<TITLE>Upload billede</TITLE>
</HEAD>
<%
Dim UPLOAD_PATH
UPLOAD_PATH = Server.MapPath("files")
Dim g_oFso, g_oFolder, g_oFile
Set g_oFso = Server.CreateObject("Scripting.FileSystemObject")
Set g_oFolder = g_oFso.getFolder(UPLOAD_PATH)
If (Request.ServerVariables("REQUEST_METHOD") = "POST") Then
Dim g_oUpload
Set g_oUpload = get_upload_files()
Dim fpos, fcontent, strOldFileName, strNewFileName, fileExtension
fcontent = g_oUpload("upload").Item("content")
strOldFileName = UPLOAD_PATH & "\" & extract_filename(g_oUpload("upload").Item("filename"))
'finder file-extension
fileExtension = GetExt(strOldFileName)
Select Case fileExtension
'tilladte filtyper
Case "jpg","gif","png","jpeg"
Call UploadFileRename
'forbudte tiltyper
Case Else
Response.Redirect Request.ServerVariables("SCRIPT_NAME") & "?status=Forkert%20filtype..."
End Select
End If
Response.Write "<html><body><table>"
Response.Write "<tr><td><hr></td></tr>"
'bruges ikke da det viser alle filerne i uploadfolderen
'For Each g_oFile In g_oFolder.Files
' Response.Write "<tr><td><a href=""files/" & g_oFile.Name & """>" & g_oFile.name & "</a></td></tr>"
'Next
Response.Write "<tr><td>Upload en jpg, gif eller png fil ved at trykke ""Gennemse..."" - vælg derefter en fil og tryk ""Upload""</td></tr>"
Response.Write "<tr><td><hr></td></tr>"
Response.Write "<tr><td>Status: <font color=red>" & Request.QueryString("status") & "</font></td></tr>"
Response.Write "<tr><td align=""right""><form name=""frmUpload"" method=""post"" enctype=""multipart/form-data"" action=""" & Request.ServerVariables("SCRIPT_NAME") & """>"
Response.Write "<input type=""file"" name=""upload""> <input type=""submit"" value=""upload""></td></tr>"
Response.Write "</table></body></html>"
Sub UploadFileRename()
Set g_oFile = g_oFso.CreateTextFile(strOldFileName)
For fpos = 1 to LenB(fcontent)
g_oFile.Write chr(AscB(MidB(fcontent, fpos, 1)))
Next
g_oFile.Close
Set g_oFile = Nothing
'laver filnavn som session("brugernavn")
strNewFileName = UPLOAD_PATH & "\" & Session("brugernavn") & "." & fileExtension
'omdøber filen
If Rename(strOldFileName, strNewFileName) then
'Gør noget i tilfælde af at filen blev omdøbt
'laver database forbindelse
Set conn = Server.CreateObject("ADODB.Connection")
Conn.Open "DRIVER={Microsoft Access Driver (*.mdb)};DBQ="&Server.MapPath("ant.mdb")
'updater databasen
sql = "UPDATE brugerinfo SET billede = '" & strNewFileName &"', " & _
"WHERE brugernavn = '" & Session("brugernavn") & "';"
Conn.Execute(sql)
'lukker forbindelsen til databasen
Conn.Close
Set Conn = Nothing
'lukker vinduet og refresher siden hvor brugeren kom fra...
Response.Write "<SCRIPT>window.opener.location.reload();self.close();</SCRIPT>"
Else
'Gør noget i tilfælde af at filen IKKE blev omdøbt
Response.Redirect Request.ServerVariables("SCRIPT_NAME") & "?status=Filen%20kunne%20ikke%20omdøbes..."
End if
End Sub
Function get_upload_files()
Dim upload_object, request_binaries
Dim position_start, position_end
Dim boundary, boundary_pos
Set upload_object = Server.CreateObject("Scripting.Dictionary")
request_binaries = Request.BinaryRead(Request.TotalBytes)
position_start = 1
position_end = InstrB(position_start, request_binaries, get_byte_string(chr(13)))
boundary = MidB(request_binaries, position_start, (position_end - position_start))
boundary_pos = InstrB(1, request_binaries, boundary)
Do Until (boundary_pos = InstrB(request_binaries, boundary & get_byte_string("--")))
If Not(Response.IsClientConnected) Then Response.End
Dim name, pos_file
position_start = (InstrB(InstrB(boundary_pos, request_binaries, get_byte_string("Content-Disposition")), request_binaries, get_byte_string("name=")) + 6)
position_end = InstrB(position_start, request_binaries, get_byte_string(chr(34)))
name = get_string(MidB(request_binaries, position_start, (position_end - position_start)))
pos_file = InstrB(boundary_pos, request_binaries, get_byte_string("filename="))
If ((pos_file <> 0) AND (pos_file < InstrB(position_end, request_binaries, boundary))) Then
upload_object.Add name, Server.CreateObject("Scripting.Dictionary")
position_start = (pos_file + 10)
position_end = InstrB(position_start, request_binaries, get_byte_string(chr(34)))
upload_object.item(name).Add "filename", get_string(MidB(request_binaries, position_start, (position_end - position_start)))
position_start = (InstrB(position_end, request_binaries, get_byte_string("Content-Type:")) + 14)
position_end = InstrB(position_start, request_binaries, get_byte_string(chr(13)))
upload_object.item(name).Add "content-type", get_string(MidB(request_binaries, position_start, (position_end - position_start)))
position_start = (position_end + 4)
position_end = InstrB(position_start, request_binaries, boundary) - 2
upload_object.item(name).Add "size", ((position_end - position_start))
upload_object.item(name).Add "content", MidB(request_binaries, position_start, (position_end - position_start))
End If
boundary_pos = InstrB(boundary_pos + LenB(boundary), request_binaries, boundary)
Loop
Set get_upload_files = upload_object
End Function
Function get_byte_string(str)
Dim cnt
For cnt = 1 to Len(str)
get_byte_string = get_byte_string & chrB(AscB(Mid(str, cnt, 1)))
Next
End Function
Function get_string(str)
Dim cnt
For cnt = 1 to LenB(str)
get_string = get_string & chr(AscB(MidB(str, cnt, 1)))
Next
End Function
Function extract_filename(filename)
extract_filename = Right(filename, Len(filename) - InStrRev(filename, "\", -1, 1))
End Function
Function Rename(oldFileName, newFileName)
dim fso, fileX
On Error Resume Next
set fso = createobject("scripting.filesystemobject")
If fso.FileExists(oldFileName) = True Then
set fileX = fso.GetFile(oldFileName)
fileX.Move newFileName
Rename = True
Else
Rename = False
End if
If Err.number <> 0 then
Rename = False
End if
Response.write filex.name
set fileX = Nothing
Set fso = Nothing
End Function
Function GetGuid()
'Denne funktion returnere en såkaldt GUID ~ unik ID...
Dim TypeLib, guid_temp
Set TypeLib = Server.CreateObject("Scriptlet.TypeLib")
'A true GUID contains a unicode null termination, that needs to be stripped to behave like
' a string.
guid_temp = TypeLib.Guid
GetGuid = Left(guid_temp, Len(guid_temp) - 2)
Set TypeLib = Nothing
End Function
Function GetExt(sFile)
' by Donald, donald@xbeat.net, 20001010
Dim iPos
Dim iPosPrev
Do
iPosPrev = iPos
iPos = InStr(iPos + 1, sFile, ".", vbBinaryCompare)
Loop While iPos > 0
If iPosPrev > 0 Then
' must be right of last backslash
If InStr(iPosPrev + 1, sFile, "\", vbBinaryCompare) = 0 Then
GetExt = Mid(sFile, iPosPrev + 1)
End If
End If
End Function
%>
Ny bruger
Nybegynder
Opret
Preview
