<% const xuploadtypes = "txt,csv" 'Allowed file types for import upload facility (separate each extension with a comma) '************************************************************ ' Stores a file on the web host. called from shopupload.asp ' VP-ASP 6.50 '*********************************************************** shopcheckadmin "" Dim tablename Dim catalogid Dim product dim mydirectory Dim fullname Dim absoluteFile Dim UploadRequest dim uploadType uploadtype=ucase(xupload) HandleStandard If Serror<>"" then WriteErrors else Response.redirect "shopa_import.asp" end if ' Sub HandleStandard dim pos dim validTypes, extension, fileOkay '****************************************************** ' location = file location '******************************************************** Response.Expires=0 Response.Buffer = TRUE Response.Clear 'Response.BinaryWrite(Request.BinaryRead(Request.TotalBytes)) byteCount = Request.TotalBytes 'Response.BinaryWrite(Request.BinaryRead(varByteCount)) RequestBin = Request.BinaryRead(byteCount) Set UploadRequest = CreateObject("Scripting.Dictionary") BuildUploadRequest RequestBin mydirectory = UploadRequest.Item("directory").Item("Value") 'tablename = UploadRequest.Item("tablename").Item("Value") contentType = UploadRequest.Item("blob").Item("ContentType") filepathname = UploadRequest.Item("blob").Item("FileName") Session("UploadFilename")=filepathname If Filepathname="" then Response.Redirect "shopa_import.asp" & "?msg=" & Server.URLEncode ("Missing file name") end if filename = Right(filepathname,Len(filepathname)-InstrRev(filepathname,"\")) '******************************* '* Check file type validation '* 16/3/2005 '******************************* validTypes = split(xuploadtypes, ",") fileOkay = false for each extension in validTypes 'check file extension against each item in the type array if lcase(right(Filepathname, len(trim(extension)))) = lcase(trim(extension)) then fileOkay = true 'if the extension matches an array item, it's okay to upload end if next if fileOkay = false then 'if the extension didn't match anything in the type array, return an error 'shoperror getlang("languploadfilenamerrror") & " " & "
Valid types: " & join(validTypes, ", ") shoperror getlang("LangMenuFileName") & " is an invalid file format for uploading.
Valid types: " & join(validTypes, ", ") end if 'on error resume next value = UploadRequest.Item("blob").Item("Value") if err.number> 0 then Serror="No file selected" HandleError end if if mydirectory<> "" then fullname=mydirectory & "/" & filename else fullname=filename end if 'Create FileSytemObject Component Set ScriptObject = Server.CreateObject("Scripting.FileSystemObject") 'Create and Write to a File pos=Instr(fullname,":") if pos=0 then absoluteFile=Server.mappath(fullname) else absolutefile=fullname end if on error resume next Set MyFile = ScriptObject.CreateTextFile(absolutefile) if err.number>0 then HandleError end if For i = 1 to LenB(value) MyFile.Write chr(AscB(MidB(value,i,1))) Next MyFile.Close Session("importfilename")=fullname Session("absolutename")=absolutenmae Session("Uploaddirectory")=mydirectory end Sub ' Author Philippe Collignon ' Email PhCollignon@email.com Sub BuildUploadRequest(RequestBin) 'Get the boundary PosBeg = 1 PosEnd = InstrB(PosBeg,RequestBin,getByteString(chr(13))) boundary = MidB(RequestBin,PosBeg,PosEnd-PosBeg) boundaryPos = InstrB(1,RequestBin,boundary) 'Get all data inside the boundaries Do until (boundaryPos=InstrB(RequestBin,boundary & getByteString("--"))) 'Members variable of objects are put in a dictionary object Dim UploadControl Set UploadControl = CreateObject("Scripting.Dictionary") 'Get an object name 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) 'Test if object is of file type If PosFile<>0 AND (PosFile" Serror=Serror & "Error Descr.=" & err.description & "
" Serror=Serror & "Source=" & err.source & "
" end sub Sub WriteErrors adminpageheader response.write Getconfig("xfont") & serror & "" adminpagetrailer end sub %>