示例网页：无组件上传文件
源代码：点击下载
本文提供了一个无组件上传文件的解决方案。它由5个文件组成。
- UploadFile.asp，上传文件的前台页面，供用户选择要上传的文件。
- UploadFile_Process.asp，后台过渡文件，可以在这里做一些个性化的设置，如上传到哪个文件夹等等。
- CBeanFile.asp，用来做一些验证工作，如果通过验证就上传文件到指定目的地（通过调用下面的两个文件）。
- CFile.asp，文件类，存储上传的文件数据，如文件名等等，它有一个方法用来将文件数据保存到指定的文件夹。
- CFormDataGetter.asp，表单数据获取类，这是上传文件的核心程序，对提交的表单进行分析，并取出文件数据。
下面分别来建立这5个文件，然后访问Upload.asp就可以运行了(假设这5个文件都放在你的本地服务器的Example文件下，那么只需在浏览器地址栏里输入http://localhost/Upload/UploadFile.asp就可以访问)。虽然这个过程需要写比较长的代码，但是好在它们已经写好了，你可以只需要复制粘贴即可，当然，在应用到你自己的网站时，需要进行一些个性化的改造，但这些改造非常简单，因为核心程序可以方便地移植，不用做任何修改。
虽然源代码就在下面，但是你现在可能不想细看，而且还懒得复制粘贴，那么有一个好消息，可以直接下载源代码，部署到自己的网站中就可以正常工作了。嗯，先让它工作起来，再来做个性化的修改，比先看懂代码再粘贴，的确是个更不错的思路。
一、UploadFile.asp，基本就是一个HTML文件
<%@LANGUAGE="VBSCRIPT" CODEPAGE="65001"%>
<% Option Explicit %>
<%Session.CodePage=65001%>
<%
' 此函数用来显示一些提示信息。
' 当上传之后，你可以将一些反馈信息（如成功还是失败等）
' 放在Session变量里，然后在相应的页面中将信息显示出来。
' 以下两个函数正是用来做这件事
Function ShowInfo()
ShowInfo = ShowInfoFrom("ssnInfo", True)
End Function
Public Function ShowInfoFrom(ByRef sSessionName, ByVal bDelete)
Dim s, i, aInfo, ll, lu, sT
On Error Resume Next
aInfo = Session(sSessionName)
If Err.Number <> 0 Then
ShowInfo = ""
Exit Function
End If
ll = LBound(aInfo)
If Err.Number = 0 Then
lu = UBound(aInfo)
For i = ll to lu
sT = aInfo(i)
If Len(sT) > 0 Then
s = s & "" & sT & ""
End If
Next
If Len(s) > 0 Then
s = "
"
End If
Else
s = aInfo
End If
On Error Goto 0
IF Len(s) > 0 Then
s = "
"
End If
ShowInfoFrom = s
If bDelete Then Session(sSessionName) = ""
End Function
%>
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<style type="text/css">
form label
{
width: 3em;
display: inline-block;
}
#idUploadInfo
{
display: none;
}
</style>
<script type="text/javascript">
var oImg = new Image();
oImg.src = "wait.gif";
function upload() {
document.getElementById('idUpload').style.display = 'none';
document.getElementById('idUploadInfo').style.display = 'block';
}
</script>
<title>无组件上传文件示例</title>
</head>
<body>
<div id="idInfo"><%= ShowInfo %></div>
<form name="fmUpload" action="UploadFile_Process.asp" method="post" enctype="multipart/form-data">
<div id="idUpload">
<p><label for="idFile">文件：</label><input type="file" name="File" /></p>
<p><label for="idSubmit"></label><input type="submit" name="submit" onclick="upload();" /></p>
</div>
<div id="idUploadInfo">
<img src="wait.gif" alt="正在上传……" />
<p>正在上传……</p>
</div>
<p>可以上传的文件类型：.jpg, .bmp, .gif</p>
<p>文件大小限制：1.5兆</p>
<p>(以上限制可以在后台修改。)</p>
</form>
</body>
</html>
二、UploadFile_Process.asp
<%@LANGUAGE="VBSCRIPT" CODEPAGE="65001"%>
<% Option Explicit %>
<%Session.CodePage=65001%>
<html-->
<!--#include file="CBeanFile.asp"-->
<head>
<title>上传文件处理</title>
<style type="text/css">
<!--
-->
</style>
<script type="text/javascript">
<!--
//-->
</script>
</head>
<body>
<div id="divWrapWrap">
<div id="divWrap">
<div id="divWrap_Content">
<div class="doodleBox">
<div class="header"><strong>上传文件处理</strong></div>
<div class="body">
<%
AvoidDuplicateSubmit_Lock ' 防止多次提交
Dim bean
Set bean = New CBeanFileForExample
If bean.validate() Then
' 如果通过验证，bean文件会自己处理上传的过程，这里什么也不用做，当然你可以添加一些
' 自定义消息，如上传成功之类的提示信息在这里。实际上bean连这种提示信息也做好了。
Else
' 如果没有通过验证呢？实际上bean文件也做了相应的处理，你也可以在这里什么都不做
Response.Write("没有选择文件")
End If
Set bean = Nothing
%>
</div>
</div>
</div>
</div>
</div>
</body>
</html>
<%
' 返回到前一页
Response.Redirect Request.ServerVariables("HTTP_REFERER")
'
' 防止多次重复提交相同的数据
'
Function AvoidDuplicateSubmit_Lock()
Session("ssnlPostCount") = Clng(Session("ssnlPostCount")) + 1
If Session("ssnlPostCount") > 1 Then
Session("errors") = "您已经提交过了"
Session("ssnlPostCount") = 0
Response.Write(Session("errors"))
Response.Write("<a href='" & Request.ServerVariables("HTTP_REFERER") & "'>返回</a>")
Response.End
End If
AvoidDuplicateSubmit_Unlock
End Function
'
' 防止多次重复提交相同的数据
'
Function AvoidDuplicateSubmit_Unlock()
Session("ssnlPostCount") = 0
End Function
%>
三、CBeanFile.asp 文件
<!--#include file="CFormDataGetter.asp"-->
<%
Class CBeanFileForExample
Private oForm
Private oFile
' 文件大小限制
Private lSizeLimited
' 文件上传到哪个文件夹下？
Private sPathForUpload
' 文件保存到数据库的哪个表中？
Private sTableRecordsUpload
Private sUserName
' 缩略图的宽度与高度的最大值的限制
Private lThumbnailDimentionSizeLimit
Private Function bValidateExp(ByRef sPattern, ByRef s)
Dim regEx
Set regEx = Server.CreateObject("VBScript.RegExp")
regEx.Global = True
regEx.IgnoreCase = True
regEx.Pattern = sPattern
bValidateExp = regEx.Test(s)
Set regEx = Nothing
End Function
Private Sub Class_Initialize()
Set oForm = New CFormDataGetter
Set oFile = New CFile
' 限定文件大小为1.5兆
Me.SizeLimited = (1024 * 1024) * 1.5
Me.PathForUpload = "Upload"
Me.TableRecordsUpload = "MF_Gallery"
Me.UserName = ""
Me.LogPath = ""
Me.LogFileName = "DataRead.xml"
Me.ThumbnailDimentionSizeLimit = 200
Me.GetRequest
End Sub
Private Sub Class_Terminate()
Set oForm = Nothing
Set oFile = Nothing
End Sub
Public Sub GetRequest()
Set oFile = oForm.GetFile("File")
End Sub
Public Function Validate()
Validate = True
If Me.Form.FormSize <= 0 Then
AddInfo("没有选择文件")
Validate = False
Else
If Me.File Is Nothing Then
AddInfo("上传文件出现未知错误，请确认上传方式是否正确 （请检查<form></form>元素的 enctype 属性设置）")
Validate = False
Else
If Me.File.Size <= 0 Then
AddInfo("没有选择文件或者文件大小为 0 字节")
Validate = False
End If
End If
End If
If Validate Then
' 开始对上传的文件进行分析
Dim bnsFileFlag, sFileType
bnsFileFlag = LeftB(Me.File.BinaryStream, 3)
' 对文件类型进行检测
Select Case Me.Form.ConvertBinaryToString(bnsFileFlag)
Case "GIF"
Case Else
Select Case LeftB(bnsFileFlag, 2)
Case Me.Form.ConvertStringToBinary("BM"), Me.Form.ConvertStringToBinary("BA"), Me.Form.ConvertStringToBinary("CI"), Me.Form.ConvertStringToBinary("CP"), Me.Form.ConvertStringToBinary("IC"), Me.Form.ConvertStringToBinary("PT")
Case ChrB(&HFF) & ChrB(&HD8)
' 有可能是JPEG格式文件
Case Else
AddInfo "目前不支持此文件（ " & Me.File.Name & " ）的类型，不能上传"
Validate = False
End Select
End Select
End If
' 检测文件大小是否超限
If Validate Then
If Me.File.Size > Me.SizeLimited Then
AddInfo "目前最大只能上传大小为 " & Me.SuitableUnit(Me.SizeLimited) & " 的文件，而你选择的文件( " & Me.File.Name & " )的大小为 " & Me.SuitableUnit(Me.File.Size) & "，超出了限制"
Validate = False
End If
End If
If Validate Then
' 通过所有的检测，开始上传
' 检测指定的上传路径是否存在
Dim oFSTest
Set oFSTest = Server.CreateObject("Scripting.FileSystemObject")
If Not oFSTest.FolderExists(Server.MapPath(Me.PathForUpload)) Then
' 如果不存在则创建一个
oFSTest.CreateFolder(Server.MapPath(Me.PathForUpload))
End if
Set oFSTest = Nothing
' 上传目的地路径
Dim sPermanentLink, oMF, sSQL, sState, oDB
sState = Me.File.Save(Server.MapPath(Me.PathForUpload) & "\" & Me.File.Name, 2)
If sState = "OK" Then
AddInfo("上传文件成功，文件链接地址为：<a href=""" & Me.PathForUpload & "/" & Me.File.Name & """ target=""_blank"" title=""点击查看"">" & Me.PathForUpload & "/" & Me.File.Name & "</a>")
Else
AddInfo sState
Validate = False
End If
End IF
End Function
Public Property Get Form()
Set Form = oForm
End Property
Public Property Let Form(ByRef o)
Set oForm = o
End Property
Public Property Get File()
Set File = oFile
End Property
Public Property Let File(ByRef o)
Set oFile = o
End Property
Public Property Get SizeLimited()
SizeLimited = lSizeLimited
End Property
Public Property Let SizeLimited(ByVal l)
lSizeLimited = l
End Property
Public Property Get PathForUpload()
PathForUpload = sPathForUpload
End Property
Public Property Let PathForUpload(ByRef s)
sPathForUpload = s
End Property
Public Property Get TableRecordsUpload()
TableRecordsUpload = sTableRecordsUpload
End Property
Public Property Let TableRecordsUpload(ByRef s)
sTableRecordsUpload = s
End Property
Public Property Get UserName()
UserName = sUserName
End Property
Public Property Let UserName(ByRef s)
sUserName = s
End Property
Public Property Get LogPath()
ON Error Resume Next
LogPath = Session("ssnLogPath")
If Err.number <> 0 Then
LogPath = ""
End If
On Error Goto 0
End Property
Public Property Let LogPath(ByRef s)
Session("ssnLogPath") = s
End Property
Public Property Get LogFileName()
On Error Resume Next
LogFileName = Session("ssnLogFileName")
If Err.number <> 0 then
LogFileName = "DataReadLog.xml"
end If
On Error Goto 0
End Property
Public Property Let LogFileName(ByRef s)
Session("ssnLogFileName") = s
End Property
Public Property Get ThumbnailDimentionSizeLimit()
ThumbnailDimentionSizeLimit = lThumbnailDimentionSizeLimit
End Property
Public Property Let ThumbnailDimentionSizeLimit(ByVal l)
lThumbnailDimentionSizeLimit = l
End Property
'
' 将以字节为单位的数字转换成合适单位的值
'
Public Function SuitableUnit(ByVal lB)
Dim i, lVal, aUnit
aUnit = Array("B", "KB", "MB", "GB", "TB")
lVal = Abs(lB)
i = 0
While lVal >= 1024 And i < UBound(aUnit)
i = i + 1
lVal = lVal / 1024
Wend
SuitableUnit = Sgn(lB) * Round(lVal, 2) & " " & aUnit(i)
End Function
' 添加信息
Public Function AddInfo(ByRef s)
AddInfo2 s, "ssnInfo"
End Function
' 添加信息到
Public Function AddInfo2(ByRef s, ByRef sSessionName)
Dim aInfo, ll, lu
If Len(s) <= 0 Then
Exit Function
End If
On Error Resume Next
aInfo = Session(sSessionName)
If Err.Number <> 0 Then
aInfo = ""
End If
Err.Clear
'测试已有信息是否是数组
ll = LBound(aInfo)
If Err.Number <> 0 Then
' 不是数组
If Len(aInfo) > 0 Then
aInfo = Array(aInfo, s)
Else
aInfo = s
End If
Else
' 是数组
lu = UBound(aInfo)
Redim Preserve aInfo(lu + 1)
aInfo(lu+1) = s
End If
On Error Goto 0
Session(sSessionName) = aInfo
End Function
End Class
%>
四、CFile.asp 文件
<%
'****************************************************
'文件名: CFile.asp
'描 述：文件类
'
'
'****************************************************
'# *Using CFormDataGetter.asp*
Class CFile
' 完整的路径名＋文件名＋后缀名
Private sFullName
Private sDescription
Private sMIME
Private bnsContent
Private csClass
Private Sub Class_Initialize()
csClass = "CFile"
End Sub
Public Property Get FullName()
FullName = sFullName
End Property
Public Property Let FullName(ByRef sNewFullName)
sFullName = sNewFullName
End Property
' 获取文件的路径，不含文件名
Public Property Get Path()
Path = Left(sFullName, InStrRev(sFullName, "\"))
End Property
' 去掉路径的文件名＋后缀名
Public Property Get Name()
Name = Right(sFullName, Len(sFullName) - InStrRev(sFullName, "\"))
End Property
' 去掉路径后的文件名 (不要后缀名)
Public Property Get ShortName()
Dim i
i = InStrRev(Me.Name, ".")
If i > 0 Then
ShortName = Left(Me.Name, InStrRev(Me.Name, ".") - 1)
Else
ShortName = Me.Name
End If
End Property
Public Property Let Description(ByRef sNewDesc)
sDescription = sNewDesc
End Property
Public Property Get Description()
Description = sDescription
End Property
Public Property Let MIME(ByRef sNewMIME)
sMIME = sNewMIME
End Property
Public Property Get MIME()
MIME = sMIME
End Property
Public Property Get Size()
Size = LenB(Me.BinaryStream)
End Property
'
' 设置文件的二进制流
'
Public Property Let BinaryStream(ByRef bnsNewBinaryStream)
bnsContent = bnsNewBinaryStream
End Property
'
' 获取文件的文本
'
Public Property Get TextStream(ByRef sCharset)
Dim stm
Set stm = Server.CreateObject("ADODB.Stream")
stm.Type = 2
stm.Open
stm.WriteText bnsContent
stm.Position = 0
If Len(sCharset) > 0 Then stm.Charset = sCharset
TextStream = stm.ReadText
stm.Close
Set stm = Nothing
End Property
'
' 获取文件的二进制流
'
Public Property Get BinaryStream()
BinaryStream = bnsContent
End Property
' 后缀名
Public Property Get Ext()
Ext = Right(Me.Name, Len(Me.Name) - InStrRev(Me.Name, "."))
End Property
Private Sub CFile_Initialize()
sFullName = ""
sDescription = ""
sMIME = ""
bnsContent = ChrB(0)
End Sub
'
' 打开文件
'
Public Function Open(ByRef sFullName)
Dim stm
Me.FullName = sFullName
Set stm = Server.CreateObject("ADODB.Stream")
stm.Type = 2
stm.Mode = 3
stm.Open
stm.LoadFromFile sFullName
stm.Type = 1
bnsContent = stm.Read
stm.Close
Set stm = Nothing
End Function
Public Function Save(ByRef sFullName, ByVal iWriteMode)
Dim stm, bns
Const sSOURCE = "Save(sFullName, iWriteMode)"
'On Error Resume Next
If Trim(sFullName) = "" Or Right(sFullName, 1) = "\" Then Exit Function
Set stm = Server.CreateObject("ADODB.Stream")
stm.Type = 1
stm.Open
stm.Write bnsContent
stm.SaveToFile sFullName, iWriteMode
stm.Close
Set stm = Nothing
If err.number <> 0 Then
Save = "时间戳：" & Now() & " [" & csClass & "." & sSOURCE & "] 发生错误(sFullName = '" & sFullName & ", iWriteMode = '" & iWriteMode & ")。错误号：" & Err.number & "；错误描述：" & Err.Description & "；错误源：" & Err.Source & "；"
Else
Save = "OK"
End If
On Error Goto 0
End Function
End Class
%>
五、CFormDataGetter.asp 文件，上传文件最为核心的程序
<!--#include file="CFile.asp"-->
<%
'****************************************************
'文件名: CFormDataGetter.asp
'描 述：这是一个页面表单容器，可以分析每个表单元素的内容，也可用作无组件上传类。
'
'
'****************************************************
'# *Using CFile.asp*
Class CFormDataGetter
' 表单字节大小
Private lFormSize
' 表单数据
Private bnsFormData
' 表单数据中字段间的分隔符
private bnsDivider
Private bnsVbCrLf
Private lChunkBytes
Private lReadedBytes
' 字段分隔符
Public Property Get FieldDivider()
FieldDivider = bnsDivider
End Property
Public Property Get FormSize()
FormSize = lFormSize
End Property
Public Property Get FormBinaryData()
FormBinaryData = bnsFormData
End Property
Public Property Get Chunk()
Chunk = lChunkBytes
End Property
Public Property Let Chunk(ByVal l)
lChunkBytes = l
End Property
Public Property Get ReadedBytes()
ReadedBytes = lReadedBytes
End Property
Public Property Let ReadedBytes(ByVal l)
lReadedBytes = l
End Property
Public Property Get LogPath()
On Error Resume Next
LogPath = Session("ssnLogPath")
If Err.number <> 0 Then
LogPath = ""
End If
On Error Goto 0
End Property
Public Property Let LogPath(ByVal s)
Session("ssnLogPath") = s
End Property
Public Property Get LogFileName()
On Error Resume Next
LogFileName = Session("ssnLogFileName")
If Err.number <> 0 Then
LogFileName = "DataReadLog.xml"
End If
On Error Goto 0
End Property
Public Property Let LogFileName(ByRef s)
Session("ssnLogFileName") = s
End Property
Private Sub Class_Initialize
' 分块数
Dim lChunks, i, lBytesToRead, oStream
bnsVbCrLf = ChrB(13) & ChrB(10)
' 获取表单的总字节数
lFormSize = Request.TotalBytes
Me.Chunk = 100 * 1024
Me.ReadedBytes = 0
If lFormSize > 0 And Me.Chunk > 0 Then
If lFormSize Mod Me.Chunk = 0 Then
lChunks = lFormSize \ Me.Chunk
Else
lChunks = lFormSize \ Me.Chunk + 1
End If
Set oStream = Server.CreateObject("ADODB.Stream")
oStream.Type = 1
oStream.Mode = 3
oStream.Open
' 分块读取数据
For i = 1 To lChunks
' 如果剩余的数据多于分块，则读进一个分块，否则读进剩余数据
If lFormSize - Me.ReadedBytes > Me.Chunk Then
lBytesToRead = Me.Chunk
Else
lBytesToRead = lFormSize - Me.ReadedBytes
End If
oStream.Write Request.BinaryRead(lBytesToRead)
Me.ReadedBytes = Me.ReadedBytes + lBytesToRead
' 记录读进了多少数据
On Error Resume Next
'LogDataReaded i, Now(), Me.ReadedBytes, lFormSize
'LogDataReadInSession Me.ReadedBytes / lFormSize
On Error Goto 0
Next
oStream.Position = 0
bnsFormData = oStream.Read
Set oStream = Nothing
' 下面开始查找表单数据中字段间的分隔符
Dim lIndex
lIndex = CLng(InstrB(bnsFormData,bnsVbCrLf))
If lIndex >= 1 Then
' 成功获取到字段间的分隔符
bnsDivider = LeftB(bnsFormData, lIndex - 1)
Else
'
bnsDivider = ""
End If
Else
bnsFormData = ""
bnsDivider = ""
End If
End Sub
'
' 记录上传了多少？
'
Public Function LogDataReaded(ByVal lSerialNumber, ByVal sTimeStamp, ByVal lBytesReaded, ByVal lTotalBytes)
Dim sFileFullVirtualName, sFileContent, oFS, oFile
sFileFullVirtualName = Me.LogPath & Me.LogFileName
sFileContent = "<?xml version=""1.0"" encoding=""utf-8""?>"
sFileContent = sFileContent & "<datareaded>"
sFileContent = sFileContent & "<serialnumber>" & lSerialNumber & "</serialnumber>"
sFileContent = sFileContent & "<timestamp>" & sTimeStamp & "</timestamp>"
sFileContent = sFileContent & "<bytesreaded>" & lBytesReaded & "</bytesreaded>"
sFileContent = sFileContent & "<totalbytes>" & lTotalBytes & "</totalbytes>"
sFileContent = sFileContent & "</datareaded>"
Set oFS = Server.CreateObject("Scripting.FileSystemObject")
Set oFile = oFS.CreateTextFile(Server.MapPath(sFileFullVirtualName), True)
oFile.Write sFileContent
oFile.Close
Set oFile = Nothing
Set oFS = Nothing
End Function
'
' 获取指字字段名的二进制串
'
Public Function GetFieldBinaryData(ByRef sFieldName)
Dim bnsBorder, lIndex, lFieldStart, lFieldEnd, lFieldSize
If Me.FormSize <= 0 Then
GetFieldBinaryData = ""
Exit Function
End If
' 字段开始边界
bnsBorder = bnsDivider & bnsVBCrLf & ConvertStringToBinary("Content-Disposition: form-data; name=""" & sFieldName & """") & bnsVbCrLf & bnsVbCrLf
lIndex = InStrB(1, Me.FormBinaryData, bnsBorder)
If lIndex > 0 Then
' 定位到字段内容的开始位置
lFieldStart = lIndex + LenB(bnsBorder)
' 定位到字段内容的结束位置
lFieldEnd = InStrB(lFieldStart, Me.FormBinaryData, bnsDivider) - 3
' 计算字段内容的字节长度
lFieldSize = lFieldEnd - lFieldStart + 1
GetFieldBinaryData = MidB(Me.FormBinaryData, lFieldStart, lFieldSize)
Else
GetFieldBinaryData = bnsBorder
End If
End Function
'
' 获取指定字段名的文本串
'
Public Function GetFieldTextData(ByRef sFieldName)
GetFieldTextData = ConvertBinaryToString(GetFieldBinaryData(sFieldName))
End Function
'
' 将一个文本字符串转换成二进制字符串
'
Public Function ConvertStringToBinary(ByRef s)
Dim bns, i
For i = Len(s) To 1 Step -1
bns = ChrB(Asc(Mid(s, i, 1))) & bns
Next
ConvertStringToBinary = bns
End Function
'
' 将一个二进制字符串转换成文本字符串
' ------------------------------------
' 此方法在localhost上能正确使用，得到理想的效果。但是将网站上传到服务器上时，有时会失灵。
' 在别的地方看到另一种程序来将二进制字符转换成文本字符串，和我的差不多，但是对于Ascii码大于等于128的，进行跳过，然后使用AscW()对连接两个字符同时进行转换。如下
' Public Function ConvertBinaryToString(ByVal bns)
' Dim i, s, sClow
' For i = 1 To LenB(bns)
' sClow = MidB(bns, i, 1)
' If AscB(sClow) < 128 Then
' s = s & Chr(AscB(sClow))
' Else
' i = i + 1
' If i <= LenB(bns) Then s = s & Chr(AscW(MidB(bns, i, 1) & sClow))
' End If
' Next
' ConvertBinaryToString = s
' End Function
'
Public Function ConvertBinaryToString(ByVal bns)
Dim s, i
s = ""
For i = LenB(bns) To 1 Step -1
s = Chr(AscB(MidB(bns, i, 1))) & s
Next
ConvertBinaryToString = s
End Function
'
' 获取文件
'
Public Function GetFile(ByRef sFieldName)
Dim bnsBorder, lIndex, lFieldStart, lFieldEnd, lFieldSize, oFile
If Me.FormSize <= 0 Then
Set GetFile = Nothing
'AddInfo "表单大小为0字节"
Exit Function
Else
'AddInfo "表单大小为 " & Me.FormSize & " 字节"
End If
' 文件二进制流开始边界
bnsBorder = bnsDivider & bnsVbCrLf & ConvertStringToBinary("Content-Disposition: form-data; name=""" & sFieldName & """; filename=""")
lIndex = InStrB(1, Me.FormBinaryData, bnsBorder)
If lIndex > 0 Then
Set oFile = New CFile
' 以下获取文件完整路径名
' 定位到第1个字符
lFieldStart = lIndex + LenB(bnsBorder)
' 定位到最后1个字符
lFieldEnd = InStrB(lFieldStart, Me.FormBinaryData, bnsVbCrLf) - 2
' 计算路径字段内容大小
lFieldSize = lFieldEnd - lFieldStart + 1
If lFieldSize > 0 Then
' 文件名
oFile.FullName = Cbns2TextStream(MidB(Me.FormBinaryData, lFieldStart, lFieldSize), "utf-8")
' 以下获取文件的MIME类型
Dim lPos
lPos = InStrB(lFieldEnd, Me.FormBinaryData, ConvertStringToBinary("Content-Type: "))
If lPos > 0 Then
lFieldStart = lPos + LenB(ConvertStringToBinary("Content-Type: "))
lFieldEnd = InStrB(lFieldStart, Me.FormBinaryData, bnsVbCrLf & bnsVbCrLf) - 1
lFieldSize = lFieldEnd - lFieldStart + 1
If lFieldSize > 0 Then
oFile.MIME = ConvertBinaryToString(MidB(Me.FormBinaryData, lFieldStart, lFieldSize))
Else
oFile.MIME = ""
End If
Else
oFile.MIME = ""
End If
' 以下获取文件内容
lPos = lFieldEnd
lFieldStart = InStrB(lPos, Me.FormBinaryData, bnsVbCrLf & bnsVbCrLf) + 4
lFieldEnd = InStrB(lFieldStart, Me.FormBinaryData, bnsDivider) - 3
lFieldSize = lFieldEnd - lFieldStart + 1
If lFieldSize <= 0 Or lFieldStart <= 0 Then
oFile.BinaryStream = ""
Else
Dim stmFormBinaryData, stmFileBinaryData
Set stmFormBinaryData = Server.CreateObject("ADODB.Stream")
Set stmFileBinaryData = Server.CreateObject("ADODB.Stream")
stmFormBinaryData.Type = 1
stmFormBinaryData.Open
stmFormBinaryData.Write Me.FormBinaryData
stmFileBinaryData.Type = 1
stmFileBinaryData.Open
' 在ADODB.Stream对象里，索引从0开始，而不是VB的其他地方，索引从1开始
'stmFormBinaryData.Position = lFieldStart - 1
stmFormBinaryData.Position = 0
'stmFormBinaryData.CopyTo stmFileBinaryData, lFieldSize
stmFormBinaryData.CopyTo stmFileBinaryData
' 使用MidB()或者LeftB()返回的字符串会自动添加一些别的信息，导致结果二进制串与原来的不太一样
'oFile.BinaryStream = MidB(Me.FormBinaryData, lFieldStart, lFieldSize)
stmFileBinaryData.Position = lFieldStart - 1
oFile.BinaryStream = stmFileBinaryData.Read(lFieldSize)
stmFormBinaryData.Close
stmFileBinaryData.Close
Set stmFormBinaryData = Nothing
Set stmFileBinaryData = Nothing
End If
Set GetFile = oFile
Else
oFile.BinaryStream = ""
Set GetFile = oFile
End If
Else
' 未找到文件二进制流开始边界
'AddInfo "未找到文件二进制流开始边界"
'AddInfo "表单数据：" & Cbns2TextStream(Me.FormBinaryData, "utf-8")
Set GetFile = Nothing
Exit Function
End If
End Function
'
' 保存文件
'
Public Function SaveFile(ByRef sFieldName, ByRef sFullName, ByVal iWriteMode)
Dim bnsBorder, lIndex, lFieldStart, lFieldEnd, lFieldSize, oFile
If Me.FormSize <= 0 Then
Set GetFile = Nothing
Exit Function
End If
' 文件二进制流开始边界
bnsBorder = bnsDivider & bnsVbCrLf & ConvertStringToBinary("Content-Disposition: form-data; name=""" & sFieldName & """; filename=""")
lIndex = InStrB(1, Me.FormBinaryData, bnsBorder)
If lIndex > 0 Then
Set oFile = New CFile
' 以下获取文件完整路径名
' 定位到第1个字符
lFieldStart = lIndex + LenB(bnsBorder)
' 定位到最后1个字符
lFieldEnd = InStrB(lFieldStart, Me.FormBinaryData, bnsVbCrLf) - 2
' 计算路径字段内容大小
lFieldSize = lFieldEnd - lFieldStart + 1
' 文件名
oFile.FullName = ConvertBinaryToString(MidB(Me.FormBinaryData, lFieldStart, lFieldSize))
' 以下获取文件的MIME类型
Dim lPos
lPos = lFieldEnd
lFieldStart = lPos + 18
lFieldEnd = InStrB(lFieldStart, Me.FormBinaryData, bnsVbCrLf & bnsVbCrLf) - 1
lFieldSize = lFieldEnd - lFieldStart + 1
oFile.MIME = ConvertBinaryToString(MidB(Me.FormBinaryData, lFieldStart, lFieldSize))
' 以下获取文件内容
lPos = lFieldEnd
lFieldStart = lPos + 5
lFieldEnd = InStrB(lFieldStart, Me.FormBinaryData, bnsDivider) - 3
lFieldSize = lFieldEnd - lFieldStart + 1
oFile.BinaryStream = MidB(Me.FormBinaryData, lFieldStart, lFieldSize)
' 开始保存文件
Dim stm, stmFile
If Trim(sFullName) = "" Or Right(sFullName, 1) = "\" Then Exit Function
Set stm = Server.CreateObject("ADODB.Stream")
Set stmFile = Server.CreateObject("ADODB.Stream")
stm.Type = 1
stm.Mode = 3
stm.Open
'stm.Write MidB(Me.FormBinaryData, lFieldStart, lFieldSize)
stm.Write Me.FormBinaryData
stmFile.Type = 1
stmFile.Open
stm.Position = lFieldStart - 1
stm.CopyTo stmFile, lFieldSize
stmFile.SaveToFile sFullName, iWriteMode
stm.Close
stmFile.Close
Set stm = Nothing
Set stmFile = Nothing
Set SaveFile = oFile
Else
Set SaveFile = Nothing
Exit Function
End If
End Function
'
' 将指定的二进制串转换成特定编码的文本
'
Public Function Cbns2TextStream(ByRef bns, ByRef sCharset)
Dim stm
Set stm = Server.CreateObject("ADODB.Stream")
stm.Type = 2
stm.Open
stm.WriteText bns
stm.Position = 0
If Len(sCharset) > 0 Then stm.Charset = sCharset
Cbns2TextStream = stm.ReadText
stm.Close
Set stm = Nothing
End Function
End Class
%>
如果你看到这里，但愿你没有它们吓倒。你可以复制它们，或者直接下载源代码，源代码正是我将以上这些代码拷贝下来保存为文件，将压缩成一个压缩文件的，它们经过了测试，可以正常运行。你下载源代码解压缩后可能会发现其中还包含了一个图片文件，而我在上面却没有提到它，因为它并不是必要的组成部分，只是一个提示上传正在进行的视觉符号而已，你可以替换成其他图片或者文字。