aspUpload有组件上传文件的源码

使用无组件上传有一个缺点：就是不能上传大的文件。
如果客户要上传大文件，这种方式就不行了，所以解决的方法有两种：
1、使用FTP上传大文件，然后将路径填入到表单中，这样多了FTP上传文件过程
2、使用有组件上传。

这里介绍aspUpload组件，该组件的下载地址是：http://www.K88.NET/code/showcode.asp?id=97
使用有组件上传，前提是服务器上必须安装了这个组件。

aspUpload上传代码：

<
form method="POST" enctype="multipart/form-data" action="?act=upload">

<
input type="file" size="20" name="file1">
<
input type="submit" value="上传">

<
/form>

<
%
if request("act") = "upload" then
'****************************************
' 
功能：aspUpload有组件上传文件
' 
作者：wangsdong
' 
网址：www.K88.NET
' 

'****************************************
AllowExt = "jpg,png,gif,zip,rar,sql,txt,bak"
FileSize=4194304
'On Error Resume Next

' 新建AspUpload对象
Set Upload = Server.CreateObject("Persits.Upload")

' 限制文件大小
Upload.SetMaxSize FileSize, True

' 上传路径--当前目录下的test目录
if session("fuptype")="pic" then
 
path="images/pic"
else
 
path="images/test"
end if
uploadDir = Server.MapPath(path)
AutoCreateFolder(uploadDir) '创建文件夹

' 尝试创建路径文件夹,true表示忽略目录已存在错误
'Upload.CreateDirectory uploadDir, true

' 先上传文件至服务器内存
Count = Upload.Save()

' 检测上传错误
If Err.Number = 8 Then
Response.Write chinese2unicode("错误: 文件过大!")
Response.end
Else
If Err <
>
0 Then
response.write chinese2unicode("发生错误：")
response.write chinese2unicode(Err.Description)
response.end
End If
End If

'Response.Write chinese2unicode("共 " &
Count &
" 个文件") &
"<
br>
<
br>
"

' 指定一个上传的表单文件
Set File = Upload.Files("file1")
If Not File Is Nothing Then
' 获取原本文件名
'Filename = File.Filename '如果使用原文件名，请去掉前面的单引号
filename=replace(replace(replace(now()," ",""),"-",""),":","")&
File.Ext '以时间为文件名
' 获取文件扩展名
Fileext = File.Ext
v=path&
"/"&
filename

' 检测文件格式是否合格
ChkStr = ","&
Lcase(AllowExt)&
","
If Instr(ChkStr,","&
right(Fileext,3)&
",") <
= 0 Then
Response.Write chinese2unicode("错误: 文件类型不正确!")
response.write "<
br>
"
response.write chinese2unicode("只允许:"&
AllowExt)
' 删除内存中的临时文件，以释放内存或硬盘空间(还可用Copy、Move两个指令)
File.Delete
' 检测是否存在文件
elseif Upload.FileExists(uploadDir &
"\" &
Filename) Then
File.SaveAs uploadDir &
"\" &
Filename
Response.Write chinese2unicode("已覆盖存在相同文件名的文件: ") &
File.Path
' 保存文件
else
File.SaveAs uploadDir &
"\" &
Filename
'Response.Write chinese2unicode("文件已保存到: ") &
File.Path
'v=Replace(UploadFilePath&
file.filename,"../","") 
 
 

 
response.write "<
script>
opener.document."&
session("frmname")&
"."&
session("bdname")&
".value='"&
v&
"'
window.close()
<
/script>
"
end If
Else
Response.Write chinese2unicode("错误: 您并没有选择文件!")
End If

else
 
 
session("fuptype")=request("fuptype") 
 
'上传类型
 
 
session("frmname")=request("frmname") 
 
'form名
 
 
session("bdname")=request("bdname") 
 
 
 
 
 
 
 
'表单名
end If

' gb2312转unicode，解决中文乱码问题
function chinese2unicode(Str)
dim i
dim Str_one
dim Str_unicode
for i=1 to len(Str)
Str_one=Mid(Str,i,1)
Str_unicode=Str_unicode&
chr(38)
Str_unicode=Str_unicode&
chr(35)
Str_unicode=Str_unicode&
chr(120)
Str_unicode=Str_unicode&
Hex(ascw(Str_one))
Str_unicode=Str_unicode&
chr(59)
next
Response.Write Str_unicode
end function
'--------------------------------
'自动创建指定的多级文件夹
'strPath为绝对路径
Function AutoCreateFolder(strPath) 'As Boolean
 
 
 
 
 
 
 
On Error Resume Next
 
 
 
 
 
 
 
Dim astrPath, ulngPath, i, strTmpPath
 
 
 
 
 
 
 
Dim objFSO
 
 
 
 
 
 
 
If InStr(strPath, "\") <
=0 or InStr(strPath, ":") <
= 0 Then
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
AutoCreateFolder = False
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
Exit Function
 
 
 
 
 
 
 
End If
 
 
 
 
 
 
 
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
 
 
 
 
 
 
 
If objFSO.FolderExists(strPath) Then
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
AutoCreateFolder = True
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
Exit Function
 
 
 
 
 
 
 
End If
 
 
 
 
 
 
 
astrPath = Split(strPath, "\")
 
 
 
 
 
 
 
ulngPath = UBound(astrPath)
 
 
 
 
 
 
 
strTmpPath = ""
 
 
 
 
 
 
 
For i = 0 To ulngPath
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
strTmpPath = strTmpPath &
astrPath(i) &
"\"
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
If Not objFSO.FolderExists(strTmpPath) Then
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
'创建
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
objFSO.CreateFolder(strTmpPath)
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
End If
 
 
 
 
 
 
 
Next
 
 
 
 
 
 
 
Set objFSO = Nothing
 
 
 
 
 
 
 
If Err = 0 Then
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
AutoCreateFolder = True
 
 
 
 
 
 
 
Else
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
AutoCreateFolder = False
 
 
 
 
 
 
 
End If
End Function 
 

% >

具体代码下载地址：http://www.K88.NET/code/showcode.asp?id=98