IDC资讯中心
在上次贴出的文章中我提到了几种上载组件的比较
现在我们自己动手，丰衣足食，来建立自己的上载组件
这个上载组件应该具备以下功能：
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
dim intformfieldcounter 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
