Pure ASP upload with image detection - file-upload

Question

How to upload files from browser to server running classic ASP and detect, server side, if the files are valid pictures? For valid pictures, how to get their dimensions?
Usually file upload in classic ASP is done by third party components which come with a DLL file and requires registration on the server, sometimes also cost money. Needless to say many hosts won't allow third party components due to security reasons.
There are great many pure ASP upload scripts already, but they only take the file and save to server disk, no image detection whatsoever.
Below is my own script written for the above purpose but of course more answers are always welcome with alternatives or better ways.

Answer 1

Here is a single Class which handles file upload plus image detection. Use case will come below. Save this as-is, preferably as a new file, with .asp extension e.g. ShadowUpload.asp
Note: if you want to allow uploading images larger than 200kb, take a look in the answer to Request.BinaryRead(Request.TotalBytes) throws error for large files. (Failing to do so might result in "Operation not Allowed" error on the BinaryRead line.)
<%
'constants:
Const MAX_UPLOAD_SIZE=1500000 'bytes
Const MSG_NO_DATA="nothing to upload!"
Const MSG_EXCEEDED_MAX_SIZE="you exceeded the maximum upload size!"
Const SU_DEBUG_MODE=False
Class ShadowUpload
Private m_Request
Private m_Files
Private m_Error
Public Property Get GetError
GetError = m_Error
End Property
Public Property Get FileCount
FileCount = m_Files.Count
End Property
Public Function File(index)
Dim keys
keys = m_Files.Keys
Set File = m_Files(keys(index))
End Function
Public Default Property Get Item(strName)
If m_Request.Exists(strName) Then
Item = m_Request(strName)
Else
Item = ""
End If
End Property
Private Sub Class_Initialize
Dim iBytesCount, strBinData
'first of all, get amount of uploaded bytes:
iBytesCount = Request.TotalBytes
WriteDebug("initializing upload, bytes: " & iBytesCount & "<br />")
'abort if nothing there:
If iBytesCount=0 Then
m_Error = MSG_NO_DATA
Exit Sub
End If
'abort if exceeded maximum upload size:
If iBytesCount>MAX_UPLOAD_SIZE Then
m_Error = MSG_EXCEEDED_MAX_SIZE
Exit Sub
End If
'read the binary data:
strBinData = Request.BinaryRead(iBytesCount)
'create private collections:
Set m_Request = Server.CreateObject("Scripting.Dictionary")
Set m_Files = Server.CreateObject("Scripting.Dictionary")
'populate the collection:
Call BuildUpload(strBinData)
End Sub
Private Sub Class_Terminate
Dim fileName
If IsObject(m_Request) Then
m_Request.RemoveAll
Set m_Request = Nothing
End If
If IsObject(m_Files) Then
For Each fileName In m_Files.Keys
Set m_Files(fileName)=Nothing
Next
m_Files.RemoveAll
Set m_Files = Nothing
End If
End Sub
Private Sub BuildUpload(ByVal strBinData)
Dim strBinQuote, strBinCRLF, iValuePos
Dim iPosBegin, iPosEnd, strBoundaryData
Dim strBoundaryEnd, iCurPosition, iBoundaryEndPos
Dim strElementName, strFileName, objFileData
Dim strFileType, strFileData, strElementValue
strBinQuote = AsciiToBinary(chr(34))
strBinCRLF = AsciiToBinary(chr(13))
'find the boundaries
iPosBegin = 1
iPosEnd = InstrB(iPosBegin, strBinData, strBinCRLF)
strBoundaryData = MidB(strBinData, iPosBegin, iPosEnd-iPosBegin)
iCurPosition = InstrB(1, strBinData, strBoundaryData)
strBoundaryEnd = strBoundaryData & AsciiToBinary("--")
iBoundaryEndPos = InstrB(strBinData, strBoundaryEnd)
'read binary data into private collection:
Do until (iCurPosition>=iBoundaryEndPos) Or (iCurPosition=0)
'skip non relevant data...
iPosBegin = InstrB(iCurPosition, strBinData, AsciiToBinary("Content-Disposition"))
iPosBegin = InstrB(iPosBegin, strBinData, AsciiToBinary("name="))
iValuePos = iPosBegin
'read the name of the form element, e.g. "file1", "text1"
iPosBegin = iPosBegin+6
iPosEnd = InstrB(iPosBegin, strBinData, strBinQuote)
strElementName = BinaryToAscii(MidB(strBinData, iPosBegin, iPosEnd-iPosBegin))
'maybe file?
iPosBegin = InstrB(iCurPosition, strBinData, AsciiToBinary("filename="))
iPosEnd = InstrB(iPosEnd, strBinData, strBoundaryData)
If (iPosBegin>0) And (iPosBegin<iPosEnd) Then
'skip non relevant data..
iPosBegin = iPosBegin+10
'read file name:
iPosEnd = InstrB(iPosBegin, strBinData, strBinQuote)
strFileName = BinaryToAscii(MidB(strBinData, iPosBegin, iPosEnd-iPosBegin))
'verify that we got name:
If Len(strFileName)>0 Then
'create file data:
Set objFileData = New FileData
objFileData.FileName = strFileName
'read file type:
iPosBegin = InstrB(iPosEnd, strBinData, AsciiToBinary("Content-Type:"))
iPosBegin = iPosBegin+14
iPosEnd = InstrB(iPosBegin, strBinData, strBinCRLF)
strFileType = BinaryToAscii(MidB(strBinData, iPosBegin, iPosEnd-iPosBegin))
objFileData.ContentType = strFileType
'read file contents:
iPosBegin = iPosEnd+4
iPosEnd = InstrB(iPosBegin, strBinData, strBoundaryData)-2
strFileData = MidB(strBinData, iPosBegin, iPosEnd-iPosBegin)
'check that not empty:
If LenB(strFileData)>0 Then
objFileData.Contents = strFileData
'append to files collection if not empty:
Set m_Files(strFileName) = objFileData
Else
Set objFileData = Nothing
End If
End If
strElementValue = strFileName
Else
'ordinary form value, just read:
iPosBegin = InstrB(iValuePos, strBinData, strBinCRLF)
iPosBegin = iPosBegin+4
iPosEnd = InstrB(iPosBegin, strBinData, strBoundaryData)-2
strElementValue = BinaryToAscii(MidB(strBinData, iPosBegin, iPosEnd-iPosBegin))
End If
'append to request collection
m_Request(strElementName) = strElementValue
'skip to next element:
iCurPosition = InstrB(iCurPosition+LenB(strBoundaryData), strBinData, strBoundaryData)
Loop
End Sub
Private Function WriteDebug(msg)
If SU_DEBUG_MODE Then
Response.Write(msg)
Response.Flush
End If
End Function
Private Function AsciiToBinary(strAscii)
Dim i, char, result
result = ""
For i=1 to Len(strAscii)
char = Mid(strAscii, i, 1)
result = result & chrB(AscB(char))
Next
AsciiToBinary = result
End Function
Private Function BinaryToAscii(strBinary)
Dim i, result
result = ""
For i=1 to LenB(strBinary)
result = result & chr(AscB(MidB(strBinary, i, 1)))
Next
BinaryToAscii = result
End Function
End Class
Class FileData
Private m_fileName
Private m_contentType
Private m_BinaryContents
Private m_AsciiContents
Private m_imageWidth
Private m_imageHeight
Private m_checkImage
Public Property Get FileName
FileName = m_fileName
End Property
Public Property Get ContentType
ContentType = m_contentType
End Property
Public Property Get ImageWidth
If m_checkImage=False Then Call CheckImageDimensions
ImageWidth = m_imageWidth
End Property
Public Property Get ImageHeight
If m_checkImage=False Then Call CheckImageDimensions
ImageHeight = m_imageHeight
End Property
Public Property Let FileName(strName)
Dim arrTemp
arrTemp = Split(strName, "\")
m_fileName = arrTemp(UBound(arrTemp))
End Property
Public Property Let CheckImage(blnCheck)
m_checkImage = blnCheck
End Property
Public Property Let ContentType(strType)
m_contentType = strType
End Property
Public Property Let Contents(strData)
m_BinaryContents = strData
m_AsciiContents = RSBinaryToString(m_BinaryContents)
End Property
Public Property Get Size
Size = LenB(m_BinaryContents)
End Property
Private Sub CheckImageDimensions
Dim width, height, colors
Dim strType
'''If gfxSpex(BinaryToAscii(m_BinaryContents), width, height, colors, strType) = true then
If gfxSpex(m_AsciiContents, width, height, colors, strType) = true then
m_imageWidth = width
m_imageHeight = height
End If
m_checkImage = True
End Sub
Private Sub Class_Initialize
m_imageWidth = -1
m_imageHeight = -1
m_checkImage = False
End Sub
Public Sub SaveToDisk(strFolderPath, ByRef strNewFileName)
Dim strPath, objFSO, objFile
Dim i, time1, time2
Dim objStream, strExtension
strPath = strFolderPath&"\"
If Len(strNewFileName)=0 Then
strPath = strPath & m_fileName
Else
strExtension = GetExtension(strNewFileName)
If Len(strExtension)=0 Then
strNewFileName = strNewFileName & "." & GetExtension(m_fileName)
End If
strPath = strPath & strNewFileName
End If
WriteDebug("save file started...<br />")
time1 = CDbl(Timer)
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.CreateTextFile(strPath)
objFile.Write(m_AsciiContents)
'''For i=1 to LenB(m_BinaryContents)
''' objFile.Write chr(AscB(MidB(m_BinaryContents, i, 1)))
'''Next
time2 = CDbl(Timer)
WriteDebug("saving file took " & (time2-time1) & " seconds.<br />")
objFile.Close
Set objFile=Nothing
Set objFSO=Nothing
End Sub
Private Function GetExtension(strPath)
Dim arrTemp
arrTemp = Split(strPath, ".")
GetExtension = ""
If UBound(arrTemp)>0 Then
GetExtension = arrTemp(UBound(arrTemp))
End If
End Function
Private Function RSBinaryToString(xBinary)
'Antonin Foller, http://www.motobit.com
'RSBinaryToString converts binary data (VT_UI1 | VT_ARRAY Or MultiByte string)
'to a string (BSTR) using ADO recordset
Dim Binary
'MultiByte data must be converted To VT_UI1 | VT_ARRAY first.
If vartype(xBinary)=8 Then Binary = MultiByteToBinary(xBinary) Else Binary = xBinary
Dim RS, LBinary
Const adLongVarChar = 201
Set RS = CreateObject("ADODB.Recordset")
LBinary = LenB(Binary)
If LBinary>0 Then
RS.Fields.Append "mBinary", adLongVarChar, LBinary
RS.Open
RS.AddNew
RS("mBinary").AppendChunk Binary
RS.Update
RSBinaryToString = RS("mBinary")
Else
RSBinaryToString = ""
End If
End Function
Function MultiByteToBinary(MultiByte)
'© 2000 Antonin Foller, http://www.motobit.com
' MultiByteToBinary converts multibyte string To real binary data (VT_UI1 | VT_ARRAY)
' Using recordset
Dim RS, LMultiByte, Binary
Const adLongVarBinary = 205
Set RS = CreateObject("ADODB.Recordset")
LMultiByte = LenB(MultiByte)
If LMultiByte>0 Then
RS.Fields.Append "mBinary", adLongVarBinary, LMultiByte
RS.Open
RS.AddNew
RS("mBinary").AppendChunk MultiByte & ChrB(0)
RS.Update
Binary = RS("mBinary").GetChunk(LMultiByte)
End If
MultiByteToBinary = Binary
End Function
Private Function WriteDebug(msg)
If SU_DEBUG_MODE Then
Response.Write(msg)
Response.Flush
End If
End Function
Private Function BinaryToAscii(strBinary)
Dim i, result
result = ""
For i=1 to LenB(strBinary)
result = result & chr(AscB(MidB(strBinary, i, 1)))
Next
BinaryToAscii = result
End Function
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::: :::
'::: This routine will attempt to identify any filespec passed :::
'::: as a graphic file (regardless of the extension). This will :::
'::: work with BMP, GIF, JPG and PNG files. :::
'::: :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::: Based on ideas presented by David Crowell :::
'::: (credit where due) :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::: blah blah blah blah blah blah blah blah blah blah blah blah :::
'::: blah blah blah blah blah blah blah blah blah blah blah blah :::
'::: blah blah Copyright *c* MM, Mike Shaffer blah blah :::
'::: bh blah ALL RIGHTS RESERVED WORLDWIDE blah blah :::
'::: blah blah Permission is granted to use this code blah blah :::
'::: blah blah in your projects, as long as this blah blah :::
'::: blah blah copyright notice is included blah blah :::
'::: blah blah blah blah blah blah blah blah blah blah blah blah :::
'::: blah blah blah blah blah blah blah blah blah blah blah blah :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::: :::
'::: This function gets a specified number of bytes from any :::
'::: file, starting at the offset (base 1) :::
'::: :::
'::: Passed: :::
'::: flnm => Filespec of file to read :::
'::: offset => Offset at which to start reading :::
'::: bytes => How many bytes to read :::
'::: :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Private Function GetBytes(flnm, offset, bytes)
Dim startPos
If offset=0 Then
startPos = 1
Else
startPos = offset
End If
if bytes = -1 then ' Get All!
GetBytes = flnm
else
GetBytes = Mid(flnm, startPos, bytes)
end if
' Dim objFSO
' Dim objFTemp
' Dim objTextStream
' Dim lngSize
'
' Set objFSO = CreateObject("Scripting.FileSystemObject")
'
' ' First, we get the filesize
' Set objFTemp = objFSO.GetFile(flnm)
' lngSize = objFTemp.Size
' set objFTemp = nothing
'
' fsoForReading = 1
' Set objTextStream = objFSO.OpenTextFile(flnm, fsoForReading)
'
' if offset > 0 then
' strBuff = objTextStream.Read(offset - 1)
' end if
'
' if bytes = -1 then ' Get All!
' GetBytes = objTextStream.Read(lngSize) 'ReadAll
' else
' GetBytes = objTextStream.Read(bytes)
' end if
'
' objTextStream.Close
' set objTextStream = nothing
' set objFSO = nothing
End Function
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::: :::
'::: Functions to convert two bytes to a numeric value (long) :::
'::: (both little-endian and big-endian) :::
'::: :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Private Function lngConvert(strTemp)
lngConvert = clng(asc(left(strTemp, 1)) + ((asc(right(strTemp, 1)) * 256)))
end function
Private Function lngConvert2(strTemp)
lngConvert2 = clng(asc(right(strTemp, 1)) + ((asc(left(strTemp, 1)) * 256)))
end function
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::: :::
'::: This function does most of the real work. It will attempt :::
'::: to read any file, regardless of the extension, and will :::
'::: identify if it is a graphical image. :::
'::: :::
'::: Passed: :::
'::: flnm => Filespec of file to read :::
'::: width => width of image :::
'::: height => height of image :::
'::: depth => color depth (in number of colors) :::
'::: strImageType=> type of image (e.g. GIF, BMP, etc.) :::
'::: :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
function gfxSpex(flnm, width, height, depth, strImageType)
dim strPNG
dim strGIF
dim strBMP
dim strType
dim strBuff
dim lngSize
dim flgFound
dim strTarget
dim lngPos
dim ExitLoop
dim lngMarkerSize
strType = ""
strImageType = "(unknown)"
gfxSpex = False
strPNG = chr(137) & chr(80) & chr(78)
strGIF = "GIF"
strBMP = chr(66) & chr(77)
strType = GetBytes(flnm, 0, 3)
if strType = strGIF then ' is GIF
strImageType = "GIF"
Width = lngConvert(GetBytes(flnm, 7, 2))
Height = lngConvert(GetBytes(flnm, 9, 2))
Depth = 2 ^ ((asc(GetBytes(flnm, 11, 1)) and 7) + 1)
gfxSpex = True
elseif left(strType, 2) = strBMP then ' is BMP
strImageType = "BMP"
Width = lngConvert(GetBytes(flnm, 19, 2))
Height = lngConvert(GetBytes(flnm, 23, 2))
Depth = 2 ^ (asc(GetBytes(flnm, 29, 1)))
gfxSpex = True
elseif strType = strPNG then ' Is PNG
strImageType = "PNG"
Width = lngConvert2(GetBytes(flnm, 19, 2))
Height = lngConvert2(GetBytes(flnm, 23, 2))
Depth = getBytes(flnm, 25, 2)
select case asc(right(Depth,1))
case 0
Depth = 2 ^ (asc(left(Depth, 1)))
gfxSpex = True
case 2
Depth = 2 ^ (asc(left(Depth, 1)) * 3)
gfxSpex = True
case 3
Depth = 2 ^ (asc(left(Depth, 1))) '8
gfxSpex = True
case 4
Depth = 2 ^ (asc(left(Depth, 1)) * 2)
gfxSpex = True
case 6
Depth = 2 ^ (asc(left(Depth, 1)) * 4)
gfxSpex = True
case else
Depth = -1
end select
else
strBuff = GetBytes(flnm, 0, -1) ' Get all bytes from file
lngSize = len(strBuff)
flgFound = 0
strTarget = chr(255) & chr(216) & chr(255)
flgFound = instr(strBuff, strTarget)
if flgFound = 0 then
exit function
end if
strImageType = "JPG"
lngPos = flgFound + 2
ExitLoop = false
do while ExitLoop = False and lngPos < lngSize
do while asc(mid(strBuff, lngPos, 1)) = 255 and lngPos < lngSize
lngPos = lngPos + 1
loop
if asc(mid(strBuff, lngPos, 1)) < 192 or asc(mid(strBuff, lngPos, 1)) > 195 then
lngMarkerSize = lngConvert2(mid(strBuff, lngPos + 1, 2))
lngPos = lngPos + lngMarkerSize + 1
else
ExitLoop = True
end if
loop
if ExitLoop = False then
Width = -1
Height = -1
Depth = -1
else
Height = lngConvert2(mid(strBuff, lngPos + 4, 2))
Width = lngConvert2(mid(strBuff, lngPos + 6, 2))
Depth = 2 ^ (asc(mid(strBuff, lngPos + 8, 1)) * 8)
gfxSpex = True
end if
end if
End Function
End Class
%>
Constants explained:
MAX_UPLOAD_SIZE - maximum size, in bytes, of all uploaded files. When exceeding that size the upload process is aborted and global error is set to the constant MSG_EXCEEDED_MAX_SIZE.
MSG_NO_DATA - when user does not choose any file to upload, global error will be set to that constant.
SU_DEBUG_MODE - when set to True the script will output various messages via Response.Write(), useful for debugging problems.
Simple use case: (full code)
<!-- #include file="ShadowUpload.asp" -->
<%
Dim objUpload
If Request("action")="1" Then
Set objUpload=New ShadowUpload
If objUpload.GetError<>"" Then
Response.Write("sorry, could not upload: "&objUpload.GetError)
Else
Response.Write("found "&objUpload.FileCount&" files...<br />")
For x=0 To objUpload.FileCount-1
Response.Write("file name: "&objUpload.File(x).FileName&"<br />")
Response.Write("file type: "&objUpload.File(x).ContentType&"<br />")
Response.Write("file size: "&objUpload.File(x).Size&"<br />")
Response.Write("image width: "&objUpload.File(x).ImageWidth&"<br />")
Response.Write("image height: "&objUpload.File(x).ImageHeight&"<br />")
If (objUpload.File(x).ImageWidth>200) Or (objUpload.File(x).ImageHeight>200) Then
Response.Write("image to big, not saving!")
Else
Call objUpload.File(x).SaveToDisk(Server.MapPath("Uploads"), "")
Response.Write("file saved successfully!")
End If
Response.Write("<hr />")
Next
Response.Write("thank you, "&objUpload("name"))
End If
End If
%>
<form action="<%=Request.ServerVariables( "Script_Name" )%>?action=1" enctype="multipart/form-data" method="POST">
File1: <input type="file" name="file1" /><br />
File2: <input type="file" name="file2" /><br />
File3: <input type="file" name="file3" /><br />
Name: <input type="text" name="name" /><br />
<button type="submit">Upload</button>
</form>
This demonstrates using most of the script features, to block non image files from uploading you can just have something like:
If objUpload.File(x).ImageWidth<0 Then
Response.Write("Not a valid image!")
Else
'proceed to save the file...
End If
Disclaimer: This was originally posted here seven years ago and as credited in the code itself, contains parts not written by me.
Note for clients using Chrome browser on android device:
For some reason, the standard <button> element of type submit appears not to work properly in Chrome for android. If you get complaints from clients about it, try changing this line in the form:
<button type="submit">Upload</button>
to this instead:
<input type="submit" value="Upload" />
Due to possible bug in the Chrome app for android, when using the phone's camera app to take a new image then trying to submit this image, it might fail. In such case just advice the client to use a different browser.

Answer 2

The code of #ShadowWizard is nice and run as a charme on a local machine, but I encountered uploading issues on a production server, then I rewrote the Class with a more robust parsing routine for the upload request.
The class can handle more errors right now and You can upload multiple files with a single INPUT element; save this as a new file and rename it as "uploadhelper.asp"
<%
Const MAX_UPLOAD_SIZE = 25000000 '25 MB
Const MSG_NO_DATA = "Nothing to upload."
Const MSG_EXCEEDED_MAX_SIZE = "You exceeded the maximum upload size."
Const MSG_BAD_REQUEST_METHOD = "Bad request method. Use the POST method."
Const MSG_BAD_ENCTYPE = "Bad encoding type. Use a ""multipart/form-data"" enctype."
Const MSG_ZERO_LENGTH = "Zero length request."
Class UploadHelper
Private m_Request
Private m_Files
Private m_Error
Public Property Get GetError
GetError = m_Error
End Property
Public Property Get FileCount
FileCount = m_Files.Count
End Property
Public Function File(index)
If m_Files.Exists(index) Then
Set File = m_Files(index)
Else
Set File = Nothing
End If
End Function
Public Default Property Get Item(strName)
If m_Request.Exists(strName) Then
Item = m_Request(strName)
Else
Item = ""
End If
End Property
Private Sub Class_Initialize
Dim iBytesCount, strBinData
'first of all, get amount of uploaded bytes:
iBytesCount = Request.TotalBytes
'abort if nothing there:
If iBytesCount = 0 Then
m_Error = MSG_NO_DATA
Exit Sub
End If
'abort if exceeded maximum upload size:
If iBytesCount > MAX_UPLOAD_SIZE Then
m_Error = MSG_EXCEEDED_MAX_SIZE
Exit Sub
End If
If Request.ServerVariables("REQUEST_METHOD") = "POST" Then
Dim CT, PosB, Boundary, PosE
CT = Request.ServerVariables("HTTP_Content_Type")
If LCase(Left(CT, 19)) = "multipart/form-data" Then
PosB = InStr(LCase(CT), "boundary=")
If PosB > 0 Then Boundary = Mid(CT, PosB + 9)
PosB = InStr(LCase(CT), "boundary=")
If PosB > 0 Then
PosB = InStr(Boundary, ",")
If PosB > 0 Then Boundary = Left(Boundary, PosB - 1)
End If
If iBytesCount > 0 And Boundary <> "" Then
Boundary = "--" & Boundary
Dim Head, Binary
Binary = Request.BinaryRead(iBytesCount)
'create private collections:
Set m_Request = Server.CreateObject("Scripting.Dictionary")
Set m_Files = Server.CreateObject("Scripting.Dictionary")
Call ParseRequest(Binary, Boundary)
Binary = Empty
Else
m_Error = MSG_ZERO_LENGTH
Exit Sub
End If
Else
m_Error = MSG_BAD_ENCTYPE
Exit Sub
End If
Else
m_Error = MSG_BAD_REQUEST_METHOD
Exit Sub
End If
End Sub
Private Sub Class_Terminate
Dim fileName
If IsObject(m_Request) Then
m_Request.RemoveAll
Set m_Request = Nothing
End If
If IsObject(m_Files) Then
For Each fileName In m_Files.Keys
Set m_Files(fileName)=Nothing
Next
m_Files.RemoveAll
Set m_Files = Nothing
End If
End Sub
Private Sub ParseRequest(Binary, Boundary)
Dim PosOpenBoundary, PosCloseBoundary, PosEndOfHeader, isLastBoundary
Boundary = StringToBinary(Boundary)
PosOpenBoundary = InStrB(Binary, Boundary)
PosCloseBoundary = InStrB(PosOpenBoundary + LenB(Boundary), Binary, Boundary, 0)
Dim HeaderContent, FieldContent, bFieldContent
Dim Content_Disposition, FormFieldName, SourceFileName, Content_Type
Dim TwoCharsAfterEndBoundary, n : n = 0
Do While (PosOpenBoundary > 0 And PosCloseBoundary > 0 And Not isLastBoundary)
PosEndOfHeader = InStrB(PosOpenBoundary + Len(Boundary), Binary, StringToBinary(vbCrLf + vbCrLf))
HeaderContent = MidB(Binary, PosOpenBoundary + LenB(Boundary) + 2, PosEndOfHeader - PosOpenBoundary - LenB(Boundary) - 2)
bFieldContent = MidB(Binary, (PosEndOfHeader + 4), PosCloseBoundary - (PosEndOfHeader + 4) - 2)
GetHeadFields BinaryToString(HeaderContent), Content_Disposition, FormFieldName, SourceFileName, Content_Type
Set objFileData = New FileData
objFileData.FileName = SourceFileName
objFileData.ContentType = Content_Type
objFileData.Contents = bFieldContent
objFileData.FormFieldName = FormFieldName
objFileData.ContentDisposition = Content_Disposition
Set m_Files(n) = objFileData
Set objFileData = Nothing
TwoCharsAfterEndBoundary = BinaryToString(MidB(Binary, PosCloseBoundary + LenB(Boundary), 2))
isLastBoundary = TwoCharsAfterEndBoundary = "--"
If Not isLastBoundary Then
PosOpenBoundary = PosCloseBoundary
PosCloseBoundary = InStrB(PosOpenBoundary + LenB(Boundary), Binary, Boundary)
End If
n = n + 1
Loop
End Sub
Private Function GetHeadFields(ByVal Head, Content_Disposition, Name, FileName, Content_Type)
Content_Disposition = LTrim(SeparateField(Head, "content-disposition:", ";"))
Name = (SeparateField(Head, "name=", ";"))
If Left(Name, 1) = """" Then Name = Mid(Name, 2, Len(Name) - 2)
FileName = (SeparateField(Head, "filename=", ";"))
If Left(FileName, 1) = """" Then FileName = Mid(FileName, 2, Len(FileName) - 2)
Content_Type = LTrim(SeparateField(Head, "content-type:", ";"))
End Function
Private Function SeparateField(From, ByVal sStart, ByVal sEnd)
Dim PosB, PosE, sFrom
sFrom = LCase(From)
PosB = InStr(sFrom, sStart)
If PosB > 0 Then
PosB = PosB + Len(sStart)
PosE = InStr(PosB, sFrom, sEnd)
If PosE = 0 Then PosE = InStr(PosB, sFrom, vbCrLf)
If PosE = 0 Then PosE = Len(sFrom) + 1
SeparateField = Mid(From, PosB, PosE - PosB)
Else
SeparateField = Empty
End If
End Function
Private Function BinaryToString(Binary)
dim cl1, cl2, cl3, pl1, pl2, pl3
Dim L
cl1 = 1
cl2 = 1
cl3 = 1
L = LenB(Binary)
Do While cl1<=L
pl3 = pl3 & Chr(AscB(MidB(Binary,cl1,1)))
cl1 = cl1 + 1
cl3 = cl3 + 1
if cl3>300 then
pl2 = pl2 & pl3
pl3 = ""
cl3 = 1
cl2 = cl2 + 1
if cl2>200 then
pl1 = pl1 & pl2
pl2 = ""
cl2 = 1
End If
End If
Loop
BinaryToString = pl1 & pl2 & pl3
End Function
Private Function StringToBinary(String)
Dim I, B
For I=1 to len(String)
B = B & ChrB(Asc(Mid(String,I,1)))
Next
StringToBinary = B
End Function
End Class
Class FileData
Private m_fileName
Private m_contentType
Private m_BinaryContents
Private m_AsciiContents
Private m_imageWidth
Private m_imageHeight
Private m_checkImage
Private m_formFieldName
Private m_contentDisposition
Public Property Get FormFieldName
FormFieldName = m_formFieldName
End Property
Public Property Let FormFieldName(sFieldName)
m_formFieldName = sFieldName
End Property
Public Property Get ContentDisposition
ContentDisposition = m_contentDisposition
End Property
Public Property Let ContentDisposition(sContentDisposition)
m_contentDisposition = sContentDisposition
End Property
Public Property Get FileName
FileName = m_fileName
End Property
Public Property Get ContentType
ContentType = m_contentType
End Property
Public Property Get ImageWidth
If m_checkImage=False Then Call CheckImageDimensions
ImageWidth = m_imageWidth
End Property
Public Property Get ImageHeight
If m_checkImage=False Then Call CheckImageDimensions
ImageHeight = m_imageHeight
End Property
Public Property Let FileName(ByVal strName)
strName = Replace(strName, "/", "\")
Dim arrTemp : arrTemp = Split(strName, "\")
m_fileName = arrTemp(UBound(arrTemp))
End Property
Public Property Let CheckImage(blnCheck)
m_checkImage = blnCheck
End Property
Public Property Let ContentType(strType)
m_contentType = strType
End Property
Public Property Let Contents(strData)
m_BinaryContents = strData
m_AsciiContents = RSBinaryToString(m_BinaryContents)
End Property
Public Property Get Size
Size = LenB(m_BinaryContents)
End Property
Private Sub CheckImageDimensions
Dim width, height, colors
Dim strType
'''If gfxSpex(BinaryToAscii(m_BinaryContents), width, height, colors, strType) = true then
If gfxSpex(m_AsciiContents, width, height, colors, strType) = true then
m_imageWidth = width
m_imageHeight = height
End If
m_checkImage = True
End Sub
Private Sub Class_Initialize
m_imageWidth = -1
m_imageHeight = -1
m_checkImage = False
End Sub
Public Sub SaveToDisk(strFolderPath, ByRef strNewFileName)
Dim strPath, objFSO, objFile
Dim i, time1, time2
Dim objStream, strExtension
strPath = strFolderPath&"\"
If Len(strNewFileName)=0 Then
strPath = strPath & m_fileName
Else
strExtension = GetExtension(strNewFileName)
If Len(strExtension)=0 Then
strNewFileName = strNewFileName & "." & GetExtension(m_fileName)
End If
strPath = strPath & strNewFileName
End If
time1 = CDbl(Timer)
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.CreateTextFile(strPath)
objFile.Write(m_AsciiContents)
'''For i=1 to LenB(m_BinaryContents)
''' objFile.Write chr(AscB(MidB(m_BinaryContents, i, 1)))
'''Next
time2 = CDbl(Timer)
objFile.Close
Set objFile=Nothing
Set objFSO=Nothing
End Sub
Private Function GetExtension(strPath)
Dim arrTemp
arrTemp = Split(strPath, ".")
GetExtension = ""
If UBound(arrTemp)>0 Then
GetExtension = arrTemp(UBound(arrTemp))
End If
End Function
Private Function RSBinaryToString(xBinary)
'Antonin Foller, http://www.motobit.com
'RSBinaryToString converts binary data (VT_UI1 | VT_ARRAY Or MultiByte string)
'to a string (BSTR) using ADO recordset
Dim Binary
'MultiByte data must be converted To VT_UI1 | VT_ARRAY first.
If vartype(xBinary)=8 Then Binary = MultiByteToBinary(xBinary) Else Binary = xBinary
Dim RS, LBinary
Const adLongVarChar = 201
Set RS = CreateObject("ADODB.Recordset")
LBinary = LenB(Binary)
If LBinary>0 Then
RS.Fields.Append "mBinary", adLongVarChar, LBinary
RS.Open
RS.AddNew
RS("mBinary").AppendChunk Binary
RS.Update
RSBinaryToString = RS("mBinary")
Else
RSBinaryToString = ""
End If
End Function
Function MultiByteToBinary(MultiByte)
'© 2000 Antonin Foller, http://www.motobit.com
' MultiByteToBinary converts multibyte string To real binary data (VT_UI1 | VT_ARRAY)
' Using recordset
Dim RS, LMultiByte, Binary
Const adLongVarBinary = 205
Set RS = CreateObject("ADODB.Recordset")
LMultiByte = LenB(MultiByte)
If LMultiByte>0 Then
RS.Fields.Append "mBinary", adLongVarBinary, LMultiByte
RS.Open
RS.AddNew
RS("mBinary").AppendChunk MultiByte & ChrB(0)
RS.Update
Binary = RS("mBinary").GetChunk(LMultiByte)
End If
MultiByteToBinary = Binary
End Function
Private Function BinaryToAscii(strBinary)
Dim i, result
result = ""
For i=1 to LenB(strBinary)
result = result & chr(AscB(MidB(strBinary, i, 1)))
Next
BinaryToAscii = result
End Function
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::: :::
'::: This routine will attempt to identify any filespec passed :::
'::: as a graphic file (regardless of the extension). This will :::
'::: work with BMP, GIF, JPG and PNG files. :::
'::: :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::: Based on ideas presented by David Crowell :::
'::: (credit where due) :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::: blah blah blah blah blah blah blah blah blah blah blah blah :::
'::: blah blah blah blah blah blah blah blah blah blah blah blah :::
'::: blah blah Copyright *c* MM, Mike Shaffer blah blah :::
'::: bh blah ALL RIGHTS RESERVED WORLDWIDE blah blah :::
'::: blah blah Permission is granted to use this code blah blah :::
'::: blah blah in your projects, as long as this blah blah :::
'::: blah blah copyright notice is included blah blah :::
'::: blah blah blah blah blah blah blah blah blah blah blah blah :::
'::: blah blah blah blah blah blah blah blah blah blah blah blah :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::: :::
'::: This function gets a specified number of bytes from any :::
'::: file, starting at the offset (base 1) :::
'::: :::
'::: Passed: :::
'::: flnm => Filespec of file to read :::
'::: offset => Offset at which to start reading :::
'::: bytes => How many bytes to read :::
'::: :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Private Function GetBytes(flnm, offset, bytes)
Dim startPos
If offset=0 Then
startPos = 1
Else
startPos = offset
End If
if bytes = -1 then ' Get All!
GetBytes = flnm
else
GetBytes = Mid(flnm, startPos, bytes)
end if
' Dim objFSO
' Dim objFTemp
' Dim objTextStream
' Dim lngSize
'
' Set objFSO = CreateObject("Scripting.FileSystemObject")
'
' ' First, we get the filesize
' Set objFTemp = objFSO.GetFile(flnm)
' lngSize = objFTemp.Size
' set objFTemp = nothing
'
' fsoForReading = 1
' Set objTextStream = objFSO.OpenTextFile(flnm, fsoForReading)
'
' if offset > 0 then
' strBuff = objTextStream.Read(offset - 1)
' end if
'
' if bytes = -1 then ' Get All!
' GetBytes = objTextStream.Read(lngSize) 'ReadAll
' else
' GetBytes = objTextStream.Read(bytes)
' end if
'
' objTextStream.Close
' set objTextStream = nothing
' set objFSO = nothing
End Function
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::: :::
'::: Functions to convert two bytes to a numeric value (long) :::
'::: (both little-endian and big-endian) :::
'::: :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Private Function lngConvert(strTemp)
lngConvert = clng(asc(left(strTemp, 1)) + ((asc(right(strTemp, 1)) * 256)))
end function
Private Function lngConvert2(strTemp)
lngConvert2 = clng(asc(right(strTemp, 1)) + ((asc(left(strTemp, 1)) * 256)))
end function
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::: :::
'::: This function does most of the real work. It will attempt :::
'::: to read any file, regardless of the extension, and will :::
'::: identify if it is a graphical image. :::
'::: :::
'::: Passed: :::
'::: flnm => Filespec of file to read :::
'::: width => width of image :::
'::: height => height of image :::
'::: depth => color depth (in number of colors) :::
'::: strImageType=> type of image (e.g. GIF, BMP, etc.) :::
'::: :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
function gfxSpex(flnm, width, height, depth, strImageType)
dim strPNG
dim strGIF
dim strBMP
dim strType
dim strBuff
dim lngSize
dim flgFound
dim strTarget
dim lngPos
dim ExitLoop
dim lngMarkerSize
strType = ""
strImageType = "(unknown)"
gfxSpex = False
strPNG = chr(137) & chr(80) & chr(78)
strGIF = "GIF"
strBMP = chr(66) & chr(77)
strType = GetBytes(flnm, 0, 3)
if strType = strGIF then ' is GIF
strImageType = "GIF"
Width = lngConvert(GetBytes(flnm, 7, 2))
Height = lngConvert(GetBytes(flnm, 9, 2))
Depth = 2 ^ ((asc(GetBytes(flnm, 11, 1)) and 7) + 1)
gfxSpex = True
elseif left(strType, 2) = strBMP then ' is BMP
strImageType = "BMP"
Width = lngConvert(GetBytes(flnm, 19, 2))
Height = lngConvert(GetBytes(flnm, 23, 2))
Depth = 2 ^ (asc(GetBytes(flnm, 29, 1)))
gfxSpex = True
elseif strType = strPNG then ' Is PNG
strImageType = "PNG"
Width = lngConvert2(GetBytes(flnm, 19, 2))
Height = lngConvert2(GetBytes(flnm, 23, 2))
Depth = getBytes(flnm, 25, 2)
select case asc(right(Depth,1))
case 0
Depth = 2 ^ (asc(left(Depth, 1)))
gfxSpex = True
case 2
Depth = 2 ^ (asc(left(Depth, 1)) * 3)
gfxSpex = True
case 3
Depth = 2 ^ (asc(left(Depth, 1))) '8
gfxSpex = True
case 4
Depth = 2 ^ (asc(left(Depth, 1)) * 2)
gfxSpex = True
case 6
Depth = 2 ^ (asc(left(Depth, 1)) * 4)
gfxSpex = True
case else
Depth = -1
end select
else
strBuff = GetBytes(flnm, 0, -1) ' Get all bytes from file
lngSize = len(strBuff)
flgFound = 0
strTarget = chr(255) & chr(216) & chr(255)
flgFound = instr(strBuff, strTarget)
if flgFound = 0 then
exit function
end if
strImageType = "JPG"
lngPos = flgFound + 2
ExitLoop = false
do while ExitLoop = False and lngPos < lngSize
do while asc(mid(strBuff, lngPos, 1)) = 255 and lngPos < lngSize
lngPos = lngPos + 1
loop
if asc(mid(strBuff, lngPos, 1)) < 192 or asc(mid(strBuff, lngPos, 1)) > 195 then
lngMarkerSize = lngConvert2(mid(strBuff, lngPos + 1, 2))
lngPos = lngPos + lngMarkerSize + 1
else
ExitLoop = True
end if
loop
if ExitLoop = False then
Width = -1
Height = -1
Depth = -1
else
Height = lngConvert2(mid(strBuff, lngPos + 4, 2))
Width = lngConvert2(mid(strBuff, lngPos + 6, 2))
Depth = 2 ^ (asc(mid(strBuff, lngPos + 8, 1)) * 8)
gfxSpex = True
end if
end if
End Function
End Class
%>
Usage: create a new *.asp file with the following code to upload your files.
<!-- #include file="uploadhelper.asp" -->
<!DOCTYPE html>
<html lang="en">
<head>
<meta charset="utf-8">
<meta http-equiv="X-UA-Compatible" content="IE=edge">
<meta name="viewport" content="width=device-width, initial-scale=1">
<title></title>
</head>
<body>
<form action="<%=Request.ServerVariables("SCRIPT_NAME")%>?cmd=upload" method="POST" enctype="multipart/form-data">
File: <input type="file" name="files[]" multiple>
<input type="submit" value="Upload">
</form>
<%
If Request("cmd")="upload" Then
Dim objUpload : Set objUpload = New UploadHelper
If objUpload.GetError <> "" Then
Response.Write("Warning: "&objUpload.GetError)
Else
Response.Write("found "&objUpload.FileCount&" files...<br />")
Dim x : For x = 0 To objUpload.FileCount - 1
Response.Write("form field name: "&objUpload.File(x).FormFieldName&"<br />")
Response.Write("content disposition: "&objUpload.File(x).ContentDisposition&"<br />")
Response.Write("file name: "&objUpload.File(x).FileName&"<br />")
Response.Write("file type: "&objUpload.File(x).ContentType&"<br />")
Response.Write("file size: "&objUpload.File(x).Size&"<br />")
Response.Write("image width: "&objUpload.File(x).ImageWidth&"<br />")
Response.Write("image height: "&objUpload.File(x).ImageHeight&"<br />")
If (objUpload.File(x).ImageWidth>1024) Or (objUpload.File(x).ImageHeight>1024) Then
Response.Write("the image is too big, file not saved!")
Else
Call objUpload.File(x).SaveToDisk(Server.MapPath("/public"), "")
Response.Write("file saved successfully!")
End If
Response.Write("<hr />")
Next
End If
End If
%>
</body>
</html>

Answer 3

As a PPS, the problem might be a little more basic than you might think. IIS has a limit of 200K for a BinaryRead() function call. Has anyone come into this problem while trying to implement this solution?
Why wasn't the BinaryRead() limitation mentioned anywhere in the initial documentation? I've been struggling with this for over an hour.
This link on StackOverflow explains it: Request.BinaryRead(Request.TotalBytes) throws error for large files