|
styrochem -> Upload Progress Bar Not Showing (12/3/2004 13:00:30)
|
This is a repost from a prior question but I really need to resolve this issue.
I modified my web pages to utilize Lewis Moten upload progress bar but am having some trouble with it. The files upload with no problem yet the progress bar window never pops up. Does anyone see anything wrong I did? My code is below.
FIRST PAGE-----
<HTML>
<HEAD><%@ EnableSessionState=False %>
<title>Upload File</title>
</HEAD>
<BODY>
<b>Upload File</b><p>
Select the file that you wish to upload<br>
<br>
<FORM method="post" encType="multipart/form-data" action="upload_process.asp">
<INPUT type="File" name="FileName" size="20">
<INPUT type="Submit" value="Upload File">
</FORM>
<SCRIPT Language="javascript">
// define variable to point to progress window
var UploadProgress;
function form_onsubmit()
{
// Create a random session identifier.
var Session = new String();
Session = Math.floor(Math.random() * 0xFFFFFF).toString(16);
// build URL for upload status
var ProgressUrl = "../uploader/Progress_Status.asp?Session=" + Session;
// define features for pop-up window
var Features = new String("");
Features += "toolbar=no, ";
Features += "menubar=no, ";
Features += "status=no, ";
Features += "resizable=no, ";
Features += "width=200, ";
Features += "height=200";
// open the pop-up window
UploadProgress = window.open(ProgressUrl, "upload", Features);
// append identification of session
document.upload.action += "?Session=" + Session;
return true;
}
function window_onunload()
{
// if progress doesn't exist, return
if(UploadProgress == null){return;}
// if progress doesn't expose closed method
if(UploadProgress.closed){return}
// close progress window
UploadProgress.close();
}
// assign event handler to unload event
window.onunload = window_onunload;
</SCRIPT>
SECOND PAGE THAT PREVIOUS POSTS TO---
<!--#include file="../code/clsupload.asp"-->
<%
'#===========================
'# Allowable file extensions
'#===========================
sAllowedFiles = "zip,jpg,gif,xls,ppt,doc,pdf,bmp,jpeg,mpeg,mdb"
'#===========================
'# Upload size max in bytes
'#===========================
iUplSize = 5000000000
'#===========================
'# File path (based on the root of your web)
'#===========================
sUploadPath = "../uploads"
'#===========================
'# Name of the text box that the
'# file name will be saved to.
'#===========================
TextBox = "Upload"
Set Upload = New clsUpload
FileName = Upload.Fields("FileName").FileName
Ext = Upload("FileName").FileExt
if inStr(uCase(sAllowedFiles),uCase(Ext)) > 0 then
If Upload("FileName").Length <= iUplSize then
Folder = Server.MapPath(sUploadPath) & "\"
FileName = Upload.UniqueName(Folder, FileName)
Upload("FileName").SaveAs Folder & FileName
Else
errmessage = "File must be less than "& iUplSize/1000 & " kb"
End if
else
errmessage = "File type not supported."
end if
Set Upload = Nothing
%>
<HTML>
<HEAD>
<SCRIPT LANGUAGE="JavaScript">
<!--
function copyForm() {
opener.document.Upload.<%=TextBox%>.value = document.popupForm.FileName.value;
document.popupForm.submit();
window.close();
return false;
}
//-->
</SCRIPT>
</HEAD>
<%If len(errmessage) > 0 then%>
<BODY>
<%=errmessage%>
<%Else%>
<BODY onLoad="return copyForm()">
<FORM NAME="popupForm" onSubmit="return copyForm()">
<INPUT TYPE="TEXT" NAME="FileName" value="<%=FileName%>" size="20">
<INPUT TYPE="BUTTON" VALUE="Submit" onClick="copyForm()">
</FORM>
<%end if%>
</BODY>
</HTML>
PROGRESS STATUS BAR PAGE---
<%@EnableSessionState=False%>
<!--#INCLUDE FILE="../Code/clsProgress.asp"-->
<STYLE>
BODY
{
font-size: 8pt;
}
</STYLE>
<%
' NOTICE:
' If session state is enabled for this page, then
' data will not be processed until the file has
' been received.
Dim Progress
Dim Percent
' do not cache page
Call Response.AddHeader("pragma","no-cache")
Response.CacheControl = "no-cache"
' Load Progress Information
Set Progress = New clsProgress
' If information could not be loaded
If Not Progress.Load Then
' Garbage collection
Set Progress = Nothing
' Notify user
Response.Write "Please Wait ..."
' Instruct browser to refresh
Refresh()
' Write buffer to browser
Response.Flush
' Halt execution.
Response.End
End If
With Progress
Percent = 0
If Not .TotalBytes = 0 Then
Percent = Fix((.BytesReceived / .TotalBytes) * 100)
End If
Response.Write "Bytes Received: " & .BytesReceived & "<BR>"
Response.Write "Total Bytes: " & .TotalBytes & "<BR>"
If IsDate(.UploadStarted) Then
Response.Write "Started: " & FormatDateTime(.UploadStarted, vbLongTime) & "<BR>"
End If
If IsDate(.LastActive) Then
Response.Write "Last Active: " & FormatDateTime(.LastActive, vbLongTime) & "<BR>"
End If
Response.Write "Progress: " & Percent & "%<BR>"
If IsDate(.UploadCompleted) Then
Response.Write "Completed.<BR>"
End If
' Write progress bar
%>
<TABLE border="1" bgColor="red" width="100%" height="16">
<TR>
<TD bgcolor="white">
<SPAN style="height:100%;width:<%=Percent%>%;background-color:blue;"></SPAN>
</TD>
<td bgcolor="white" align="center" width="1%"><%=Percent%>%
</td>
</TR>
</TABLE>
<%
' If not completed, refresh
If .UploadCompleted = "" Then
Refresh
End If
End With
' Garbage Collection
Set Progress = Nothing
Public Sub Refresh()
%>
<SCRIPT>
window.focus();
window.setTimeout("window.location.reload()", 1000);
</SCRIPT>
<%
End Sub
%>
clsupload PAGE ------------
<!--METADATA
TYPE="TypeLib"
NAME="Microsoft ActiveX Data Objects 2.5 Library"
UUID="{00000205-0000-0010-8000-00AA006D2EA4}"
VERSION="2.5"
-->
<%
Const FileSystemObjectEnabled = True
' If your ISP does not allow the File System Object to
' be used, then set this value to false. Some features
' will be disabled such as verifying folders exist,
' Assigning unique names to files, displaying progress,
' and interacting with existing files (Move, Copy, Delete,
' Rename)
Const BufferSize = &H10000
' Changing buffer size may change the length of time
' it takes to upload a file. You may want to begin
' with 64KB and go from there to find the optimal
' number for your website.
' Since the Progress Information class writes to
' a file each itteration, this can degrade performance
' a lot when using small buffers.
' Do not go below 100 bytes, or you will begin to risk
' not being able to parse boundaries. Data may not upload
' properly.
' For your reference:
' 1 KB 1024 &H400
' 2 KB 2048 &H800
' 4 KB 4096 &H1000
' 8 KB 8192 &H2000
' 16 KB 16384 &H4000
' 32 KB 32768 &H8000
' 64 KB 65536 &H10000
' 128 KB 131072 &H20000
' 256 KB 262144 &H40000
%>
<!--#INCLUDE FILE="clsField.asp"-->
<!--#INCLUDE FILE="clsProgress.asp"-->
<%
' ------------------------------------------------------------------------------
' Author: Lewis Moten
' Email: Lewis@Moten.com
' URL: http://www.lewismoten.com
' Date: September 1, 2003
' ------------------------------------------------------------------------------
' 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>
' ------------------------------------------------------------------------------
'
' Customized Errors:
' (vbObjectError + ##)
'
' 1: Object does not exist within the ordinal reference.
' 2: Failed to save file ... common reasons
' 3: Failed to parse posted binary data delimiter
' 4: Failed to save file ... unknown
' 5: Used Request.Form ... Failed to read posted form data
' 6: Failed to read posted form data for unknown reason.
' 7: Folder does not exist.
' 8: Filename is not valid
' 9: Folder is not valid
' 10: ADODB.Version below 2.5
' 11: Not enough free space available.
' 12: File System Object has been disabled.
' 13: multipart/form-data was not received.
' ------------------------------------------------------------------------------
'
Dim gBinaryData ' bytes visitor sent to server with posted form data
' Page Scope accessable to both clsUpload and clsFile
Class clsUpload
' ------------------------------------------------------------------------------
Private TotalBytes ' Number of bytes client is sending
Private Delimiter ' 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 msg ' Error Message
Private ProductName ' Name of the product
Private ProductVersion ' Version of the product
Private ErrorSignature ' Signature applied to all products.
Private Progress ' Progress information class
Private ParsedData ' Did we parse the data?
' ------------------------------------------------------------------------------
Private Sub RequestData
If ParsedData Then Exit Sub
ParsedData = True
'On Error Resume Next
' Determine number bytes visitor sent
TotalBytes = Request.TotalBytes
Dim ChunkSize
Dim Received
Dim TotalBytes
Dim BinaryStream
ChunkSize = BufferSize ' Global Property
TotalBytes = Request.TotalBytes
Received = 0
Set BinaryStream = CreateObject("ADODB.Stream")
BinaryStream.Mode = adModeReadWrite
BinaryStream.Type = adTypeBinary
BinaryStream.Open
Do While ChunkSize > 0
' If chunk size buffer will read past the end of the stream
' adjust it to read to the end of the stream.
If ChunkSize + Received > TotalBytes Then ChunkSize = TotalBytes - Received
' get out of the loop if no more data can be read.
If ChunkSize = 0 Then Exit Do
' Get the current chunk
' Write chunk to stream
BinaryStream.Write(Request.BinaryRead(ChunkSize))
' Incriment bytes received
Received = Received + ChunkSize
' As long as the user is still connected ...
If Response.IsClientConnected() Then
' Update Progress information
Progress.LastActive = Now()
Progress.BytesReceived = Received
Call Progress.Save()
Else
' Update Progress information
Progress.UploadCompleted = Now()
Call Progress.Save()
' Stop execution.
Exit Sub
End If
Loop
BinaryStream.Position = 0
gBinaryData = BinaryStream.Read(adReadAll)
BinaryStream.Close
Set BinaryStream = Nothing
' Parse out the delimiter
Delimiter = ParseBoundary()
' Parse the data
Call ParseData
End Sub
' ------------------------------------------------------------------------------
' Private Function 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?
'
' ' Need a MAC to find out why this causes problems.
'
' ' MSIE 3.01 and 3.02 on the Mac, for instance, don't use a
' ' leading '--' in the boundary field for multipart/form-data POSTs
'
' ' Examples:
'
' ' -----------------------------7d230d1f940246
' ' -----------------------------7d22ee291ae0114
'
' ' If we can not find a carriage return and line feed combination ...
' If InStrB(1, gBinaryData, CRLF) = 0 Then
'
' ' We can not determine the delimiter
'
' msg = "Failed to parse posted binary data delimiter. "
' msg = msg & " Make sure your encoding attiribute is set to"
' msg = msg & " mutlipart/form-data in your <FORM> tag. example:"
' msg = msg & "<FORM method=""post"" encType=""multipart/form-data"""
' msg = msg & " action=""ToDatabase.asp""> "
'
' Call PublishError(3, msg)
'
' Exit Sub
'
' End If
'
' ' parse delimiter
' ParseDelimiter = MidB(gBinaryData, 1, InStrB(1, gBinaryData, CRLF) - 1)
'
' End Function
' ------------------------------------------------------------------------------
Private Function IsMultipartFormData()
' Determine if user posted multipart form-data
' if not, they did not specify encType attribute correctly
' on <FORM> tag.
Dim ContentType
ContentType = Request.ServerVariables("HTTP_CONTENT_TYPE")
' Return true, only if the text is found within the content type.
IsMultipartFormData = Not InStr(1, ContentType, "multipart/form-data") = 0
End Function
' ------------------------------------------------------------------------------
Private Function ParseBoundary()
' Parse boundary from content type
' The boundry seperates each type of data within the binary data posted
' to this web page.
' NOTE: Not sure if this new technique solves issues with
' MAC
' MSIE 3.01 & 3.02 on MAC.
' Opera
' Mozilla 1.2
'
' Could not confirm issues in the past or now. If you are a developer
' and have access to these resources, please help me verify if the
' code does or does not work.
Dim ContentType
Dim BoundaryIndex
ContentType = Request.ServerVariables("HTTP_CONTENT_TYPE")
' Find out where the boundary text starts
BoundaryIndex = InStr(1, ContentType, "boundary=")
' If boundary is not specified withing content type header
If BoundaryIndex = 0 Then
' Return nothing.
Exit Function
End If
' Pull the boundary out of the content type
' Len("boundary=") = 9
ParseBoundary = CStrB(Mid(ContentType, BoundaryIndex + 9))
End Function
' ------------------------------------------------------------------------------
Private Sub ParseData()
' This procedure loops through each section (chunk) found within the
' delimiters and sends them to the parse chunk routine
Dim ChunkStart ' start position of chunk data
Dim ChunkLength ' Length of chunk
Dim ChunkEnd ' Last position of chunk data
' Initialize at first character
ChunkStart = 1
' Find start position
ChunkStart = InStrB(ChunkStart, gBinaryData, Delimiter & CRLF)
' While the start posotion was found
While Not ChunkStart = 0
' Find the end position (after the start position)
ChunkEnd = InStrB(ChunkStart + 1, gBinaryData, Delimiter) - 4
' Determine Length of chunk
ChunkLength = ChunkEnd - ChunkStart
Call ParseChunk(ChunkStart, ChunkLength)
' Look for next chunk after the start position
' ChunkStart = InStrB(ChunkStart + 1, gBinaryData, Delimiter & CRLF)
ChunkStart = InStrB(ChunkEnd, gBinaryData, Delimiter & CRLF)
Wend
End Sub
' ------------------------------------------------------------------------------
Private Sub ParseChunk(ByRef chunkStart, ByRef chunkLength)
' 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 FieldName ' Name of field
Dim FilePath ' File name of binary data
Dim ContentType ' Content type of binary data
Dim ContentDisposition ' Content Disposition
Dim dataStart ' Start position of data
Dim dataLength ' Length of data
' Parse out the content dispostion
ContentDisposition = ParseDisposition(chunkStart, chunkLength)
' And Parse the Name
FieldName = ParseName(ContentDisposition)
' And the file name
FilePath = ParseFileName(ContentDisposition)
' Parse out the Content Type
ContentType = ParseContentType(chunkStart, chunkLength)
' Determine where the binardy data begins and ends
Call ParseBinaryData(chunkStart, chunkLength, dataStart, dataLength)
' Add a new field
Call AddField(FieldName, FilePath, ContentType, dataStart, dataLength)
End Sub
' ------------------------------------------------------------------------------
Private Sub AddField(ByRef fieldName, ByRef filePath, ByRef contentType, ByRef dataStart, ByRef dataLength)
Dim Field ' 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 Field = New clsField
' Set field properties
With Field
.Name = fieldName
.FilePath = filePath
.ContentType = contentType
.dataStart = dataStart
.dataLength = dataLength
End With
' Determine field length based on if ContentType was provided.
If contentType = "" Then
' Assume Unicode - 2 bytes per character
Field.Length = dataLength \ 2
Else
' Assume binary data
Field.Length = dataLength
End If
' Set field array index to new field
Set mobjFieldAry(mlngCount) = Field
' Incriment field count
mlngCount = mlngCount + 1
End Sub
' ------------------------------------------------------------------------------
Private Sub ParseBinaryData(ByRef chunkStart, ByRef chunkLength, ByRef dataStart, ByRef dataLength)
' Parses binary content of the chunk
dataStart = 0
dataLength = 0
' Find first occurence of a blank line
dataStart = InStrB(chunkStart, gBinaryData, CRLF & CRLF)
' If it doesn't exist, then return nothing
If dataStart = 0 Then Exit Sub
If dataStart > chunkStart + chunkLength Then
dataStart = 0
Exit Sub
End If
' Incriment start to pass carriage returns and line feeds
dataStart = dataStart + 4
' calculate data length based on start and length of the chunk.
dataLength = ((chunkStart + chunkLength) - dataStart)
End Sub
' ------------------------------------------------------------------------------
Private Function ParseContentType(ByRef chunkStart, ByRef chunkLength)
' Parses the content type of a binary file.
' example: image/gif is the content type of a GIF image.
Dim StartIndex ' Start Position
Dim EndIndex ' End Position
Dim Length ' Length
' Fid the first occurance of a line starting with Content-Type:
StartIndex = InStrB(chunkStart, gBinaryData, CRLF & CStrB("Content-Type:"), vbTextCompare)
' If not found, return nothing
If StartIndex = 0 Or StartIndex > chunkStart + chunkLength Then
ParseContentType = ""
Exit Function
End If
' Find the end of the line
EndIndex = InStrB(StartIndex + 15, gBinaryData, CR)
' If not found, return nothing
If EndIndex = 0 Or endIndex > chunkStart + chunkLength Then
ParseContentType = ""
Exit Function
End If
' Adjust start position to start after the text "Content-Type:"
StartIndex = StartIndex + 15
' If the start position is the same or past the end, return nothing
If StartIndex >= EndIndex Then
ParseContentType = ""
Exit Function
End If
' Determine length
Length = EndIndex - StartIndex
' Pull out content type
' Convert to unicode
' Trim out whitespace
' Return results
ParseContentType = Trim(CStrU(MidB(gBinaryData, StartIndex, Length)))
End Function
' ------------------------------------------------------------------------------
Private Function ParseDisposition(ByRef chunkStart, ByRef chunkLength)
' 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 StartIndex ' Start Position
Dim EndIndex ' End Position
Dim Length ' Length
' Find first occurance of a line starting with Content-Disposition:
StartIndex = InStrB(chunkStart, gBinaryData, CRLF & CStrB("Content-Disposition:"), vbTextCompare)
' If not found, return nothing
If StartIndex = 0 Or StartIndex > chunkStart + chunkLength Then Exit Function
' Find the end of the line
EndIndex = InStrB(StartIndex + 22, gBinaryData, CRLF)
' If not found, return nothing
If EndIndex = 0 Or EndIndex > chunkStart + chunkLength Then Exit Function
' Adjust start position to start after the text "Content-Disposition:"
StartIndex = StartIndex + 22
' If the start position is the same or past the end, return nothing
If StartIndex >= EndIndex Then Exit Function
' Determine Length
Length = EndIndex - StartIndex
' Pull out content disposition
' Convert to Unicode
' Return Results
ParseDisposition = CStrU(MidB(gBinaryData, StartIndex, Length))
End Function
' ------------------------------------------------------------------------------
Private Function ParseName(ByRef contentDisposition)
' Parses the name of the field from the content disposition
'
' Example
'
' form-data: name="File1"; filename="C:\Photo.gif"
'
' Would Return:
' File1
Dim StartIndex ' Start Position
Dim EndIndex ' End Position
Dim Length ' Length
' Find first occurance of text name="
StartIndex = InStr(1, contentDisposition, "name=""", vbTextCompare)
' If not found, return nothing
If StartIndex = 0 Then Exit Function
' Find the closing quote
EndIndex = InStr(StartIndex + 6, contentDisposition, """")
' If not found, return nothing
If EndIndex = 0 Then Exit Function
' Adjust start position to start after the text name="
StartIndex = StartIndex + 6
' If the start position is the same or past the end, return nothing
If StartIndex >= EndIndex Then Exit Function
' Determine Length
Length = EndIndex - StartIndex
' Pull out field name
' Return results
ParseName = Mid(contentDisposition, StartIndex, Length)
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
ParseFileName = DefaultName()
Exit Function
End If
' Find the closing quote
llngEnd = InStr(llngStart + 10, pstrDisposition, """")
' If not found, return nothing
If llngEnd = 0 Then
ParseFileName = DefaultName()
Exit Function
End If
' 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
ParseFileName = DefaultName()
Exit Function
End If
' Determine length
llngLength = llngEnd - llngStart
' Pull out file name
' Return results
ParseFileName = Mid(pstrDisposition, llngStart, llngLength)
End Function
' ------------------------------------------------------------------------------
Private Function DefaultName()
' Some browsers don't supply file names in the headers.
' We have to assume a name for them.
' Since all we know is that the file is made of binary data,
' we assign a .bin extension.
DefaultName = _
Year(Date) & "_" & _
MonthName(Month(Date), True) & "_" & _
Day(Date) & "-" & _
timer() & ".bin"
End Function
' ------------------------------------------------------------------------------
Public Property Get Count()
Call RequestData()
' Return number of fields found
Count = mlngCount
End Property
' ------------------------------------------------------------------------------
Public Property Get Collection(ByVal fieldName)
Dim myCollection()
Dim index
Dim matches
' convert name to lowercase
fieldName = LCase(fieldName)
' default number of matches to none
matches = -1
' Loop through each field
For index = 0 to Count() - 1
' If name matches
If LCase(mobjFieldAry(index).Name) = fieldName Then
' incriment number of matches found
matches = matches + 1
' Add a new item to the collection
ReDim Preserve myCollection(matches)
' Assign last item to the value
Set myCollection(matches) = mobjFieldAry(index)'.Value
End If
Next
' Return the collection as an array
Collection = myCollection
End Property
' ------------------------------------------------------------------------------
Public Default Property Get Fields(ByVal pstrName)
Call RequestData()
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 PublishError(1, "Object does not exist within the ordinal reference.")
Exit Property
End If
' Return the field class for the index specified
Set Fields = mobjFieldAry(pstrName)
Exit Property
' 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
End Property
' ------------------------------------------------------------------------------
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
' Convert to unicode
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
' ------------------------------------------------------------------------------
Public Sub DeleteFile(byval filePath)
If Not FileSystemObjectEnabled Then
Call PublishError(12, "File System Object has been disabled.")
Exit Sub
End If
Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.DeleteFile(filePath)
Set FSO = Nothing
End Sub
' ------------------------------------------------------------------------------
Public Sub RenameFile(ByVal filePath, ByVal fileName)
If Not FileSystemObjectEnabled Then
Call PublishError(12, "File System Object has been disabled.")
Exit Sub
End If
Dim folder
folder = Mid(filePath, 1, InStrRev(filePath, "\"))
Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
Call FSO.MoveFile(filePath, folder & fileName)
Set FSO = Nothing
End Sub
' ------------------------------------------------------------------------------
Public Sub CopyFile(ByRef source, ByRef destination)
If Not FileSystemObjectEnabled Then
Call PublishError(12, "File System Object has been disabled.")
Exit Sub
End If
Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
Call FSO.CopyFile(source, destination, true)
Set FSO = Nothing
End Sub
' ------------------------------------------------------------------------------
Public Sub MoveFile(ByRef source, ByRef destination)
If Not FileSystemObjectEnabled Then
Call PublishError(12, "File System Object has been disabled.")
Exit Sub
End If
Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
Call FSO.MoveFile(source, destination)
Set FSO = Nothing
End Sub
' ------------------------------------------------------------------------------
Public Function UniqueName(ByVal folder, ByRef proposedName)
' Generates a unique file name that has not yet been used
' within the target folder.
' If we continue to upload a file called photo.gif,
' this is what will be returned:
' first time: photo.gif
' second time: photo[1].gif
' third time: photo[2].gif
If Not FileSystemObjectEnabled Then
Call PublishError(12, "File System Object has been disabled.")
Exit Function
End If
' Make sure we have a file name
If proposedName = "" Then proposedName = DefaultName()
' Make sure user supplied a valid file name
If proposedName = "." Then
Call PublishError(8, "Filename is not valid")
Exit Function
End If
' Make sure user supplied a folder to check
If folder = "" Then
Call PublishError(9, "Folder is not valid")
Exit Function
End If
Dim Name ' Name of file (without extension)
Dim Ext ' File Extension
' seperate name/ext
If InStrRev(proposedName, ".") = 0 Then
Name = proposedName
Ext = ""
ElseIf InStrRev(proposedName, ".") = 1 Then
Name = ""
Ext = Mid(proposedName, 2)
ElseIf InStrRev(proposedName, ".") = Len(proposedName) Then
Name = Mid(proposedName, 1, Len(proposedName) - 1)
Ext = ""
Else
Name = Mid(proposedName, 1, InStrRev(proposedName, ".") - 1)
Ext = Mid(proposedName, InStrRev(proposedName, ".") + 1)
End If
' make sure we have trailing slash
If Not Mid(folder, Len(folder), 1) = "\" Then folder = folder & "\"
Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
' verify folder exists
If Not FSO.FolderExists(folder) Then
Set FSO = Nothing
Call PublishError(7, "Folder does not exist: " & folder)
Exit Function
End If
Dim Suffix
Dim Index
Index = 0
Suffix = ""
' Check to see if compiled filename exists
While FSO.FileExists(folder & Name & Suffix & "." & Ext)
' File name exists, let's incriment our counter
Index = Index + 1
' Setup suffix to match the index
Suffix = "[" & Index & "]"
Wend
Set FSO = Nothing
' Return unique file name
UniqueName = Name & Suffix & "." & Ext
End Function
' ------------------------------------------------------------------------------
Private Sub PublishError(number, message)
' writes out error in a specific format.
On Error Goto 0
Call Err.Raise(vbObjectError + number, ProductName & " " & ProductVersion, message + ErrorSignature)
End Sub
' ------------------------------------------------------------------------------
Public Function DebugText()
Call RequestData()
' Returns HTML code used in debugging the information comming accross
' within the posted form data
Dim Text
Dim Length
Dim Index
Dim Code
Length = LenB(gBinaryData)
For Index = 1 To Length
Code = AscB(MidB(gBinaryData, Index, 1))
Select Case Code
Case 13
Text = Text & "<B>vbCr</B><BR>"
Case 10
Text = Text & "<B>vbLf</B><BR>"
Case Else
If Code < 32 Then
' non-printable character
Text = Text & "."
Else
' printable. Encode the character.
Text = Text & Server.HTMLEncode(Chr(Code))
End If
End Select
Next
DebugText = Text
End Function
' ------------------------------------------------------------------------------
Private Sub Class_Terminate()
' This event is called when you destroy the class.
'
' Example:
' Set objUpload = Nothing
'
' Example:
' Response.End
'
' Example:
' Page finnishes executing ...
' Remove binary data
gBinaryData = ""
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)
' Signify the upload process has been completed.
Session("Upload.Completed") = Now()
' Update Session
Progress.UploadCompleted = Now()
Call Progress.Save()
End Sub
' ------------------------------------------------------------------------------
Private Sub Class_Initialize()
' This event is called when you instantiate the class.
'
' Example:
' Set objUpload = New clsUpload
ProductName = "Upload Without COM"
ProductVersion = "3.11"
ErrorSignature = "[Need help? Contact Lewis Moten, lewis@moten.com, http://www.lewismoten.com]"
' Initialize progress information class
Set Progress = New clsProgress
' Set initial information
Progress.UploadStarted = Now()
Progress.LastActive = Now()
Progress.BytesReceived = 0
Progress.TotalBytes = Request.TotalBytes
Progress.UploadCompleted = ""
' update the Progress information
Call Progress.Save()
' Set script timeout to 10 minutes.
Server.ScriptTimeout = 60 * 10
' Shameless plug for search engines
Response.Write "<NOSCRIPT>"
Response.Write "<B>Upload Files Without COM</B> provided by: "
Response.Write "<A href=""http://www.lewismoten.com""><I>Lewis Moten</I></A>"
Response.Write "</NOSCRIPT>"
' Verify ADODB Version
Dim Connection
Dim AdodbVersion
Set Connection = CreateObject("ADODB.Connection")
AdodbVersion = CDbl(Connection.Version)
Set Connection = Nothing
If AdodbVersion < 2.5 Then
Call PublishError(10, "Microsoft Data Access Components (ADODB) must be version 2.5 or above.")
Exit Sub
End If
' Did the web developer program the form tag correctly?
If Not IsMultipartFormData() Then
msg = "multipart/form-data was not received. "
msg = msg & "Make sure that you have specified the endType "
msg = msg & "attribute to ""multipart/form-data"" in your "
msg = msg & "<FORM id=form1 name=form1> tag."
Call PublishError(13, msg)
Exit Sub
End If
' 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
End Sub
' ------------------------------------------------------------------------------
End Class
' ------------------------------------------------------------------------------
%>
|
|
|
|
