在上次贴出的文章中我提到了几种上载组件的比较
现在我们自己动手，丰衣足食，来建立自己的上载组件
这个上载组件应该具备以下功能：
1。应该能够接受各种HTML的form元素中传过来的数值，而不
用知道是通过text或则select传过来的
2。应该能够给出一个上载路径
3。应该能够限制上载文件的大小
4。应该能够支持多个文件同时上载
5。应该能够处理异常错误
6。应该能够工作稳定
7。应该能够不厚此薄彼（即能够同时工作在IE和Netscape中）
8。能够把文件保存在数据库中
9。应该能够限制用户权限
代码和文件如下所示（老规矩，我就不作详细解释了）
1。Upload.htm
<HTML>
<HEAD><TITLE>Upload</TITLE></HEAD>
<BODY>
<FORM NAME="frmUpload" METHOD="Post" ENCTYPE="multipart/form-data" ACTION="Upload.asp"> <TABLE>
<TR><TD>作者</TD><TD><INPUT TYPE="text" NAME="txtAuthor"></TD></TR>
<TR><TD>文件</TD><TD><INPUT TYPE="file" NAME="txtFileName"></TD></TR>
<TR><TD COLSPAN="2" ALIGN="right"><INPUT TYPE="Submit" VALUE="Upload"></TD></TR>
</TABLE>
</FORM>
</BODY>
</HTML>
**注意：使用ENCTYPE="multipart/form-data"是为了能够让form提交一个文件
2。Upload.asp
<%@ Language=VBScript %>
<%
Option explicit
Response.Buffer = True
On Error Resume Next
If Request.ServerVariables("REQUEST_METHOD") = "POST" Then
Dim objUpload
Dim lngMaxFileBytes
Dim strUploadPath
Dim varResult
lngMaxFileBytes = 10000
strUploadPath = "c:\inetpub\wwwroot\upload\"
Set objUpload = Server.CreateObject("pjUploadFile.clsUpload")
If Err.Number <> 0 Then
Response.Write "组件没有安装正确。"
Else
varResult = objUpload.DoUpload (lngMaxFileBytes, strUploadPath)
Set objUpload = Nothing
Dim i
For i = 0 to UBound(varResult,1)
Response.Write varResult(i,0) & " : " & varResult(i,1) & "<br>"
Next
End If
End If
%>
现在使用VB6开发这个ActiveX控件：(要注意的是，由于本人比较懒，中间有些代码可能不完整，
但重要的是要理解这个组件的编程思路)
1。引用Active Server Pages Object library.
2。代码如下：
Option Explicit
Private MyScriptingContext As ScriptingContext
Private MyRequest As Request
Private MyResponse As Request
Private Const ERR_NO_FILENAME As Long = vbObjectError + 100
Private Const ERR_NO_EXTENSION As Long = vbObjectError + 101
Private Const ERR_EMPTY_FILE As Long = vbObjectError + 102
Private Const ERR_FILESIZE_NOT_ALLOWED As Long = vbObjectError + 103
Private Const ERR_FOLDER_DOES_NOT_EXIST As Long = vbObjectError + 104
Private Const ERR_FILE_ALREADY_EXISTS As Long = vbObjectError + 105
Public Sub OnStartPage(PassedScriptingContext As ScriptingContext)
Set MyScriptingContext = PassedScriptingContext
Set MyRequest = MyScriptingContext.Request
Set MyResponse = MySriptingContext.Response
End Sub
Private Function GetFileName(strFilePath) As String
Dim intPos As Integer
GetFileName = strFilePath
For intPos = Len(strFilePath) To 1 Step -1
If Mid(strFilePath, intPos, 1) = "\" Or Mid(strFilePath, intPos, 1) = ":" Then
GetFileName = Right(strFilePath, Len(strFilePath) - intPos)
Exit Function
End If
Next
End Function
Private Function CheckFileExtension(strFileName) As Boolean
Dim strFileExtension As String
If InStr(strFileName, ".") Then
strFileExtension = Mid(strFileName, InStrRev(strFileName, ".") + 1)
If Len(strFileExtension) < 3 Then
CheckFileExtension = False
Else
CheckFileExtension = True
End If
Else
CheckFileExtension = False
End If
End Function
Private Sub WriteFile(ByVal strUploadPath As String, ByVal strFileName As String, _
ByVal lngFileLength As Long)
End Sub
Public Function DoUpload (ByVal lngMaxFileBytes As Long, _
ByVal strUploadPath As String) As Variant
Dim varByteCount As Variant
Dim varHTTPHeader As Variant
Dim lngFileLength As Long
Dim arrError(0, 1) As Variant
On Error GoTo DoUpload_Err
varByteCount = MyRequest.TotalBytes
varHTTPHeader = StrConv(MyRequest.BinaryRead(varByteCount), vbUnicode)
MyResponse.Write varHTTPHeader
DimintFormFieldCounter As Integer
intFormFieldCounter = Len(varHTTPHeader) - Len(Replace(varHTTPHeader, "; name=", Mid("; name=", 2)))
ReDim arrFormFields(intFormFieldCounter - 1, 1) As Variant
For i = 0 To intFormFieldCounter - 1
lngFormFieldNameStart = InStrB(lngFormFieldNameStart + 1, varHTTPHeader, "; name=" & Chr(34))
lngFormFieldNameEnd = InStrB(lngFormFieldNameStart +_
Len(StrConv("; name=" & Chr(34), vbUnicode)), varHTTPHeader, Chr(34)) _
+ Len(StrConv(Chr(34), vbUnicode))
strFormFieldName = MidB(varHTTPHeader, lngFormFieldNameStart, lngFormFieldNameEnd - lngFormFieldNameStart)
strFormFieldName = Replace(strFormFieldName, "; name=", vbNullString)
strFormFieldName = Replace(strFormFieldName, Chr(34), vbNullString)
If MidB(varHTTPHeader, lngFormFieldNameEnd, 2) = ";" Then
lngFormFieldValueStart = InStrB(lngFormFieldNameEnd, varHTTPHeader, "filename=" & Chr(34))
lngFormFieldValueEnd = InStrB(lngFormFieldValueStart + Len(StrConv("filename=" & Chr(34), vbUnicode)), varHTTPHeader, Chr(34))
strFileName = MidB(varHTTPHeader, lngFormFieldValueStart, lngFormFieldValueEnd - lngFormFieldValueStart)
strFileName = Mid(strFileName, InStr(strFileName, "=") + 2, Len(strFileName) - InStr(strFileName, "="))
strFileName = Replace(strFileName, Chr(34), vbNullString)
Else
lngFormFieldValueStart = lngFormFieldNameEnd
lngFormFieldValueEnd = InStrB(lngFormFieldValueStart, varHTTPHeader, varDelimeter)
strFormFieldValue = MidB(varHTTPHeader, lngFormFieldValueStart, lngFormFieldValueEnd - lngFormFieldValueStart)
strFormFieldValue = Replace(strFormFieldValue, vbCrLf, vbNullString)
lngFormFieldNameStart = lngFormFieldValueEnd
End If
arrFormFields(i, 0) = strFormFieldName
arrFormFields(i, 1) = strFormFieldValue
strFileName = GetFileName(strFileName)
If Len(strFileName) = 0 Then
Err.Raise ERR_NO_FILENAME
End If
If Not CheckFileExtension(strFileName) Then
Err.Raise ERR_NO_EXTENSION
End If
lngFileDataStart = InStr(InStr(varHTTPHeader, strFileName), varHTTPHeader, vbCrLf & vbCrLf) + 4
lngFileDataEnd = InStr(lngFileDataStart, varHTTPHeader, varDelimeter)
lngFileLength = lngFileDataEnd-lngFileDataStart
If lngFileLength <= 2 Then
Err.Raise ERR_EMPTY_FILE
End If
If Not lngMaxFileBytes = 0 Then
If lngMaxFileBytes < lngFileLength Then
Err.Raise ERR_FILESIZE_NOT_ALLOWED
End If
End If
If Not fs.FolderExists(strUploadPath) Then
Err.Raise ERR_FOLDER_DOES_NOT_EXIST
End If
If fs.FileExists(strUploadPath & strFileName) Then
Err.Raise ERR_FILE_ALREADY_EXISTS
End If
Set sFile = fs.CreateTextFile(strUploadPath & strFileName, True)
sFile.Write varContent , lngFileDataStart, lngFileLength
Close File
sFile.Close
Set sFile = Nothing
Set fs = Nothing
Next
DoUpload = ""
Exit Function
DoUpload_Err:
arrError(0, 0) = "Error"
Select Case Err.Number
Case ERR_NO_FILENAME
arrError(0, 1) = "没有输入需要提交的文件名。"
Case ERR_NO_EXTENSION
arrError(0, 1) = "文件扩展名出错。"
Case ERR_EMPTY_FILE
arrError(0, 1) = "你要上载的文件长度为0。"
Case ERR_FILESIZE_NOT_ALLOWED
arrError(0, 1) = "总共要上传 [" & lngFileLength &_
"] 字节超过了允许的最大要求 [" &_
lngMaxFileBytes & "]."
Case ERR_FOLDER_DOES_NOT_EXIST
arrError(0, 1) = "上传的目录不存在。"
Case ERR_FILE_ALREADY_EXISTS
arrError(0, 1) = "文件 [" & strFileName & "] 已经存在了。"
Case Else
arrError(0, 1) = Err.Description
End Select
DoUpload = arrError()
End Function
关键词：以前搜集的一些资料---如何创建自己的上传组件的编程思路