Subversion Repositories DevTools

<!--METADATA

	TYPE="TypeLib"

	NAME="Microsoft ActiveX Data Objects 2.5 Library"

	UUID="{00000205-0000-0010-8000-00AA006D2EA4}"

	VERSION="2.5"

-->

<!--#INCLUDE FILE="clsField.asp"-->

<%

' ------------------------------------------------------------------------------

'	Author:		Lewis Moten

'	Email:		Lewis@Moten.com

'	URL:		http://www.lewismoten.com

'	Date:		March 19, 2002

' ------------------------------------------------------------------------------

' Upload class retrieves multi-part form data posted to web page

' and parses it into objects that are easy to interface with.

' Requires MDAC (ADODB) COM components found on most servers today

' Additional compenents are not necessary.

'

' Demo:

'	Set objUpload = new clsUpload

'		Initializes object and parses all posted multi-part from data.

'		Once this as been done, Access to the Request object is restricted

'

'	objUpload.Count

'		Number of fields retrieved

'

'		use: Response.Write "There are " & objUpload.Count & " fields."

'

'	objUpload.Fields

'		Access to field objects.  This is the default propert so it does

'		not necessarily have to be specified.  You can also determine if

'		you wish to specify the field index, or the field name.

'

'		Use:

'			Set objField = objUpload.Fields("File1")

'			Set objField = objUpload("File1")

'			Set objField = objUpload.Fields(0)

'			Set objField = objUpload(0)

'			Response.Write objUpload("File1").Name

'			Response.Write objUpload(0).Name

'

' ------------------------------------------------------------------------------

'

' List of all fields passed:

'

'	For i = 0 To objUpload.Count - 1

'		Response.Write objUpload(i).Name & "<BR>"

'	Next

'

' ------------------------------------------------------------------------------

'

' HTML needed to post multipart/form-data

'

'<FORM method="post" encType="multipart/form-data" action="Upload.asp">

'	<INPUT type="File" name="File1">

'	<INPUT type="Submit" value="Upload">

'</FORM>

Class clsUpload

' ------------------------------------------------------------------------------

	Private mbinData			' bytes visitor sent to server

	Private mlngChunkIndex		' byte where next chunk starts

	Private mlngBytesReceived	' length of data

	Private mstrDelimiter		' Delimiter between multipart/form-data (43 chars)

	Private CR					' ANSI Carriage Return

	Private LF					' ANSI Line Feed

	Private CRLF				' ANSI Carriage Return & Line Feed

	Private mobjFieldAry()		' Array to hold field objects

	Private mlngCount			' Number of fields parsed

' ------------------------------------------------------------------------------

	Private Sub RequestData

		Dim llngLength		' Number of bytes received

		' Determine number bytes visitor sent

		mlngBytesReceived = Request.TotalBytes

		' Store bytes recieved from visitor

		mbinData = Request.BinaryRead(mlngBytesReceived)

	End Sub

' ------------------------------------------------------------------------------

	Private Sub ParseDelimiter()

		' Delimiter seperates multiple pieces of form data

			' "around" 43 characters in length

			' next character afterwards is carriage return (except last line has two --)

			' first part of delmiter is dashes followed by hex number

			' hex number is possibly the browsers session id?

		' Examples:

		' -----------------------------7d230d1f940246

		' -----------------------------7d22ee291ae0114

		mstrDelimiter = MidB(mbinData, 1, InStrB(1, mbinData, CRLF) - 1)

	End Sub

' ------------------------------------------------------------------------------

	Private Sub ParseData()

		' This procedure loops through each section (chunk) found within the

		' delimiters and sends them to the parse chunk routine

		Dim llngStart	' start position of chunk data

		Dim llngLength	' Length of chunk

		Dim llngEnd		' Last position of chunk data

		Dim lbinChunk	' Binary contents of chunk

		' Initialize at first character

		llngStart = 1

		' Find start position

		llngStart = InStrB(llngStart, mbinData, mstrDelimiter & CRLF)

		' While the start posotion was found

		While Not llngStart = 0

			' Find the end position (after the start position)

			llngEnd = InStrB(llngStart + 1, mbinData, mstrDelimiter) - 2

			' Determine Length of chunk

			llngLength = llngEnd - llngStart

			' Pull out the chunk

			lbinChunk = MidB(mbinData, llngStart, llngLength)

			' Parse the chunk

			Call ParseChunk(lbinChunk)

			' Look for next chunk after the start position

			llngStart = InStrB(llngStart + 1, mbinData, mstrDelimiter & CRLF)

		Wend

	End Sub

' ------------------------------------------------------------------------------

	Private Sub ParseChunk(ByRef pbinChunk)

		' This procedure gets a chunk passed to it and parses its contents.

		' There is a general format that the chunk follows.

		' First, the deliminator appears

		' Next, headers are listed on each line that define properties of the chunk.

		'	Content-Disposition: form-data: name="File1"; filename="C:\Photo.gif"

		'	Content-Type: image/gif

		' After this, a blank line appears and is followed by the binary data.

		Dim lstrName			' Name of field

		Dim lstrFileName		' File name of binary data

		Dim lstrContentType		' Content type of binary data

		Dim lbinData			' Binary data

		Dim lstrDisposition		' Content Disposition

		Dim lstrValue			' Value of field

		' Parse out the content dispostion

		lstrDisposition = ParseDisposition(pbinChunk)

			' And Parse the Name

			lstrName = ParseName(lstrDisposition)

			' And the file name

			lstrFileName = ParseFileName(lstrDisposition)

		' Parse out the Content Type

		lstrContentType = ParseContentType(pbinChunk)

		' If the content type is not defined, then assume the

		' field is a normal form field

		If lstrContentType = "" Then

			' Parse Binary Data as Unicode

			lstrValue = CStrU(ParseBinaryData(pbinChunk))

		' Else assume the field is binary data

		Else

			' Parse Binary Data

			lbinData = ParseBinaryData(pbinChunk)

		End If

		' Add a new field

		Call AddField(lstrName, lstrFileName, lstrContentType, lstrValue, lbinData)

	End Sub

' ------------------------------------------------------------------------------

	Private Sub AddField(ByRef pstrName, ByRef pstrFileName, ByRef pstrContentType, ByRef pstrValue, ByRef pbinData)

		Dim lobjField		' Field object class

		' Add a new index to the field array

		' Make certain not to destroy current fields

		ReDim Preserve mobjFieldAry(mlngCount)

		' Create new field object

		Set lobjField = New clsField

		' Set field properties

		lobjField.Name = pstrName

		lobjField.FilePath = pstrFileName				

		lobjField.ContentType = pstrContentType

		' If field is not a binary file

		If LenB(pbinData) = 0 Then

			lobjField.BinaryData = ChrB(0)

			lobjField.Value = pstrValue

			lobjField.Length = Len(pstrValue)

		' Else field is a binary file

		Else

			lobjField.BinaryData = pbinData

			lobjField.Length = LenB(pbinData)

			lobjField.Value = ""

		End If

		' Set field array index to new field

		Set mobjFieldAry(mlngCount) = lobjField

		' Incriment field count

		mlngCount = mlngCount + 1

	End Sub

' ------------------------------------------------------------------------------

	Private Function ParseBinaryData(ByRef pbinChunk)

		' Parses binary content of the chunk

		Dim llngStart	' Start Position

		' Find first occurence of a blank line

		llngStart = InStrB(1, pbinChunk, CRLF & CRLF)

		' If it doesn't exist, then return nothing

		If llngStart = 0 Then Exit Function

		' Incriment start to pass carriage returns and line feeds

		llngStart = llngStart + 4

		' Return the last part of the chunk after the start position

		ParseBinaryData = MidB(pbinChunk, llngStart)

	End Function

' ------------------------------------------------------------------------------

	Private Function ParseContentType(ByRef pbinChunk)

		' Parses the content type of a binary file.

		'	example: image/gif is the content type of a GIF image.

		Dim llngStart	' Start Position

		Dim llngEnd		' End Position

		Dim llngLength	' Length

		' Fid the first occurance of a line starting with Content-Type:

		llngStart = InStrB(1, pbinChunk, CRLF & CStrB("Content-Type:"), vbTextCompare)

		' If not found, return nothing

		If llngStart = 0 Then Exit Function

		' Find the end of the line

		llngEnd = InStrB(llngStart + 15, pbinChunk, CR)

		' If not found, return nothing

		If llngEnd = 0 Then Exit Function

		' Adjust start position to start after the text "Content-Type:"

		llngStart = llngStart + 15

		' If the start position is the same or past the end, return nothing

		If llngStart >= llngEnd Then Exit Function

		' Determine length

		llngLength = llngEnd - llngStart

		' Pull out content type

		' Convert to unicode

		' Trim out whitespace

		' Return results

		ParseContentType = Trim(CStrU(MidB(pbinChunk, llngStart, llngLength)))

	End Function

' ------------------------------------------------------------------------------

	Private Function ParseDisposition(ByRef pbinChunk)

		' Parses the content-disposition from a chunk of data

		'

		' Example:

		'

		'	Content-Disposition: form-data: name="File1"; filename="C:\Photo.gif"

		'

		'	Would Return:

		'		form-data: name="File1"; filename="C:\Photo.gif"

		Dim llngStart	' Start Position

		Dim llngEnd		' End Position

		Dim llngLength	' Length

		' Find first occurance of a line starting with Content-Disposition:

		llngStart = InStrB(1, pbinChunk, CRLF & CStrB("Content-Disposition:"), vbTextCompare)

		' If not found, return nothing

		If llngStart = 0 Then Exit Function

		' Find the end of the line

		llngEnd = InStrB(llngStart + 22, pbinChunk, CRLF)

		' If not found, return nothing

		If llngEnd = 0 Then Exit Function

		' Adjust start position to start after the text "Content-Disposition:"

		llngStart = llngStart + 22

		' If the start position is the same or past the end, return nothing

		If llngStart >= llngEnd Then Exit Function

		' Determine Length

		llngLength = llngEnd - llngStart

		' Pull out content disposition

		' Convert to Unicode

		' Return Results

		ParseDisposition = CStrU(MidB(pbinChunk, llngStart, llngLength))

	End Function

' ------------------------------------------------------------------------------

	Private Function ParseName(ByRef pstrDisposition)

		' Parses the name of the field from the content disposition

		'

		' Example

		'

		'	form-data: name="File1"; filename="C:\Photo.gif"

		'

		'	Would Return:

		'		File1

		Dim llngStart	' Start Position

		Dim llngEnd		' End Position

		Dim llngLength	' Length

		' Find first occurance of text name="

		llngStart = InStr(1, pstrDisposition, "name=""", vbTextCompare)

		' If not found, return nothing

		If llngStart = 0 Then Exit Function

		' Find the closing quote

		llngEnd = InStr(llngStart + 6, pstrDisposition, """")

		' If not found, return nothing

		If llngEnd = 0 Then Exit Function

		' Adjust start position to start after the text name="

		llngStart = llngStart + 6

		' If the start position is the same or past the end, return nothing

		If llngStart >= llngEnd Then Exit Function

		' Determine Length

		llngLength = llngEnd - llngStart

		' Pull out field name

		' Return results

		ParseName = Mid(pstrDisposition, llngStart, llngLength)

	End Function

' ------------------------------------------------------------------------------

	Private Function ParseFileName(ByRef pstrDisposition)

		' Parses the name of the field from the content disposition

		'

		' Example

		'

		'	form-data: name="File1"; filename="C:\Photo.gif"

		'

		'	Would Return:

		'		C:\Photo.gif

		Dim llngStart	' Start Position

		Dim llngEnd		' End Position

		Dim llngLength	' Length

		' Find first occurance of text filename="

		llngStart = InStr(1, pstrDisposition, "filename=""", vbTextCompare)

		' If not found, return nothing

		If llngStart = 0 Then Exit Function

		' Find the closing quote

		llngEnd = InStr(llngStart + 10, pstrDisposition, """")

		' If not found, return nothing

		If llngEnd = 0 Then Exit Function

		' Adjust start position to start after the text filename="

		llngStart = llngStart + 10

		' If the start position is the same of past the end, return nothing

		If llngStart >= llngEnd Then Exit Function

		' Determine length

		llngLength = llngEnd - llngStart

		' Pull out file name

		' Return results

		ParseFileName = Mid(pstrDisposition, llngStart, llngLength)

	End Function

' ------------------------------------------------------------------------------

	Public Property Get Count()

		' Return number of fields found

		Count = mlngCount

	End Property

' ------------------------------------------------------------------------------

	Public Default Property Get Fields(ByVal pstrName)

		Dim llngIndex	' Index of current field

		' If a number was passed

		If IsNumeric(pstrName) Then

			llngIndex = CLng(pstrName)

			' If programmer requested an invalid number

			If llngIndex > mlngCount - 1 Or llngIndex < 0 Then

				' Raise an error

				Call Err.Raise(vbObjectError + 1, "clsUpload.asp", "Object does not exist within the ordinal reference.")

				Exit Property

			End If

			' Return the field class for the index specified

			Set Fields = mobjFieldAry(pstrName)

		' Else a field name was passed

		Else

			' convert name to lowercase

			pstrName = LCase(pstrname)

			' Loop through each field

			For llngIndex = 0 To mlngCount - 1

				' If name matches current fields name in lowercase

				If LCase(mobjFieldAry(llngIndex).Name) = pstrName Then

					' Return Field Class

					Set Fields = mobjFieldAry(llngIndex)

					Exit Property

				End If

			Next

		End If

		' If matches were not found, return an empty field

		Set Fields = New clsField

'		' ERROR ON NonExistant:

'		' If matches were not found, raise an error of a non-existent field

'		Call Err.Raise(vbObjectError + 1, "clsUpload.asp", "Object does not exist within the ordinal reference.")

'		Exit Property

	End Property

' ------------------------------------------------------------------------------

	Private Sub Class_Terminate()

		' This event is called when you destroy the class.

		'

		' Example:

		'	Set objUpload = Nothing

		'

		' Example:

		'	Response.End

		'

		' Example:

		'	Page finnishes executing ...

		Dim llngIndex	' Current Field Index

		' Loop through fields

		For llngIndex = 0 To mlngCount - 1

			' Release field object

			Set mobjFieldAry(llngIndex) = Nothing

		Next

		' Redimension array and remove all data within

		ReDim mobjFieldAry(-1)

	End Sub

' ------------------------------------------------------------------------------

	Private Sub Class_Initialize()

		' This event is called when you instantiate the class.

		'

		' Example:

		'	Set objUpload = New clsUpload

		' Redimension array with nothing

		ReDim mobjFieldAry(-1)

		' Compile ANSI equivilants of carriage returns and line feeds

		CR = ChrB(Asc(vbCr))	' vbCr		Carriage Return

		LF = ChrB(Asc(vbLf))	' vbLf		Line Feed

		CRLF = CR & LF			' vbCrLf	Carriage Return & Line Feed

		' Set field count to zero

		mlngCount = 0

		' Request data

		Call RequestData

		' Parse out the delimiter

		Call ParseDelimiter()

		' Parse the data

		Call ParseData

	End Sub

' ------------------------------------------------------------------------------

	Private Function CStrU(ByRef pstrANSI)

		' Converts an ANSI string to Unicode

		' Best used for small strings

		Dim llngLength	' Length of ANSI string

		Dim llngIndex	' Current position

		' determine length

		llngLength = LenB(pstrANSI)

		' Loop through each character

		For llngIndex = 1 To llngLength

			' Pull out ANSI character

			' Get Ascii value of ANSI character

			' Get Unicode Character from Ascii

			' Append character to results

			CStrU = CStrU & Chr(AscB(MidB(pstrANSI, llngIndex, 1)))

		Next

	End Function

' ------------------------------------------------------------------------------

	Private Function CStrB(ByRef pstrUnicode)

		' Converts a Unicode string to ANSI

		' Best used for small strings

		Dim llngLength	' Length of ANSI string

		Dim llngIndex	' Current position

		' determine length

		llngLength = Len(pstrUnicode)

		' Loop through each character

		For llngIndex = 1 To llngLength

			' Pull out Unicode character

			' Get Ascii value of Unicode character

			' Get ANSI Character from Ascii

			' Append character to results

			CStrB = CStrB & ChrB(Asc(Mid(pstrUnicode, llngIndex, 1)))

		Next

	End Function

' ------------------------------------------------------------------------------

End Class

' ------------------------------------------------------------------------------

%>