<%
shopcheckadmin ""
'*******************************
'* Check file type validation
'* 16/3/2005
'*******************************
const xuploadtypes = "jpg,jpeg,gif,png" 'Allowed file types for image upload facility (separate each extension with a comma)
'*******************************
'************************************************************
' Stores a file on the web host. called from shopa_upload.asp
' VP-ASP 6.50 June 30, 2005
'***********************************************************
Dim catalogid, dbfield
Dim product
dim mydirectory
Dim fullname
Dim absoluteFile
Dim UploadRequest
dim uploadType
uploadtype=ucase(xupload)
HandleStandard
If Serror<>"" then
WriteErrors serror
else
'url="shopa_uploaddb.asp"
'Responseredirect url
WriteToParent
WriteInfo
end if
'
Sub HandleStandard
dim pos
'******************************************************
' 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")
contentType = UploadRequest.Item("blob").Item("ContentType")
filepathname = UploadRequest.Item("blob").Item("FileName")
setsess "UploadFilename",filepathname
If Filepathname="" then
serror = getlang("LangMenuFileName") & " " & getlang("langcustrequired")
writeerrors serror
response.end
end if
'*******************************
'* Check file type validation
'* 16/3/2005
'*******************************
dim validTypes, extension, fileOkay
if len(xuploadtypes) > 0 then 'if xuploadtypes is defined in shop$config, use it as the comparison parameters
validTypes = split(xuploadtypes, ",")
else 'otherwise, use the following "default" image types
validTypes = split("jpg,jpeg,gif,png", ",")
end if
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
serror = getlang("LangMenuFileName") & " is an invalid file format for uploading. Valid types: " & join(validTypes, ", ")
end if
'*******************************
filename = Right(filepathname,Len(filepathname)-InstrRev(filepathname,"\"))
'on error resume next
value = UploadRequest.Item("blob").Item("Value")
if err.number> 0 then
Serror="No image selected"
HandleError
end if
if mydirectory<> "" then
fullname=mydirectory & "/" & filename
else
fullname=filename
end if
dim size
'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
dim fso, f
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFile(absolutefile)
size=f.size
set fso=nothing
set f=nothing
If size=0 then
handleError
else
setsess "uploadimage",fullname
Setsess "absolutename",absolutenmae
setsess "Uploaddirectory",mydirectory
end if
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 & err.description & " "
end sub
Sub WriteErrors (serror)
%>
VPASP Shopping Cart Control Panel