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

现在流行的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组件