一个能防止改名木马漏洞的无组件上传类

现在流行的asp上传组件除了无惧的化境之外，最多的可能就是ewebEditor 和Fckeditor的上传是，但是经过测试都很难防止改名为gif和asp文件上传，在FckEditor中改名后的asp木马不能直接上传，系统会检测到 <%等字符而拒绝，但是经过修改后的asp木马再改名为gif后却可以顺利上传，如在文件前端加上许多空行，或对木马进行加密处理。当然有人会认为木马传到服务器后会被杀掉，但是做过免杀的木马却会漏网。基于这些原因，本人开发了一个可以从根本上解决这个问题的无组件上传类。经过测试常用的文件格式均可通过。做法是对上传的文件进行格式分析，不符合的格式不允许上传，这样就从根本上解决了这个问题。现贴上来请大家指教。
1、文件upfile.asp
<%
'**************************************************************************
'*  类文件名称:upfile.asp
'*  作者:马如风（Melon）
'*  邮箱:mqmelon0@163.com
'*  版权:=====筱风工作室(R)2004.1-2004.3=====
'*  内容:不用组件上传文件类
'*  用法:在接收表单内容的文件中定义UpFileClass类对象，用GetData方法
'*      读取文件内容,并使用FileInfo类的SaveToFile方法存入指定文件
'*  例子:set FileUP=new UpFileClass
'* FileUp.GetData
'*      set file1=FileUP.upFile("表单元素名")
'* filename=path&filename
'*      file1.SaveToFile(server.mappath(filename))
'*      set FileUp=nothing
'**************************************************************************
%>
<%
response.charset="gb2312"

Dim BinaStream '全局变量
'dim FileSavePath   

Class UpFileClass  '类别名称
'定义Dictionary变量，用于保存上传的信息
Dim upForm,upFile

'　类初始化过程
private sub Class_Initialize
'判断传递的数据，如无，则退出
if Request.TotalBytes <1 Then
Exit sub
End if
'FileSavePath=""  '全局变量负值
set BinaStream=Server.CreateObject("adodb.stream")
set upForm=New DictionaryClass
set upFile=New DictionaryClass
End sub

'类清除过程
Private sub Class_Terminate
upFile.RemoveAll
upForm.RemoveAll
set upFile=nothing
set upForm=nothing
BinaStream.Close
set BinaStream=nothing
FileSavePath=""
End sub

'获取数据过程
Public sub GetData
Dim oFileInfo '用于保存文件信息的类对象
Dim oDataSeprator '用于保存分隔符信息，为二进制字符串
Dim oFindStart,oFindEnd '寻找指针
Dim oCrLf ' CHRB(13)&CHRB(10), 分隔数字
Dim oFormData ' 表单数据描述信息，文本串
Dim oFileStart ' 文件开始位置
Dim otmpStream ' 临时Stream 对象，用于中间周转字符串
Dim otmpBinaData ' 临时二进制字符串，用于中间周转
Dim oDataAllSize ' 所有二进制数值大小
Dim oFormName ' 表单元素名称
Dim oFormContent ' 表单元素内容
Dim oFormStart ' 表单元素开始位置
Dim oFormEnd ' 表单元素结束位置
Dim oFileFullName ' 带路径文件名

'变量初始化
set oFileInfo=new FileInfo
oDataSeprator=""
oFindStart=Clng(0)
oFindEnd=Clng(0)
oCrLf=chrB(13)&chrB(10)
oFormData=""
oFileStart=Clng(0)
set otmpStream=Server.CreateObject("adodb.stream")
otmpBinaData=""
oDataAllSize=Clng(0)
oFormName=""
oFormcontent=""
oFormStart=Clng(0)
oFormEnd=Clng(0)
oFileFullName=""
' 获得传递过来的二进制数据
if Request.TotalBytes <1 then
Error_Msg("发生数据错误，传递数据空或丢失！")
Exit sub
End if
BinaStream.Type=1 '二进制
BinaStream.Mode=3 '读写模式，1－读，2－写，3－读写
BinaStream.Open  '打开对象，准备读写
'开始读取所有上传的数据
'Thankful long(yrl031715@163.com)
'Fix upload large file.
'**********************************************
' 修正作者：long
' 联系邮件: yrl031715@163.com
' 修正时间：2007年5月6日
' 修正说明：由于iis6的Content-Length 头信息中包含的请求长度超过了 AspMaxRequestEntityAllowed 的值（默认200K）, IIS 将返回一个 403 错误信息.
'          直接导致在iis6下调试FCKeditor上传功能时，一旦文件超过200K,上传文件时文件管理器失去响应，受此影响，文件的快速上传功能也存在在缺陷。
'          在参考 宝玉 的 Asp无组件上传带进度条 演示程序后作出如下修改，以修正在iis6下的错误。

Dim nTotalBytes, nPartBytes, ReadBytes
ReadBytes = 0
nTotalBytes = Request.TotalBytes
'循环分块读取
Do While ReadBytes < nTotalBytes
'分块读取
nPartBytes = 64 * 1024 '分成每块64k
If nPartBytes + ReadBytes > nTotalBytes Then
nPartBytes = nTotalBytes - ReadBytes
End If
BinaStream.Write Request.BinaryRead(nPartBytes)
ReadBytes = ReadBytes + nPartBytes
Loop
'读取完毕
BinaStream.Position=0
otmpBinaData=BinaStream.Read
oDataAllSize=BinaStream.Size
'获得分隔符
oDataSeprator=MidB(otmpBinaData,1,InstrB(1,otmpBinaData,oCrLf)-1)
'给寻找指针付值
oFindStart=Lenb(oDataSeprator)+2
oFindEnd=oFindStart
'分解名项目，且保存其值
While oFindStart+2 <oDataAllSize
otmpStream.Type=1
otmpStream.MOde=3
otmpStream.Open
oFindEnd=InstrB(oFindStart,otmpBinaData,oCrLf&oCrLf)+3
'此时，oFindEnd指向内容，oFindStart指向描述
BinaStream.Position=oFindStart
BinaStream.CopyTo otmpStream,oFindEnd-oFindStart
'把表单描述存入oFormData
otmpStream.Position=0
otmpStream.Type=2 '设为文本类型数据
otmpStream.Charset="gb2312" '设字符集为中文
oFormData=otmpStream.ReadText '保存数据为文本
'查找表单项目名称
oFormStart=Instr(1,oFormData,"name=",1)+len("name=")+1
oFormEnd=Instr(oFormStart,oFormData,"""",1)
oFormName=Mid(oFormData,oFormStart,oFormEnd-oFormStart)
'调试开始
'open_appe_txt "debug.txt","oFormData="&chr(13)&chr(10)&oFormData
'open_appe_txt "debug.txt","判断前："&chr(13)&chr(10)&"oFormStart="&oFormStart&"oFormEnd="&oFormEnd&"oFormName="&oFormName
'调试结束
'判断是否为文件
if Instr(oFormEnd,oFormData,"filename=",1)>0 Then
'是文件，则取文件属性
'找到文件名字
oFormStart=Instr(oFormEnd,oFormData,"filename=",1)+len("filename=")+1
'加1是为了去掉文件名字前面的引号
oFormEnd=Instr(oFormStart,oFormData,"""",1)
'此时，oFormEnd指向下一个描述的前一个位置，减1是为去掉引号
'获得文件信息
'获得带路径文件名称
oFileFullName=Mid(oFormData,oFormStart,oFormEnd-oFormStart)
'分解文件名称
oFileInfo.FileName=GetFileName(oFileFullName)
oFileInfo.FileExt=GetFileExt(oFileFullName)
oFileInfo.FilePath=GetFilePath(oFileFullName)
'获得文件类型
oFormStart=Instr(oFormEnd,oFormData,"Content-Type:",1)+len("Content-Type:")
oFormEnd=Instr(oFormStart,oFormData,chr(13)&chr(10),1)
oFileInfo.FileType=Mid(oFormData,oFormStart,oFormEnd-oFormStart)
'获得文件内容起始点
oFileInfo.FileStart=oFindEnd
oFindStart=InstrB(oFindEnd,otmpBinaData,oDataSeprator)
'此时，oFindStart指向分隔符位置
oFileInfo.FileSize=oFindStart-oFindEnd-3
oFileInfo.FormName=oFormName
'把数据加入到upFile[Dictionary对象]中保存
'调试开始
'open_appe_txt "debug.txt","循环中(文件)："&chr(13)&chr(10)&"oFindStart="&oFindStart&"oFormName="&oFormName
'调试结束
upFile.add oFormName,oFileInfo
Else
'如果是表单元素，则取元素值
'关闭otmpStream对象，以便重新读取内容
otmpStream.Close
otmpStream.Type=1
otmpStream.Mode=3
otmpStream.Open
'找到内容结束位置
oFindStart=InstrB(oFindEnd,otmpBinaData,oDataSeprator)
'读出内容
BinaStream.Position=oFindEnd
BinaStream.CopyTo otmpStream,oFindStart-oFindEnd-3
otmpStream.Position=0
otmpStream.Type=2
otmpStream.Charset="gb2312"
oFormContent=otmpStream.ReadText
upForm.add oFormName,oFormContent
End if
'调整寻找指针位置
oFindStart=oFindStart+LenB(oDataSeprator)+1
'此时，寻找指针均指向下一描述
otmpStream.Close
WEnd '循环返回
'变量清空
otmpBinaData=""
set otmpBinaData=nothing
end sub '子程序到此结束

'获得文件路径程序
Private Function GetFilePath(FullPath)
if FullPath <>"" Then
GetFilePath=Left(FullPath,InstrRev(FullPath,"/"))
Else
GetFilePath=""
End if
End Function

'获得文件名程序
Private Function GetFileName(FullPath)
if FullPath <>"" Then
GetfileName=Mid(FullPath,InstrRev(FullPath,"/")+1)
Else
GetFileName=""
End if
End Function

'获得文件扩展名
Private Function GetFileExt(FullPath)
if FullPath <>"" Then
GetFileExt=Mid(FullPath,InstrRev(FullPath,".")+1)
Else
GetFileExt=""
End if
End Function

'类定义结束
End Class

'文件属性类定义开始
Class FileInfo
Dim FileName,FileSize,FileStart,FilePath,FileExt,FileType,FormName
'Dim FileSaveName

Private sub Class_Initialize
FileName=""
FileSize=0
FileStart=0
FilePath=""
FileExt=""
FileType=""
FormName=""
End sub

Private sub Class_Terminate
'空子程序
End sub


'把内容存入到服务器上指定位置和名称的文件
Public Function SaveToFile(tmpFileName)
Dim FileSaveStream,tmpStream,tmpReadStream,FullPath
Dim filePath,FileFullName,SpcPosition
'使用服务器路径
tmpFileName=s_SavePath&tmpFileName
FullPath=server.mappath(tmpFileName)
'加入
Dim mfileExt,tmpData
mfileExt=Mid(FullPath,InstrRev(FullPath,".")+1,Len(FullPath))
'加入2009.3.27

SaveFile=-1
if FullPath="" or Right(FullPath,1)="/" Then
Call Error_Msg("Error Occured when Save the file to appointed directory and fileName!：/n The fileName is not valid！")
Exit Function
Else
'替换/为/
FullPath=Replace(FullPath,"/","/")
'取出保存的目录
SpcPosition=InStrrev(FullPath,"/")
If spcposition=0 Then
filePath=s_curPath '使用程序所在目录
FileFullName=FullPath
Else
filePath=Mid(FullPath,1,SpcPosition-1)
FileFullName=Mid(FullPath,spcPosition+1,Len(Fullpath))
End if


If i_AutoRename=1 Then
'如果存在同名，则自动更名
tmpFileName=s_SavePath& autoRename(filePath,FileFullName)
FullPath=server.mappath(tmpFileName)
End if
End if

set FileSaveStream=Server.CreateObject("adodb.stream")
FileSaveStream.Type=1
FileSaveStream.Mode=3
fileSaveStream.Open
BinaStream.position=FileStart
BinaStream.CopyTo FileSaveStream,FileSize

BinaStream.position=FileStart
tmpData=BinaStream.read(30)

If mfileExt <>"" Then
If SniffPic(mfileExt,tmpData)=False Then
saveToFile=-1
Exit function
End if
End If

FileSaveStream.SaveToFile FullPath,2
FileSaveStream.Close
set FileSaveStream=nothing

SaveToFile=0

End Function

'获得文件保存的内容,返回二进制数据，可以用来存入数据库中
Public Function GetFileData()
BinaStream.Position=FileStart
GetFileData=BinaStream.Read(Filesize)
End Function

'测试一个文件是否存在
function AutoRename(filePath,FileFullName)
'如果一个文件存在，则自动更名
Dim oFSO,testFileName,testFileExt,extPosition,iCounter,sFileName
'返回值,默认直接返回
AutoRename=fileFullName
'取得文件名
extPosition=InstrRev(FileFullName,".")
If extPosition>0 Then
testFileName=Mid(FileFullName,1,extPosition-1)
testFileExt=Mid(FileFullName,extPosition+1,Len(FileFullName))
Else
testFileName=FileFullName
testFileExt=""
End If
sFileName=fileFullName
Set oFSO = Server.CreateObject( "Scripting.FileSystemObject" )
'测试指定目录是否存在
if not (oFSO.FolderExists( filePath)) then
'不存在，则生成目录,然后退出
oFSO.CreateFolder(filePath)
else
iCounter = 0

Do While ( True )
Dim sFilePath
sFilePath = filePath & "/" & sFileName

If ( oFSO.FileExists( sFilePath ) ) Then
iCounter = iCounter + 1
sFileName =  testFileName & "(" & iCounter & ")." & testFileExt
Else
Exit Do
End If
Loop

If iCounter>0 Then
AutoRename=sFileName
End if
end if
End function

End Class
'FileInfo类定义结束
%>
<%
function open_appe_txt(txt_name,txt_content)
dim MyFileObject,MyTextFile
set MyFileObject=server.CreateObject("Scripting.FileSystemObject")
set MyTextFile=MyFileObject.OpenTextFile(server.MapPath(txt_name),8,true)
MyTextFile.WriteLine(txt_content)
MyTextFile.Close
set MyTxtFile=nothing
set MyFileObject=nothing
end function
%>
<%
'显示错误信息程序
sub Error_Msg(eMsg,eUrl)
%>
<script>
alert(' <%=eMsg%>');
if (""==' <%=eUrl%>')
history.back();
else
document.location=' <%=eUrl%>';
</script>
<%
End Sub


'马如风2009.3.26
Function Bin2Str(Bin)
  Dim I, Str
  For I=1 to LenB(Bin)
    clow=MidB(Bin,I,1)
    if AscB(clow) <128 then
      Str = Str & Chr(ASCB(clow))
    Else
      I=I+1
      if I <= LenB(Bin) then Str = Str & Chr(ASCW(MidB(Bin,I,1)&clow))
    end If
  Next
  Bin2Str = Str
End Function

function binToNum(bin)
    '二进制转为 Numeric
        dim i:binToNum=0
        for i=lenB(bin) to 1 step -1
            binToNum=binToNum*256+ascB(midB(bin,i,1))
        next 'shawl.qiu code'

end function

Function SniffPic(sFileExt,sData)
SniffPic=false
If sfileExt="" Then
Exit function
End if

Dim tmpExt,tmpData,tmpI,tmpSource

tmpExt=UCase(sFileExt)
If lenb(sData) <10 Then
Exit Function
End If

Select Case tmpExt
Case "GIF"
For tmpI=1 To 3
tmpData=tmpData & Hex(binToNum(Midb(sData,tmpI,1)))
Next
tmpSource=Hex("&H47") & Hex("&H49") & Hex("&H46")
If tmpData=tmpSource Then
SniffPic=true
End if
Case "JPG"
For tmpI=1 To 3
tmpData=tmpData & Hex(binToNum(Midb(sData,tmpI,1)))
next
tmpSource=CStr(Hex("&HFF")) & CStr(Hex("&HD8")) & CStr(Hex("&HFF"))
If tmpData=tmpSource Then
SniffPic=true
End if
Case "PNG"
For tmpI=1 To 4
tmpData=tmpData & Hex(binToNum(Midb(sData,tmpI,1)))
next
tmpSource=CStr(Hex("&H89")) & CStr(Hex("&H50")) & CStr(Hex("&H4E")) & CStr(Hex("&H47"))
If tmpData=tmpSource Then
SniffPic=true
End if
Case "BMP"
For tmpI=1 To 2
tmpData=tmpData & Hex(binToNum(Midb(sData,tmpI,1)))
next
tmpSource=CStr(Hex("&H42")) & CStr(Hex("&H4D"))
If tmpData=tmpSource Then
SniffPic=true
End if
Case "PCX"
For tmpI=1 To 4
tmpData=tmpData & Hex(binToNum(Midb(sData,tmpI,1)))
next
tmpSource=CStr(Hex("&H0A")) & CStr(Hex("&H05")) & CStr(Hex("&H01")) & CStr(Hex("&H08"))
If tmpData=tmpSource Then
SniffPic=true
End if
Case "TIF"
For tmpI=1 To 4
tmpData=tmpData & Hex(binToNum(Midb(sData,tmpI,1)))
next
tmpSource=CStr(Hex("&H49")) & CStr(Hex("&H49")) & CStr(Hex("&H2A")) & CStr(Hex("&H00"))
If tmpData=tmpSource Then
SniffPic=true
End If
Case "DOC"
For tmpI=1 To 8
tmpData=tmpData & Hex(binToNum(Midb(sData,tmpI,1)))
next
tmpSource=CStr(Hex("&HD0")) & CStr(Hex("&HCF")) & CStr(Hex("&H11")) & CStr(Hex("&HE0")) & CStr(Hex("&HA1"))
tmpSource=tmpSource & CStr(Hex("&HB1")) & CStr(Hex("&H1A")) & CStr(Hex("&HE1"))
If tmpData=tmpSource Then
SniffPic=true
End If
Case "XLS"
For tmpI=1 To 8
tmpData=tmpData & Hex(binToNum(Midb(sData,tmpI,1)))
next
tmpSource=CStr(Hex("&HD0")) & CStr(Hex("&HCF")) & CStr(Hex("&H11")) & CStr(Hex("&HE0")) & CStr(Hex("&HA1"))
tmpSource=tmpSource & CStr(Hex("&HB1")) & CStr(Hex("&H1A")) & CStr(Hex("&HE1"))
If tmpData=tmpSource Then
SniffPic=true
End If
Case "RAR"
For tmpI=1 To 10
tmpData=tmpData & Hex(binToNum(Midb(sData,tmpI,1)))
next
tmpSource=CStr(Hex("&H52")) & CStr(Hex("&H61")) & CStr(Hex("&H72")) & CStr(Hex("&H21")) & CStr(Hex("&H1A")) & CStr(Hex("&H07"))
tmpSource=tmpSource & CStr(Hex("&H00")) & CStr(Hex("&HCF")) & CStr(Hex("&H90")) & CStr(Hex("&H73"))
If tmpData=tmpSource Then
SniffPic=true
End If
Case Else
sniffpic=true
End Select
End function
'马如风2009.3.26
%>
2、up.asp
<%@codepage=936%>
<html> <meta http-equiv="Content-Type" content="text/html; charset=gb2312">
<body topmargin=0  rightmargin=0  leftmargin=0>
<%
'*******************************************
'* 文件：up.asp
'* 功能：上传文件
'* 输入：无
'* 输出：无
'* 修改日期：2004.3.5
'* 作者：马如风
'* 版权声明：筱风工作室版权所有（2004－2005）
'*******************************************
%>
<!--#include file="upfile.asp"-->
<!--#include file="dic.asp"-->
<!--#include file="setup.asp"-->

<%
fname=""&year(now)&month(now)&day(now)&hour(now)&minute(now)&second(now)&""
if request("up_act")="up_files" then

set FileUP=new upFileClass
FileUP.GetData

set file1=FileUP.upFile.item("file1")
If i_rename=0 then
'filename=s_SavePath&fname&"."&file1.FileExt
filename=fname&"."&file1.FileExt
else
filename=file1.filename
End if

'对文件格式进行判断处理
If InStr(S_FileExt,UCase(file1.fileExt))=0 then
error_msg "Your File"&Chr(96)& "s Type is not allowed!/n",""
response.End()
end if

if int(file1.filesize/1024)>i_upSize then
Error_Msg "The FileSize is Exceed "&i_upSize&"KB!/n",""
response.End()
end if

'
Dim tmpResult
'tmpResult=file1.SaveToFile(server.mappath(filename))
tmpResult=file1.SaveToFile(fileName)
set FileUP=Nothing

If tmpResult=0 then

img=filename
response.write (" <SCRIPT>parent.document.getElementById("""& s_inputName &""").value+='/n"&img&"';history.back(); </SCRIPT>")

Else

error_msg "Sorry！File"&Chr(96)& "s Type is not correct!/n",""
response.End()
End if

Else
If i_upfile=1 And i_Author=1 then
%>

<table cellpadding=0 cellspacing=0 border="0">
<tr>
<form enctype=multipart/form-data method=post action=up.asp?up_act=up_files>
<td> <input type=file style="FONT-SIZE:9pt;cursor:hand;" name=file1 size="20">
<input style="FONT-SIZE:9pt;cursor:hand;" type="submit" value=" 上 传 " name=Submit>
</form> </td> </tr> </table>
<%
ElseIf i_Author=0 Then

%>
<table cellpadding=0 cellspacing=0 border="0">
<tr> <td style="font-size:12px;height:24px;" valign="middle">请登录后再使用上传功能。 </td> </tr> </table>
<%
else
%>
<table cellpadding=0 cellspacing=0 border="0">
<tr> <td style="font-size:12px;height:24px;" valign="middle">不允许上传文件. </td> </tr> </table>
<%
End if
end if
%>

3、dic.asp
<%
Class DictionaryClass
Dim ArryObj()    '使用该二维数组来做存放数据的字典
Dim MaxIndex      'MaxIndex则是ArryObj开始的最大上标
Dim CurIndex      '字典指针,用来指向ArryObj的指针
Dim C_ErrCode      '错误代码号


Private Sub Class_Initialize
CurIndex=0      '从下标0开始
C_ErrCode=0      '0表示没有任何错误
MaxIndex=100      '默认的大小
Redim ArryObj(1,MaxIndex)  '定义一个二维的数组
End Sub

Private Sub Class_Terminate
Erase ArryObj  '清除数组
End Sub

Public Property Get ErrCode '返回错误代码
ErrCode=C_ErrCode
End Property

Public Property Get Count  '返回数据的总数,只返回CurIndex当前值-1即可.
Count=CurIndex
End Property

Public Property Get Keys  '返回字典数据的全部Keys,返回数组.
Dim KeyCount,ArryKey(),I
KeyCount=CurIndex-1
Redim ArryKey(KeyCount)

For I=0 To KeyCount
    ArryKey(I)=ArryObj(0,I)
    Next

Keys=ArryKey
Erase ArryKey
End Property

Public Property Get Items  '返回字典数据的全部Values,返回数组.
  Dim KeyCount,ArryItem(),I
  KeyCount=CurIndex-1
  Redim ArryItem(KeyCount)

  For I=0 To KeyCount
      If isObject(ArryObj(1,I)) Then
      Set ArryItem(I)=ArryObj(1,I)
  Else
        ArryItem(I)=ArryObj(1,I)
  End If
  Next

  Items=ArryItem
  Erase ArryItem
End Property

Public Property Let Item(sKey,sVal) '取得sKey为Key的字典数据
  If sIsEmpty(sKey) Then
  Exit Property
  End If

  Dim i,iType

  iType=GetType(sKey)
  If iType=1 Then '如果sKey为数值型的则检查范围
  If sKey>CurIndex Or sKey <1 Then
  C_ErrCode=2
Exit Property
End If
  End If

  If iType=0 Then
  For i=0 to CurIndex-1
    If ArryObj(0,i)=sKey Then
    If isObject(sVal) Then
      Set ArryObj(1,i)=sVal
  Else
    ArryObj(1,i)=sVal
  End If
  Exit Property
  End If
  Next
  ElseIf iType=1 Then
      sKey=sKey-1
    If isObject(sVal) Then
      Set ArryObj(1,sKey)=sVal
  Else
    ArryObj(1,sKey)=sVal
  End If
  Exit Property
  End If
  C_ErrCode=2        'ErrCode为2则是替换或个为sKey的字典数据时找不到数据
End Property

Public Property Get Item(sKey)
  If sIsEmpty(sKey) Then
    Item=Null
  Exit Property
End If
 
Dim i,iType
 
iType=GetType(sKey)
If iType=1 Then '如果sKey为数值型的则检查范围
  If sKey>CurIndex Or sKey <1 Then
    Item=Null
  Exit Property
End If
  End If

If iType=0 Then
For i=0 to CurIndex-1
    If ArryObj(0,i)=sKey Then
    If isObject(ArryObj(1,i)) Then
      Set Item=ArryObj(1,i)
  Else
    Item=ArryObj(1,i)
  End If
  Exit Property
  End If
  Next
  ElseIf iType=1 Then
    sKey=sKey-1
    If isObject(ArryObj(1,sKey)) Then
      Set Item=ArryObj(1,sKey)
  Else
    Item=ArryObj(1,sKey)
  End If
  Exit Property
  End If

  Item=Null
End Property

Public Sub Add(sKey,sVal) '添加字典
  'On Error Resume Next
  If Exists(sKey) Or C_ErrCode=9 Then
  C_ErrCode=1          'Key值不唯一(空的Key值也不能添加数字)
  Exit Sub
End If

  If CurIndex>MaxIndex Then
  MaxIndex=MaxIndex+1      '每次增加一个标数,可以按场合需求改为所需量
  Redim Preserve ArryObj(1,MaxIndex)
End If

ArryObj(0,CurIndex)=Cstr(sKey)    'sKey是标识值,将Key以字符串类型保存
if isObject(sVal) Then
  Set ArryObj(1,CurIndex)=sVal    'sVal是数据
Else
  ArryObj(1,CurIndex)=sVal    'sVal是数据
End If

CurIndex=CurIndex+1
End Sub

Public Sub Insert(sKey,nKey,nVal,sMethod)
If Not Exists(sKey) Then
C_ErrCode=4
Exit Sub
End If

If Exists(nKey) Or C_ErrCode=9 Then
C_ErrCode=4          'Key值不唯一(空的Key值也不能添加数字)
Exit Sub
End If

sType=GetType(sKey)        '取得sKey的变量类型

Dim ArryResult(),I,sType,subIndex,sAdd

ReDim ArryResult(1,CurIndex)  '定义一个数组用来做临时存放地

if sIsEmpty(sMethod) Then sMethod="b"  '为空的数据则默认是"b"
sMethod=lcase(cstr(sMethod))
subIndex=CurIndex-1
sAdd=0
If sType=0 Then            '字符串类型比较
If sMethod="1" Or sMethod="b" Or sMethod="back" Then '将数据插入sKey的后面
For I=0 TO subIndex
ArryResult(0,sAdd)=ArryObj(0,I)

If IsObject(ArryObj(1,I)) Then
Set ArryResult(1,sAdd)=ArryObj(1,I)
Else
ArryResult(1,sAdd)=ArryObj(1,I)
End If

If ArryObj(0,I)=sKey Then '插入数据
sAdd=sAdd+1
ArryResult(0,sAdd)=nKey
If IsObject(nVal) Then
Set ArryResult(1,sAdd)=nVal
Else
ArryResult(1,sAdd)=nVal
End If
End If

sAdd=sAdd+1
Next

Else
For I=0 TO subIndex
If ArryObj(0,I)=sKey Then '插入数据
ArryResult(0,sAdd)=nKey
If IsObject(nVal) Then
Set ArryResult(1,sAdd)=nVal
Else
ArryResult(1,sAdd)=nVal
End If
sAdd=sAdd+1
End If
ArryResult(0,sAdd)=ArryObj(0,I)

If IsObject(ArryObj(1,I)) Then
Set ArryResult(1,sAdd)=ArryObj(1,I)
Else
ArryResult(1,sAdd)=ArryObj(1,I)
End If

sAdd=sAdd+1
Next
End If
ElseIf sType=1 Then
sKey=sKey-1            '减1是为了符合日常习惯(从1开始)

If sMethod="1" Or sMethod="b" Or sMethod="back" Then '将数据插入sKey的后面
For I=0 TO sKey        '取sKey前面部分数据
ArryResult(0,I)=ArryObj(0,I)
If IsObject(ArryObj(1,I)) Then
Set ArryResult(1,I)=ArryObj(1,I)
Else
ArryResult(1,I)=ArryObj(1,I)
End If
Next
'插入新的数据
ArryResult(0,sKey+1)=nKey
If IsObject(nVal) Then
Set ArryResult(1,sKey+1)=nVal
Else
ArryResult(1,sKey+1)=nVal
End If
'取sKey后面的数据
For I=sKey+1 TO subIndex
ArryResult(0,I+1)=ArryObj(0,I)
If IsObject(ArryObj(1,I)) Then
Set ArryResult(1,I+1)=ArryObj(1,I)
Else
ArryResult(1,I+1)=ArryObj(1,I)
End If
Next
Else
For I=0 TO sKey-1        '取sKey-1前面部分数据
ArryResult(0,I)=ArryObj(0,I)
If IsObject(ArryObj(1,I)) Then
Set ArryResult(1,I)=ArryObj(1,I)
Else
ArryResult(1,I)=ArryObj(1,I)
End If
Next
'插入新的数据
ArryResult(0,sKey)=nKey
If IsObject(nVal) Then
Set ArryResult(1,sKey)=nVal
Else
ArryResult(1,sKey)=nVal
End If
'取sKey后面的数据
For I=sKey TO subIndex
ArryResult(0,I+1)=ArryObj(0,I)
If IsObject(ArryObj(1,I)) Then
Set ArryResult(1,I+1)=ArryObj(1,I)
Else
ArryResult(1,I+1)=ArryObj(1,I)
End If
Next
End If
Else
C_ErrCode=3
Exit Sub
End If

ReDim ArryObj(1,CurIndex) '重置数据

For I=0 To CurIndex
ArryObj(0,I)=ArryResult(0,I)
If isObject(ArryResult(1,I)) Then
Set ArryObj(1,I)=ArryResult(1,I)
Else
ArryObj(1,I)=ArryResult(1,I)
End If
Next

MaxIndex=CurIndex
Erase ArryResult
CurIndex=CurIndex+1    'Insert后数据指针加一
End Sub

Public Function Exists(sKey)  '判断存不存在某个字典数据
If sIsEmpty(sKey) Then
Exists=False
Exit Function
End If

Dim I,vType
vType=GetType(sKey)

If vType=0 Then
For I=0 To CurIndex-1
If ArryObj(0,I)=sKey Then
Exists=True
Exit Function
End If
Next
ElseIf vType=1 Then
If sKey <=CurIndex And sKey>0 Then
Exists=True
Exit Function
End If
End If

Exists=False
End Function

Public Sub Remove(sKey)        '根据sKey的值Remove一条字典数据
If Not Exists(sKey) Then
C_ErrCode=3
Exit Sub
End If

sType=GetType(sKey)        '取得sKey的变量类型

Dim ArryResult(),I,sType,sAdd

ReDim ArryResult(1,CurIndex-2)  '定义一个数组用来做临时存放地
sAdd=0
If sType=0 Then            '字符串类型比较
For I=0 TO CurIndex-1
If ArryObj(0,I) <>sKey Then
    ArryResult(0,sAdd)=ArryObj(0,I)

If IsObject(ArryObj(1,I)) Then
    Set ArryResult(1,sAdd)=ArryObj(1,I)
Else
    ArryResult(1,sAdd)=ArryObj(1,I)
End If

sAdd=sAdd+1
End If
Next

ElseIf sType=1 Then
sKey=sKey-1            '减1是为了符合日常习惯(从1开始)
For I=0 TO CurIndex-1
If I <>sKey Then
    ArryResult(0,sAdd)=ArryObj(0,I)
If IsObject(ArryObj(1,I)) Then
Set ArryResult(1,sAdd)=ArryObj(1,I)
Else
ArryResult(1,sAdd)=ArryObj(1,I)
  End If

sAdd=sAdd+1
End If
Next
Else
C_ErrCode=3
Exit Sub
End If

MaxIndex=CurIndex-2
ReDim ArryObj(1,MaxIndex) '重置数据

For I=0 To MaxIndex
ArryObj(0,I)=ArryResult(0,I)
If isObject(ArryResult(1,I)) Then
Set ArryObj(1,I)=ArryResult(1,I)
Else
ArryObj(1,I)=ArryResult(1,I)
End If
Next

Erase ArryResult
CurIndex=CurIndex-1    '减一是Remove后数据指针
End Sub

Public Sub RemoveAll '全部清空字典数据,只Redim一下就OK了
Redim ArryObj(MaxIndex)
CurIndex=0
End Sub

Public Sub ClearErr  '重置错误
C_ErrCode=0
End Sub

Private Function sIsEmpty(sVal) '判断sVal是否为空值
If IsEmpty(sVal) Then
C_ErrCode=9          'Key值为空的错误代码
sIsEmpty=True
Exit Function
End If

If IsNull(sVal) Then
C_ErrCode=9          'Key值为空的错误代码
sIsEmpty=True
Exit Function
End If

If Trim(sVal)="" Then
C_ErrCode=9          'Key值为空的错误代码
sIsEmpty=True
Exit Function
End If

sIsEmpty=False
End Function

Private Function GetType(sVal)  '取得变量sVal的变量类型
dim sType
sType=TypeName(sVal)
Select Case sType
Case "String"
GetType=0
Case "Integer","Long","Single","Double"
GetType=1
Case Else
GetType=-1
End Select

End Function

End Class
%>
4、1.asp
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
  <title> new document </title>
  <meta name="generator" content="editplus" />
  <meta name="author" content="" />
  <meta name="keywords" content="" />
  <meta name="description" content="" />
</head>

<body>
  <table>
  <form name="upfile">
  <tr>
  <td> <input type="text" id="filePath" name="filePath" size="40"> </td> <td> <iframe height="30" width="320" frameborder="0" scrolling="no" src="up.asp"> </iframe> </td>
  </tr>
  </form>
  </table>
</body>
</html>

说明:upfile.asp为上传类，up.asp为调用文件，1.asp为演示文件，dic.asp为避免iis服务器dictonary组件不可用时的自写义dictonary组件也可以将其修改为iis的dictonary组件