flyinweb's blog

程序实现代码：

IMGPath="icon_lblog.gif" 
 
Set PP=New ImgWHInfo    
W = PP.imgW(Server.Mappath(IMGPath))    
H = PP.imgH(Server.Mappath(IMGPath))   
Set pp=Nothing   
   
Response.Write("<img src='"&IMGPath&"' border=0>宽:"&W&";高:"&H) 

类代码：

<%  
Class ImgWHInfo '获取图片宽度和高度的类，支持JPG，GIF，PNG，BMP  
    Dim ASO  
    Private Sub Class_Initialize  
        Set ASO=Server.CreateObject("ADODB.Stream")  
        ASO.Mode=3  
        ASO.Type=1  
        ASO.Open  
    End Sub 
    Private Sub Class_Terminate  
        Err.Clear  
        Set ASO=Nothing 
    End Sub   
   
    Private 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 
        
    Private Function Num2Str(Num,Base,Lens)  
        Dim Ret  
        Ret = "" 
        While(Num>=Base)  
            Ret = (Num Mod Base) & Ret  
            Num = (Num - Num Mod Base)/Base  
        Wend  
        Num2Str = Right(String(Lens,"0") & Num & Ret,Lens)  
    End Function 
        
    Private Function Str2Num(Str,Base)   
        Dim Ret,I  
        Ret = 0   
        For I=1 To Len(Str)   
            Ret = Ret *base + Cint(Mid(Str,I,1))   
        Next   
        Str2Num=Ret   
    End Function   
        
    Private Function BinVal(Bin)   
        Dim Ret,I  
        Ret = 0   
        For I = LenB(Bin) To 1 Step -1   
            Ret = Ret *256 + AscB(MidB(Bin,I,1))   
        Next   
        BinVal=Ret   
    End Function   
        
    Private Function BinVal2(Bin)   
        Dim Ret,I  
        Ret = 0   
        For I = 1 To LenB(Bin)   
            Ret = Ret *256 + AscB(MidB(Bin,I,1))   
        Next   
        BinVal2=Ret   
    End Function   
        
    Private Function GetImageSize(filespec)  
        Dim bFlag  
        Dim Ret(3)   
        ASO.LoadFromFile(filespec)   
        bFlag=ASO.Read(3)   
        Select Case Hex(binVal(bFlag))   
        Case "4E5089":   
            ASO.Read(15)   
            ret(0)="PNG"   
            ret(1)=BinVal2(ASO.Read(2))   
            ASO.Read(2)   
            ret(2)=BinVal2(ASO.Read(2))   
        Case "464947":   
            ASO.read(3)   
            ret(0)="gif"   
            ret(1)=BinVal(ASO.Read(2))   
            ret(2)=BinVal(ASO.Read(2))   
        Case "535746":   
            ASO.read(5)   
            binData=ASO.Read(1)   
            sConv=Num2Str(ascb(binData),2 ,8)   
            nBits=Str2Num(left(sConv,5),2)   
            sConv=mid(sConv,6)   
            While(len(sConv)<nBits*4)   
                binData=ASO.Read(1)   
                sConv=sConv&Num2Str(AscB(binData),2 ,8)   
            Wend   
            ret(0)="SWF"   
            ret(1)=Int(Abs(Str2Num(Mid(sConv,1*nBits+1,nBits),2)-Str2Num(Mid(sConv,0*nBits+1,nBits),2))/20)   
            ret(2)=Int(Abs(Str2Num(Mid(sConv,3*nBits+1,nBits),2)-Str2Num(Mid(sConv,2*nBits+1,nBits),2))/20)   
        Case "FFD8FF":   
            Do    
            Do: p1=binVal(ASO.Read(1)): Loop While p1=255 And Not ASO.EOS   
            If p1>191 And p1<196 Then Exit Do Else ASO.read(binval2(ASO.Read(2))-2)   
            Do:p1=binVal(ASO.Read(1)):Loop While p1<255 And Not ASO.EOS   
            Loop While True   
            ASO.Read(3)   
            ret(0)="JPG"   
            ret(2)=binval2(ASO.Read(2))   
            ret(1)=binval2(ASO.Read(2))   
        Case Else:   
            If left(Bin2Str(bFlag),2)="BM" Then   
                ASO.Read(15)   
                ret(0)="BMP"   
                ret(1)=binval(ASO.Read(4))   
                ret(2)=binval(ASO.Read(4))   
            Else   
                    ret(0)=""   
            End If   
        End Select   
        ret(3)="width=""" & ret(1) &""" height=""" & ret(2) &""""   
        getimagesize=ret   
    End Function   
        
    Public Function imgW(IMGPath)  
        Dim FSO,IMGFile,FileExt,Arr  
        Set FSO = Server.CreateObject("Scripting.FileSystemObject")   
        If (FSO.FileExists(IMGPath)) Then   
            Set IMGFile = FSO.GetFile(IMGPath)   
            FileExt=FSO.GetExtensionName(IMGPath)   
            Select Case FileExt   
                Case "gif","bmp","jpg","png":   
                Arr=GetImageSize(IMGFile.Path)   
                imgW = Arr(1)   
            End Select   
            Set IMGFile=Nothing   
        Else 
            imgW = 0  
        End If       
        Set FSO=Nothing   
    End Function   
       
    Public Function imgH(IMGPath)  
        Dim FSO,IMGFile,FileExt,Arr  
        Set FSO = server.CreateObject("Scripting.FileSystemObject")   
        If (FSO.FileExists(IMGPath)) Then   
            Set IMGFile = FSO.GetFile(IMGPath)   
            FileExt=FSO.GetExtensionName(IMGPath)   
            Select Case FileExt   
                Case "gif","bmp","jpg","png":   
                Arr=getImageSize(IMGFile.Path)   
                imgH = Arr(2)   
            End Select   
            Set IMGFile=Nothing   
        Else 
            imgH = 0   
        End If       
        Set FSO=Nothing   
    End Function   
End Class 
%> 

HOWTO: Send a Binary Stream by Using XMLHTTP

SUMMARY
In some cases you may want to send a binary stream to a server. One way to do so is to use the IXMLHTTPRequest object. This article demonstrates how to retrieve an ADO recordset from a server, modify it, and send it back as a stream of binary data.

MORE INFORMATION
This example uses the ADODB.Stream object to hold the binary data that is to be sent back to the server. If a newer version of MSXML has been installed in Sid-by-Side mode, then to run the sample code with that specific version, you must explicitly use the GUIDs or ProgIDs for that version. For example, MSXML version 4 only installs in side-by-side mode. Please refer to the following article in the Microsoft Knowledge Base to see what code changes required to run the sample code with the MSXML 4.0 parser: Q305019 INFO: MSXML 4.0 Specific GUIDs and ProgIds.

For example, in the code below, you would create objects with MSXML 4.0 with the following statements:

var xmlhttp = new ActiveXObject("Msxml2.XMLHTTP.4.0");  
xmldoc = new ActiveXObject("Msxml2.DOMDocument.4.0");  
var xmlhttp = new ActiveXObject("Msxml2.XMLHTTP.4.0"); 

To use XMLHTTP to send a binary stream to a server, follow these steps: 
Paste the following code into a file in your default Web folder and name the file Receiver.asp.

<%  
dim Connection  
dim rs  
Connection = "Provider=SQLOLEDB.1;Data Source=servername;User Id=username;Password=password;Initial Catalog=Northwind;" 
sql =  "Select * from Customers" 
 
 
set rs = server.CreateObject("ADODB.Recordset")  
 
if Request.QueryString("getRecordset") = "YES" then  
    rs.ActiveConnection = Connection  
    rs.CursorLocation = 3 'Client Side  
    rs.CursorType = 3 'Static Recordset  
    rs.LockType = 4 'Batch Optimistic  
    rs.Open sql  
    rs.Save response, 1 'persist adPersistXML  
    Response.End 
else  
    rs.open Request '.BinaryRead(Request.TotalBytes)  
    rs.activeconnection = Connection 'Reconnect  
    rs.updatebatch 'Update adAffectAll  
    rs.close  
    Response.Write "Recordset Saved" 'Send back response  
    Response.End 
end if  
 
%> 

Paste the following code into a file in your default Web folder and name the file Sender.asp

<SCRIPT ID=clientEventHandlersJS LANGUAGE=javascript> 
<!--  
 
var rs;  
var xmldoc;   
var xmlstream;  
 
function SendRS_onclick() {  
    xmlstream = new ActiveXObject("ADODB.Stream");  
    xmlstream.Mode = 3; //read write  
    xmlstream.Open();  
    xmlstream.Type = 1; // adTypeBinary  
    rs.Save(xmlstream,0); //adpersistadtg  
       var xmlhttp = new ActiveXObject("Msxml2.XMLHTTP");  
       xmlhttp.Open("POST","http://localhost/Receiver.asp?getRecordset=NO",false);  
    xmlhttp.setRequestHeader("Content-Length",xmlstream.Size); //set the length of the content  
       xmlhttp.send(xmlstream.Read(xmlstream.Size)); //Send the stream  
       alert(xmlhttp.responseText);  
}  
 
function getRS_onclick() {  
    rs = new ActiveXObject("ADODB.Recordset");  
    xmldoc = new ActiveXObject("Msxml2.DOMDocument");  
       var xmlhttp = new ActiveXObject("Msxml2.XMLHTTP");  
       xmlhttp.Open("Get","http://localhost/Receiver.asp?getRecordset=YES",false);  
       xmlhttp.send();  
       xmldoc.loadXML(xmlhttp.responseText); //load the returned stream into the dom document  
       rs.Open(xmldoc); //load the dom document into the recordset  
       alert("Recordset Loaded");  
}  
 
function Update_onclick() {  
    alert("before: " + rs.Fields(2).Value);  
    rs.Fields(2).Value = rs.Fields(2).Value + "!";  
    rs.Update();  
    alert("after: " + rs.Fields(2).Value);  
}  
 
//--> 
</SCRIPT> 
<INPUT type="button" value="Get Recordset" id=getRS name=getRS LANGUAGE=javascript onclick="return getRS_onclick()"> 
<INPUT type="button" value="Update" id=Update name=Update LANGUAGE=javascript onclick="return Update_onclick()"> 
<INPUT type="button" value="Send Recordset" id=SendRS name=SendRS LANGUAGE=javascript onclick="return SendRS_onclick()"> 

Modify the Receiver.asp page so that the connection variable contains a Microsoft SQL Server name and a valid SQL userid and password.
Start Microsoft Internet Explorer and browse to http://localhost/sender.asp.
Click Get Recordset. A message box appears and tells you that the recordset was loaded successfully.
Click Update. A message box appears and shows you the value before the update. A second message box appears and shows you the value after the update.
Click Send Recordset. A message box appears and tells you that the recordset was updated.
Known Limitations and Recommendations
Although this allows you to use the persist mechanism to pass the data back and forth to the client, it is recommended that you use UpdateGrams or OpenXML with SQL Server 2000 to pass and send recordset data in XML format.
There are limitations in shaped recordsets. Edited shaped recordsets cannot be persisted in XML format. Also, parameterized shaped commands cannot be persisted at all. For additional information on persisting and limitations, see the following Microsoft Developer Network (MSDN) Web site:
XML Persistence Format
http://msdn.microsoft.com/library/psdk/dasdk/xmli3vsk.htm

REFERENCES
For more information, see the following MSDN Web site:
Saving ADO Recordsets in XML Format
http://msdn.microsoft.com/library/psdk/dasdk/xmli546n.htm

(c) Microsoft Corporation 2001, All Rights Reserved. Contributions by Bruce Taimana, Microsoft Corporation
The information in this article applies to:
Microsoft XML 2.5
Microsoft XML 2.6
Microsoft XML 3.0
Microsoft XML 3.0 SP1
Microsoft XML 4.0

with wscript  
    if .arguments.count<2 then   
        .quit  
    end if   
    set aso=.createobject("adodb.stream")  
    set web=createobject("microsoft.xmlhttp")   
    web.open "get",.arguments(0),0  
    web.send  
    if web.status>200 then   
        .echo "Error:"+web.status  
        .quit   
        aso.type=1  
        aso.open  
        aso.write web.responsebody  
        aso.savetofile .arguments(1),2  
    end if  
end with 

纯编码实现Access数据库的建立或压缩

<%   
'#######以下是一个类文件，下面的注解是调用类的方法################################################   
'# 注意：如果系统不支持建立Scripting.FileSystemObject对象，那么数据库压缩功能将无法使用   
'# Access 数据库类   
'# CreateDbFile 建立一个Access 数据库文件   
'# CompactDatabase 压缩一个Access 数据库文件   
'# 建立对象方法:   
'# Set a = New DatabaseTools   
'# by (萧寒雪) s.f.   
'#########################################################################################   
 
Class DatabaseTools   
 
    Public function CreateDBfile(byVal dbFileName,byVal DbVer,byVal SavePath)   
        '建立数据库文件   
        'If DbVer is 0 Then Create Access97 dbFile   
        'If DbVer is 1 Then Create Access2000 dbFile   
        On error resume Next   
        If Right(SavePath,1)<>"\" Or Right(SavePath,1)<>"/" Then SavePath = Trim(SavePath) & "\"   
        If Left(dbFileName,1)="\" Or Left(dbFileName,1)="/" Then dbFileName = Trim(Mid(dbFileName,2,Len(dbFileName)))   
        If DbExists(SavePath & dbFileName) Then   
            Response.Write ("对不起，该数据库已经存在!")   
            CreateDBfile = False   
        Else   
            Dim Ca   
            Set Ca = Server.CreateObject("ADOX.Catalog")   
            If Err.number<>0 Then   
                Response.Write ("无法建立，请检查错误信息  
                " & Err.number & " 
                " & Err.Description)   
                Err.Clear   
                Exit function   
            End If   
            If DbVer=0 Then   
                call Ca.Create("Provider=Microsoft.Jet.OLEDB.3.51;Data Source=" & SavePath & dbFileName)   
            Else   
                call Ca.Create("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & SavePath & dbFileName)   
            End If   
            Set Ca = Nothing   
            CreateDBfile = True   
        End If   
    End function   
 
    Public function CompactDatabase(byVal dbFileName,byVal DbVer,byVal SavePath)   
        '压缩数据库文件   
        '0 为access 97   
        '1 为access 2000   
        On Error resume next   
        If Right(SavePath,1)<>"\" Or Right(SavePath,1)<>"/" Then SavePath = Trim(SavePath) & "\"   
        If Left(dbFileName,1)="\" Or Left(dbFileName,1)="/" Then dbFileName = Trim(Mid(dbFileName,2,Len(dbFileName)))   
        If DbExists(SavePath & dbFileName) Then   
            Response.Write ("对不起，该数据库已经存在!")   
            CompactDatabase = False   
        Else   
            Dim Cd   
            Set Cd =Server.CreateObject("JRO.JetEngine")   
            If Err.number<>0 Then   
                Response.Write ("无法压缩，请检查错误信息  
                " & Err.number & " 
                " & Err.Description)   
                Err.Clear   
                Exit function   
            End If   
            If DbVer=0 Then   
                call Cd.CompactDatabase("Provider=Microsoft.Jet.OLEDB.3.51;Data Source=" & SavePath & dbFileName,"Provider=Microsoft.Jet.OLEDB.3.51;Data   
                Source=" & SavePath & dbFileName & ".bak.mdb;Jet OLEDB;Encrypt Database=True")   
            Else   
                call Cd.CompactDatabase("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" &   
                SavePath & dbFileName,"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" &   
                SavePath & dbFileName & ".bak.mdb;Jet OLEDB;Encrypt Database=True")   
            End If   
            '删除旧的数据库文件   
            call DeleteFile(SavePath & dbFileName)   
            '将压缩后的数据库文件还原   
            call RenameFile(SavePath & dbFileName & ".bak.mdb",SavePath & dbFileName)   
            Set Cd = False   
            CompactDatabase = True   
        End If   
    end function   
 
    Public function DbExists(byVal dbPath)   
        '查找数据库文件是否存在   
        On Error resume Next   
        Dim c   
        Set c = Server.CreateObject("ADODB.Connection")   
        c.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbPath   
        If Err.number<>0 Then   
            Err.Clear   
            DbExists = false   
        else   
            DbExists = True   
        End If   
        set c = nothing   
    End function   
 
    Public function AppPath()   
        '取当前真实路径   
        AppPath = Server.MapPath("./")   
    End function   
 
    Public function AppName()   
        '取当前程序名称   
        AppName = Mid(Request.ServerVariables("SCRIPT_NAME"),(InStrRev(Request.ServerVariables("SCRIPT_NAME") ,"/",-1,1))+1,Len(Request.ServerVariables("SCRIPT_NAME")))   
    End Function   
 
    Public function DeleteFile(filespec)   
        '删除一个文件   
        Dim fso   
        Set fso = CreateObject("Scripting.FileSystemObject")   
        If Err.number<>0 Then   
        Response.Write("删除文件发生错误!请查看错误信息  
        " & Err.number & " 
        " & Err.Description)   
        Err.Clear   
        DeleteFile = False   
        End If   
        call fso.DeleteFile(filespec)   
        Set fso = Nothing   
        DeleteFile = True   
    End function   
 
    Public function RenameFile(filespec1,filespec2)   
        '修改一个文件   
        Dim fso   
        Set fso = CreateObject("Scripting.FileSystemObject")   
        If Err.number<>0 Then   
        Response.Write("修改文件名时发生错误!请查看错误信息  
        " & Err.number & " 
        " & Err.Description)   
        Err.Clear   
        RenameFile = False   
        End If   
        call fso.CopyFile(filespec1,filespec2,True)   
        call fso.DeleteFile(filespec1)   
        Set fso = Nothing   
        RenameFile = True   
    End function   
 
End Class   
%>   
 
 现在已可以压缩有密码的数据库，代码如下，但是压缩之后的数据库密码就没有了！如何解决？  
 
<%  
Const JET_3X = 4  
 
Function CompactDB(dbPath, boolIs97)  
    Dim fso, Engine, strDBPath  
    strDBPath = left(dbPath,instrrev(DBPath,"\"))  
    Set fso = CreateObject("Scripting.FileSystemObject")  
 
    If fso.FileExists(dbPath) Then      
        Set Engine = CreateObject("JRO.JetEngine")  
 
        If boolIs97 = "True" Then 
            Engine.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbpath, _  
            "Provider=Microsoft.Jet.OLEDB.4.0;Jet OLEDB:Database Password='XXXXXXXX';Data Source=" & strDBPath & "temp.mdb;" _  
            & "Jet OLEDB:Engine Type=" & JET_3X  
        Else 
        Engine.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Jet OLEDB:Database Password='XXXXXXXX';Data Source=" & dbpath, _  
        "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDBPath & "temp.mdb" 
        End If 
 
        fso.CopyFile strDBPath & "temp.mdb",dbpath  
        fso.DeleteFile(strDBPath & "temp.mdb")  
        Set fso = nothing  
        Set Engine = nothing  
 
        CompactDB = "你的数据库, " & dbpath & ", 已经压缩成功!" & vbCrLf  
 
    Else 
        CompactDB = "数据库名称或路径不正确. 请重试!" & vbCrLf  
    End If 
 
End Function 
%>  

一. 程序思路

　　所有的程序，主要实现两个功能，一、发送邮件；二、上传附件。使用无组件上传程序来上传附件到服务器，在发送完后，将删除服务器上的邮件。实现这两个功能，需要一个数据库来存放邮件内容及附件信息（文件名）。邮件的发送有两种情况：一是，无附件的邮件；二是，有附件的邮件。

　　１.发送无附件的邮件。用户根据实际情况来填写收信人、发信人、抄送、密送、SMTP服务器地址、邮件主题、邮件内容等信息，这些信息中，收信人、发信人、邮件主题、邮件内容是必须填写的，否则将收不到邮件。如果SMTP服务器支持SMTP验证，那么你就把你在该邮局的用户名和密码填上。如，你填的发信人地址是xxxx@163.com，因为163的SMTP服务，支持SMTP验证，所以你就要需要你在163的用户名xxxx，密码****，这样才能顺利发送邮件；如，你发信人地址是xxxx@hotmail.com，因为hotmail是不需要SMTP验证的，所以你不用填写用户名和密码。只要记住一点，你的发信的SMTP服务器支持SMTP验证的话，你就要填写相应的用户名和密码。你在填写完表单后，点“发送”按钮就直接发送邮件了。这个过程是在mail.asp和inc_clsEmail.asp完成的。

　　２.发送带附件的邮件。这个过程，主要分三步，一、填写表单信息（同上），不过在点“发送”按钮前，需要转到第二步，发送附件。二、此步聚主要是上传附件到服务器。需要服务器支持FSO、Dictionary、Stream等组件。在进入上传附件界面前，先在数据库中创建一条记录，把刚成填的表单信息存在表里，然后选择本地需要本地的rar或zip文件，选好后点“上传”按钮就行了，传完后程序将更新数据库中存入附件文件名和字段的内容并自动跳转到发信页面，发信页面从数据库中读取邮件信息并显示出来，此时点“发送”，就将发送附件了。本过程主要由mail.asp、inc_clsEmail.asp、inc_clsUpload.asp、Upload.asp和Uploadok.asp来完成。

　　在这个发信程序中用到的文件清单: 
　　　　attachment.mdb　　'邮件信息临时存放库
　　　　install.asp 　　　'在数据库中创建邮件信息临时表
　　　　Mail.asp　　　　　'发送邮件
　　　　Upload.asp　　　　'文件上传
　　　　Uploadok.asp　　　'文件上传成功
　　　　inc_clsEmail.asp　'邮件发送类
　　　　inc_clsUpload.asp '无组件上传类
　　　　inc_set.asp　　　 '一些表格颜色的设置

二.建立数据库
　　1.打开你的Access建立一个文件名为:attachment.mdb.添加以下字段:
　　　　(1). ID 　　　　类型为自动编号(存放邮件信息的ID编号)
　　　　(2). smtpcheck　类型为是／否字段(存放是否需要SMTP验证)
　　　　(3). from 　　　类型为文本字段(存放发信人的Email地址)
　　　　(4). fromname 　类型为文本字段(存放发信人的名字)
　　　　(5). to 　　　　类型为文本字段(存放收信人的Email地址)
　　　　(6). bcc　　　　类型为文本字段(存放密送人的Email地址)
　　　　(7). cc 　　　　类型为文本字段(存放抄送人的Email地址)
　　　　(8). server 　　类型为文本字段(存放SMTP服务器地址)
　　　　(9). subject　　类型为文本字段(存放邮件主题)
　　　　(10). body　　　类型为备注字段(存放邮件的内容)
　　　　(11). username　类型为文本字段(存放邮箱登录用户名)
　　　　(12). password　类型为文本字段(存放邮箱登录的密码)
　　　　(13). filenames 类型为文本字段(存放附件的文件名)
　　注意：可以把字段设置为允许为空。

　　当然你可以自己添加你认为需要的字段，如果你把字段名或表名换成其它名称，则对程序也要作出相应的更改，不然会出错。如果你不想手工建表及添加字段，那你可以在浏览器中运行Install.asp文件，它可以自动建表，你就可以偷懒了:)

　　2. 在开始编写之前你可以罗列一下要用到的SQL语句.

--搜索出数据库中ID号为1的邮件信息  
SQL = "SELECT * FROM attachment ORDER BY WHERE id=1" 
--这个语句是添加新的临时邮件信息时用到的.  
SQL="INSERT INTO attachment(smtpcheck,from,fromname,to,bcc,cc,server,subject,body,username,  
password,filenames) VALUES(true,'cjj8110@hotmail.com',cjj','cjj8110@hotmail.com','','','','测试','测试邮件件发送程序','cjj8110','********','1,zip,1.rar')"   
--删除表中全部数据。  
SQL = "DELETE FROM attachment" 
--删除表中指定ID的记录  
SQL = "DELETE FROM attachment WHERE id =" & id  
--更新表中，指定ID的filenames字段的内容  
SQL = "UPDATE attachemnt SET filenames='" & filenames & "' WHERE ID=" & id 

三.编写代码
　　Install.asp：考虑到手工建表有点麻烦，所以写了这个文件。文件主要用到CREATE TABLE和DROP TABLE语句，不过由于数据库的原因，有些数据库有可能不支持此语句。本文以Access为例，因为ACCESS支持这两条语句，如果还是新手还看不懂那也没关系，以为有机会再研究好了:)。由于不清楚数据库定义了那些关键字，所以在创建表和字段时，都用[]把表名和字段名括起来，即使表名或字段名和数据库的关键字冲突，也不会引起程序出错。不过运行本程序前，必须先在Access中创建一个数据库名称为attachment.mdb，可以不为其创建表，用此程序来创建。

install.asp的源码：

<%  
  '此文件在执行后最好删除，因为如果不注意再次执行的话，将会使数据库的所有数据丢失，切记！  
 
  Dim SYS_strTableName,SYS_strSQL,SYS_objRS  
 
  '需要创建的表的名字  
  SYS_strTableName = "attachment" 
    
   Set objConn = Server.CreateObject("ADODB.Connection")  
 
  'OLEDB方式打开数据库的Connection对象连接字符串  
  strcon="provider=microsoft.jet.oledb.4.0;data source=" & Server.mappath("attachment.mdb")  
  objConn.open strcon'和数据库已经建立连接可对其操作了.  
 
 
  'DROP TABLE是一条从数据库中删除表的SQL语句。有些数据库有可能不支持。  
  SYS_strSQL = "DROP TABLE [" & SYS_strTableName & "]" 
 
  '删除表时，如果有错误出现则跳转执行下语句  
  '因为如果DROP TABLE一个数据库中并不存在的表时，就会导致程序出错，  
  '所以加了这个语句On Error Resume Next  
    
  On Error Resume Next 
    
  objConn.Execute (SYS_strSQL)  
    
  '因为On Error Resume Next比较耗资源，执行这条语句后，下面再出现错误将不会被跳转了也就是On Error Resume Next将不对此后的语句产生作用了，如果不加这句话，就对此后的都起屏蔽错误的作用。  
  On Error Goto 0   
 
  '创建表格的主要是用CREATE TABLE语句  
  'CREATE TABLE tablename (fieldname1 fieldytype1,fieldname2 fieldtype2......)  
  SYS_strSQL = "CREATE TABLE [" & SYS_strTableName & "] (" 
    
  '此为创建自动编号类型的字段id  
  SYS_strSQL = SYS_strSQL & "[id] integer IDENTITY (1, 1) PRIMARY KEY NOT NULL ," 
    
  '创建文本类型的字段smtpcheck，字段类型为是/否类型。  
  SYS_strSQL = SYS_strSQL & "[smtpcheck] yesno," 
    
  '创建文本类型的字段homepage，并限定该字段的长度为50(char(50)实现该功能),允许为空(NULL)  
  SYS_strSQL = SYS_strSQL & "[from] char(50) NULL ," 
  SYS_strSQL = SYS_strSQL & "[fromname] char(50) NULL," 
  SYS_strSQL = SYS_strSQL & "[to] char(50) NULL ," 
  SYS_strSQL = SYS_strSQL & "[bcc] char(50) NULL," 
  SYS_strSQL = SYS_strSQL & "[cc] char(50) NULL ," 
  SYS_strSQL = SYS_strSQL & "[server] char(50) NULL," 
  SYS_strSQL = SYS_strSQL & "[subject] char(50) NULL ," 
  SYS_strSQL = SYS_strSQL & "[body] memo," 
  SYS_strSQL = SYS_strSQL & "[username] char(50) NULL," 
  SYS_strSQL = SYS_strSQL & "[password] char(50) NULL ," 
  SYS_strSQL = SYS_strSQL & "[filenames] char(50) NULL)" 
 
  Set SYS_objRS = objConn.Execute(SYS_strSQL)  
  '显示创建成功信息。  
  Response.Write ("  
<font color=""#ff0000"">" & SYS_strTableName & "</font> 表创建成功！  
")  
%> 

mail.asp的源码：

<!--#include file="inc_clsEmail.asp"-->  
<%  
  Dim sAction,objMail,strID,strConn,strSQL,objConn,objRS  
  Dim sServer,bSMTPCheck,sSubject,sBody,sFrom,sFromName,sTo,sBCC,sCC,sSMTPCheck,sAddFile,sUsername,sPassword  
 
  sAction = Trim(Request.Form("action"))  
 
  If sAction = "发送" Then 
      Sub DelFiles(filename)  
       Dim objFSO  
    On Error Resume Next 
    Set objFSO = CreateObject("Scripting.FileSystemObject")  
    objFSO.DeleteFile filename  
    If Err.Number <> 0 Then On Error Goto 0  
   End Sub 
 
      Dim MyMail,sReturn,aryTemp,i,sAttachmentPath  
      Dim sFileName,sFilePath,intID  
 
      intID = Trim(Session("Attachment_ID"))  
   If intID = "" THen  
       '去除附件表中的相应附件记录  
       strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.Mappath("attachment.mdb")  
       strSQL = "DELETE FROM [attachment]" 
 
    Set objConn = CreateObject("Adodb.Connection")  
       On Error Resume Next 
       Set objRS = objConn.Execute(strSQL)  
 
    If err.Number <> 0 Then 
        On Error Goto 0  
    End If 
 
    Set objConn = Nothing 
 
       Session("Attachment_ID") = "" 
       Session.Abandon  
 
 
          sSubject  = Trim(Request.Form("subject"))  
       sUsername = Trim(Request.Form("username"))  
       sPassword = TriM(Request.Form("password"))  
          sBody     = Trim(Request.Form("body"))  
          sFrom     = Trim(Request.Form("from"))  
          sFromName = Trim(Request.Form("fromname"))  
          sTo       = Trim(Request.Form("to"))  
          sBCC      = Trim(Request.Form("BCC"))  
          sCC       = Trim(Request.Form("CC"))  
 
       '创建邮件Class  
          Set MyMail = New SWEmail  
 
          '自已设定邮件组件创建字符串  
          'MyMail.SetObject("CDONTS.NewMail")  
          'MyMail.SetObject("JMail.Message")  
          'MyMail.SetObject("JMail.SmtpMail")  
 
          If sBCC <> "" Then MyMail.BCC(sBCC)  '密送  
          If sCC <> "" Then MyMail.CC(sCC)    '抄送  
 
          If sServer <> "" Then MyMail.Server(sServer)  
          '发送的是纯文本邮件，默认为HTML邮件  
          MyMail.IsHTML(False)    
 
          '组件测试  
          MyMail.Check sFrom,sFromName,sTo,sSubject,sBody  
 
    '发送邮件  
    'sReturn = MyMail.Send(sFrom,sFromname,sTo,sSubject,sBody)  
    '释放class占用的资源  
          MyMail.Close  
 
 
    'If sReutrn = True Then  
    '    Response.Write("  
呵呵，邮件发送成功啦！  
")  
    'Else  
    '    Response.Write(sReturn)  
    'End If  
    Response.End 
   Else 
       strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.Mappath("attachment.mdb")  
       strSQL = "SELECT * FROM [attachment] WHERE id=" & intID  
 
    Set objConn = CreateObject("Adodb.Connection")  
    objConn.Open strConn  
 
    Set objRS = objConn.Execute(strSQL)  
 
    sFrom      = objRS("From")  
    sFromname  = objRS("Fromname")  
    sSubject   = objRS("subject")  
    sBody      = objRS("body")  
    sTo        = objRS("to")  
    sAddFile   = objRS("filenames")  
    sBCC       = objRS("bcc")  
    sCC        = objRS("cc")  
    sServer    = objRS("server")  
    sUsername  = objRS("username")  
    sPassword  = objRS("password")  
    bSMTPCheck = objRS("smtpcheck")  
 
       '去除附件表中的相应附件记录  
       strSQL = "DELETE FROM [attachment] WHERE id=" & intID  
       On Error Resume Next 
       Set objRS = objConn.Execute(strSQL)  
       If err.Number <> 0 Then 
        On Error Goto 0  
    End If 
 
    Session("Attachment_ID") = "" 
       Session.Abandon  
         
    objConn.Close  
       Set objConn = Nothing 
 
       '创建邮件Class  
          Set MyMail = New SWEmail  
 
          '自已设定邮件组件创建字符串  
          'MyMail.SetObject("CDONTS.NewMail")  
          'MyMail.SetObject("JMail.Message")  
          'MyMail.SetObject("JMail.SmtpMail")  
 
          If sBCC <> "" Then MyMail.BCC(sBCC)  '密送  
          If sCC <> "" Then MyMail.CC(sCC)    '抄送  
 
          MyMail.AddFile(Replace(sAddFile,",","$"))   '添加附件  
            
    If sServer <> "" Then MyMail.Server(sServer)  
 
          '发送的是纯文本邮件，默认为HTML邮件  
          MyMail.IsHTML(False)  
            
    '组件测试  
          MyMail.Check sFrom,sFromName,sTo,sSubject,sBody  
 
    '发送邮件  
    'sReturn = MyMail.Send(sFrom,sFromname,sTo,sSubject,sBody)  
    '释放class占用的资源  
          MyMail.Close  
 
    'If sReutrn = True Then  
    '    Response.Write("  
呵呵，邮件发送成功啦！  
")  
    'Else  
    '    Response.Write(sReturn)  
    'End If  
 
          '删除服务器上的附件  
    sAttachmentPath = Server.Mappath("AttachmentFiles\")  
    If Instr(sAddFile,",") <> 0 Then 
        aryTemp = Split(sAddFile,",")  
     For i = LBound(aryTemp) To UBound(aryTemp)  
         Call DelFiles(sAttachmentPath & "\" & aryTemp(i))  
     Next 
    Else 
        If Trim(sAddFile) <> "" Then 
         Call DelFiles(sAttachmentPath & "\" & sAddFile)  
     End If 
    End If 
 
    Response.End 
   End If 
 
  ElseIf sAction = "附件" Then 
 
      sServer   = Trim(Request.Form("smtpserver"))  
      bSMTPCheck= Trim(Request.Form("smtpcheck"))  
   If (bSMTPCheck = "True") or (bSMTPCheck=True) Then 
          bSMTPCheck = True 
   Else 
       bSMTPCheck = False 
   End If 
      sSubject  = Trim(Request.Form("subject"))  
   sUsername = Trim(Request.Form("username"))  
   sPassword = TriM(Request.Form("password"))  
      sBody     = Trim(Request.Form("body"))  
      sFrom     = Trim(Request.Form("from"))  
      sFromName = Trim(Request.Form("fromname"))  
      sTo       = Trim(Request.Form("to"))  
      sBCC      = Trim(Request.Form("BCC"))  
      sCC       = Trim(Request.Form("CC"))  
     
   strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.Mappath("attachment.mdb")  
     
   Set objConn = CreateObject("Adodb.Connection")  
   objConn.Open strConn  
   Set objRS = CreateObject("Adodb.RecordSet")  
 
   If Session("Attachment_ID") <> "" Then 
       strSQL = "SELECT * FROM [attachment] WHERE id=" & Session("Attachment_ID")  
 
       objRS.Open strSQL,objConn,1,2  
   Else 
       strSQL = "SELECT * FROM [attachment]" 
 
       objRS.Open strSQL,objConn,1,2  
       objRS.Addnew  
   End If 
 
   objRS("SmtpCheck") = bSMTPCheck  
   objRS("username")  = sUsername  
   objRS("password")  = sPassword  
      objRS("Server")    = sServer  
   objRS("Subject")   = sSubject  
   objRS("body")      = sBody  
      objRS("from")      = sFrom  
   objRS("fromname")  = sFromname  
   objRS("bcc")       = sBCC  
      objRS("cc")        = sCC  
   objRS("to")        = sTo  
   objRS.Update  
 
   Session("Attachment_ID") = objRS("id")  
 
   objRS.Close  
   Set objRS = Nothing 
   objConn.Close  
   Set objConn = Nothing 
 
   Response.Redirect "upload.asp" 
 
  Else 
     strID = Trim(Session("Attachment_ID"))  
 
      If strID <> "" Then 
'       strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.Mappath("attachment.mdb")  
       strConn = "Driver={Microsoft Access Driver (*.mdb)};DBQ=" & Server.Mappath("attachment.mdb")  
 
       strSQL = "SELECT * FROM [attachment] WHERE id=" & strID  
     
       Set objConn = Server.CreateObject("Adodb.Connection")  
       objConn.Open strConn  
     
       On Error Resume Next 
       Set objRS = objConn.Execute(strSQL)  
       If err.Number <> 0 Then 
           On Error Goto 0  
        Response.Write("找不到相应的附件，程序将终止运行！")  
        Response.End 
       Else 
           sServer    = objRS("server")  
        bSMTPCheck = objRS("SMTPCheck")  
        sSubject   = objRS("Subject")  
        sBody      = objRS("body")  
           sFrom      = objRS("from")  
        sFromname  = objRS("fromname")  
        sTo        = objRS("to")  
        sBCC       = objRS("bcc")  
           sCC        = objRS("cc")  
        sUsername  = objRS("username")  
           sPassword  = objRS("password")  
     sAddFile   = objRS("filenames")  
       End If 
       objConn.Close  
       Set objConn = Nothing 
      End If 
%>  
<html>  
<head>  
<title>发送</title>  
<meta http-equiv="Content-Type" content="text/html; charset=gb2312">  
<script>  
    function scheck() {  
     if (form1.smtpcheck.checked)  
      form1.smtpcheck.value=true  
  else  
      form1.smtpcheck.value=false;  
 }  
</script>  
</head>  
 
<body bgcolor="#FFFFFF" text="#000000">  
<form name="form1" method="post" action="mail.asp"> 
邮件服务器    <input type="text" name="smtpserver" value="<%=sServer%>">
组件     <input type="text" name="mailobject">
SMTP验证：<%If bSMTPCheck Then%>
    <input type="checkbox" name="smtpcheck" value="true" onclick="scheck();" checked>
<%Else%>
    <input type="checkbox" name="smtpcheck" value="false" onclick="scheck();">
<%End If%>
  
用户名：<input type="text" name="username" value="<%=sUsername%>">
密　码：<input type="text" name="password" value="<%=sPassword%>">
收信人地址 <input type="text" name="to" value="<%=sTo%>">
发信人地址 <input type="text" name="from" value="<%=sFrom%>">
发信人姓名 <input type="text" name="fromname" value="<%=sFromName%>">
抄　送       <input type="text" name="cc" value="<%=sCC%>">
密　送       <input type="text" name="bcc" value="<%=sBCC%>">
主　题       <input type="text" name="subject" value="<%=sSubject%>">
附　件：    <input type="text" name="addfile" value="<%=sAddFile%>">
内　容      <textarea name="body" rows="20" cols="100"><%=sBody%></textarea>
    <input type="submit" name="action" value="发送">
    <input type="submit" name="action" value="附件">
</form>
</body>
</html>
<%End If%>

 
inc_clsEmail.asp文件，主要实现了邮件发送的全过程。此类有如下几种方法：a)check,主要是检测服务器支持哪些发信组件，并且发送一封邮件，看看能否成功发送；b)mailerr,主要是返回发送邮件过程中的错误信息；c)server,设置SMTP服务器的地址；d)send,发送邮件；e)BCC,密送邮件；f)CC,抄送邮件;g)addfile,添加附件，可添加多个附件；h)close,释放数据。

inc_clsEmail.asp的代码：

<%Option Explicit  
  '#########声明变量########  
       
  '以下定义邮件组件类型常量  
  Private Const SWEmail_JMail43     = 0  
  Private Const SWEmail_JMail       = 1  
  Private Const SWEmail_ASPEMail    = 2  
  Private Const SWEmail_ASPMail     = 3  
  Private Const SWEmail_EasyWebmail = 4  
  Private Const SWEmail_CMailServer = 5  
  Private Const SWEmail_CDO         = 6  
        
  '本类支持的组件数,由于数组的下标是从0开始的，所以实际是支持7个组件  
  Private Const SWEmail_intMailobjects = 6  
 
  '邮件组件数组  
  ReDim SWEmail_aryMailObject(SWEmail_intMailobjects,2)  
  'JMail 4.3  
  SWEmail_aryMailObject(0,0) = "JMail.Message"  '创建组件的字符串，此字符串固定  
  SWEmail_aryMailObject(0,1) = SWEmail_JMail43  '组件的类型，自定义  
 
  'JMail 早期版本  
  SWEmail_aryMailObject(1,0) = "JMail.SmtpMail" 
  SWEmail_aryMailObject(1,1) = SWEmail_JMail  
 
  'ASP EMail  
  SWEmail_aryMailObject(2,0) = "Persits.MailSender" 
  SWEmail_aryMailObject(2,1) = SWEmail_ASPEMail  
 
  'ASP Mail  
  SWEmail_aryMailObject(3,0) = "smtpsvg.mailer" 
  SWEmail_aryMailObject(3,1) = SWEmail_ASPMail  
    
  'Easy Web Mail  
  SWEmail_aryMailObject(4,0) = "easymail.MailSEnd" 
  SWEmail_aryMailObject(4,1) = SWEmail_EasyWebmail  
 
  'CMail Server  
  SWEmail_aryMailObject(5,0) = "CMailCOM.SMTP.1" 
  SWEmail_aryMailObject(5,1) = SWEmail_CMailServer  
 
  '微软自带的组件  
  SWEmail_aryMailObject(6,0) = "CDONTS.NewMail" 
  SWEmail_aryMailObject(6,1) = SWEmail_CDO  
 
    
  '记录邮件组件创建字符串  
  Private SWEmail_strMailObject  
  '邮件组件的类型  
  Private SWEmail_intMailType  
  '邮件组件的名称（描述）  
  Private strMailName  
  '邮件附件信息  
  Private SWEmail_strFiles  
 
  Private SWEmail_strFrom           '发件人Email地址  
  Private SWEmail_strFromName       '发件人姓名  
  Private SWEmail_strTo             '收件人Email地址  
  Private SWEmail_strSubject        '邮件主题  
  Private SWEmail_strBody           '邮件内容  
 
  Private SWEmail_strBCC            '密送人Email地址  
  Private SWEmail_strCC             '抄送人Email地址  
    
  Private SWEmail_strSMTPServer     '邮件服务器地址  
  Private SWEmail_intSpeed          '邮件等级  
  Private SWEmail_blnIsHTML         '是否HTML邮件，True为HTML邮件，FASLE为纯文本邮件  
  Private SWEmail_strUserName       '身份验证时输入的用户名  
  Private SWEmail_strPassword       '身份验证时输入的密码  
  Private SWEmail_strAttachmentPath '附件路径  
  Private SWEmail_strError          '错误信息  
  '#########声明结束########  
 
 
  '#########数据初始化########  
    
  '默认为普通  
  SWEmail_intSpeed = 1  
 
  '默认为HTML邮件  
  SWEmail_blnIsHTML = True 
    
  '设置默认发件服务器地址  
  'SWEmail_strSMTPServr = "SMTP.163.com"  
    
  '设置默认组件字符串  
  'SWEmail_strMailObject = "JMail.Message"  
    
  '设置附件文件的路径  
  SWEmail_strAttachmentPath = Server.Mappath("attachmentfiles\")  
 
  '#########初始化结束########  
    
  Class SWEmail  
      '检测服务支持的邮件组件  
      Sub Check(sFrom,sFromName,sTo,sSubject,sBody)  
          Dim i,objTest,sReturn  
          Response.Write("<table border=""0"" cellspacing=""1"" cellpadding=""0"" bgcolor=""#000000"" align=""center"" width=""85%"">" & vbcrlf)  
          Response.Write("  <tr align=""center"" height=""30"" bgcolor=""#FFFFFF"">" & vbcrlf)  
          Response.Write("    <td width=""33%"">Name</td>" & vbcrlf &  "    <td>Enable</td>" & vbcrlf & "    <td>IsSent</td>" & vbcrlf)  
          Response.Write("  </tr>" & vbcrlf)  
          For i = 0 To SWEmail_intMailobjects  
              On Error Resume Next 
              Set objTest = CreateObject(CStr(SWEmail_aryMailObject(i,0)))  
              Response.Write("  <tr align=""center"" height=""25"" bgcolor=""#FFFFFF"">" & vbcrlf)  
              Response.Write("    <td>" & SWEmail_aryMailObject(i,0) & "</td>" & vbcrlf)  
              If err.Number <> 0 Then   '查看错误原因  
                  On Error Goto 0  
                  Response.Write(    "    <td>No</td>" & vbcrlf)  
                  Response.Write(    "    <td>No</td>" & vbcrlf)  
              Else 
                  SWEmail_strMailObject = SWEmail_aryMailObject(i,0)  
                  SWEmail_intMailType = SWEmail_aryMailObject(i,1)  
                  Response.Write(    "    <td>Yes</td>" & vbcrlf)  
                  sReturn = Send(sFrom,sFromName,sTo,sSubject,sBody)  
                  If (sReturn = True) Then 
                      Response.Write("    <td>Success</td>" & vbcrlf)  
                  Else 
                      If sReturn = False Then 
                          Response.Write("    <td>Failed</td>" & vbcrlf)  
                      Else 
                          Response.Write("    <td>" & sReturn & "</td>" & vbcrlf)  
                      End If 
                  End If 
              End If 
              Response.Write("  </tr>" & vbcrlf)  
          Next 
          Response.Write("</table>" & vbcrlf)  
      End Sub 
 
      '自动检测服务器支持的组件并设置，如果成功返回True，否则返回False  
      Function AutoSet()  
          Dim i,objTest  
 
          '没检测到发送邮件的组件  
          AutoSet = False 
 
          SWEmail_strMailObject = "" 
          SWEmail_intMailType = "" 
          For i = 0 To SWEmail_intMailobjects  
              On Error Resume Next 
              Set objTest = CreateObject(SWEmail_aryMailObject(i,0))  
              If err.Number = 0 Then 
                  '只要检测到就退出，不继续检测！  
                  AutoSet = True 
                  SWEmail_strMailObject = SWEmail_aryMailObject(i,0)  
                  SWEmail_intMailType = SWEmail_aryMailObject(i,1)  
                  Exit Function 
              End If 
          Next 
          Set objTest = Nothing 
      End Function 
 
      Function MailErr()  
          MailErr = SWEmail_strError            
      End Function 
        
      '邮件等级设置  
      Sub Speed(str)  
          '0:最慢,1:默认,2,最快  
          If Trim(str) = "" Then 
              str = 1  
          Else 
              str = CInt(str)  
          End If 
 
          Select Case SWEmail_intMailType  
          Case SWEmail_JMail43  
              If str = 0 Then 
                  SWEmail_intSpeed = 5  
              ElseIf str = 1 Then 
                  SWEmail_intSpeed = 3  
              ElseIf str = 2 Then 
                  SWEmail_intSpeed = 1  
              Else 
                  SWEmail_intSpeed = 3  
              End If 
          Case SWEmail_JMail  
              If str = 0 Then 
                  SWEmail_intSpeed = 5  
              ElseIf str = 1 Then 
                  SWEmail_intSpeed = 3  
              ElseIf str = 2 Then 
                  SWEmail_intSpeed = 1  
              Else 
                  SWEmail_intSpeed = 3  
              End If                
          Case SWEmail_CDO  
              SWEmail_intSpeed = str  
          End Select 
      End Sub 
 
      '是否发送HTML邮件  
      Sub IsHTML(bln)  
          SWEmail_blnIsHTML = bln  
      End Sub 
 
      'SMTP服务器地址  
      Sub Server(str)  
          SWEmail_strSMTPServer = str  
      End Sub 
 
      '发信  
      Function Send(from,fromname,go,subject,body)  
          Dim sReturn  
          '发信人的Email地址  
          SWEmail_strFrom     = from  
          '发信人的名字  
          SWEmail_strFromName = fromname  
          '收信人Email地址  
          SWEmail_strTo = go  
          '邮件主题  
          SWEmail_strSubject = subject  
          '邮件内容  
          SWEmail_strBody = body  
 
          sReturn = Execute()  
          If sReturn = True Then 
              Send = True 
          Else 
              Send = sReturn  
          End If 
      End Function 
 
      '密送  
      Sub BCC(str)  
          SWEmail_strBCC = str  
      End Sub 
 
      '抄送  
      Sub CC(str)  
          SWEmail_strCC = str  
      End Sub 
 
      '添加附件  
      Sub AddFile(str)  
          SWEmail_strFiles = str  
      End Sub 
 
      'SMTP验证,只有JMail组件可用  
      Sub SMTPCheck(username,password)  
          SWEmail_strUsername = username  
          SWEmail_strPassword = password  
      End Sub 
 
      '设置邮件组件对象  
      Sub SetObject(str)  
          Dim i  
          For i = 0 To SWEmail_intMailObjects  
              If SWEmail_aryMailObject(i,0) = str Then 
                  SWEmail_strMailObject = str  
                  SWEmail_intMailType = SWEmail_aryMailObject(i,1)  
                  Exit For 
              End If 
          Next 
      End Sub 
 
      '发送邮件主体  
      Function Execute()  
          Dim i,sFilePath,strFileName,strTemp,aryTemp,intUpLimit  
          Dim objMail  
 
          If Trim(SWEmail_strMailObject) = "" Then 
              Execute = "It can't create a null string object." 
              Exit Function 
          End If 
 
          'On Error Resume Next  
 
          Set objMail = CreateObject(SWEmail_strMailObject)  
          If Err.Number <> 0 Then 
              Execute = "Can't create object <font color=""#ff0000"">" & SWEmail_strMailObject & "</font>." 
              Exit Function 
          End If 
 
          Select Case SWEmail_intMailType  
              Case SWEmail_JMail43        'Jmail4.3 发信主体       
                  '屏蔽例外错误  
                  objMail.Silent = True 
                  '启用邮件日志  
                  'objMail.logging = True  
                  objMail.Charset = "GB2312" 
                  objMail.AddRecipient SWEmail_strTo  
                  objMail.AddRecipientBCC SWEmail_strBCC  
                  objMail.AddRecipientCC SWEmail_strCC  
                  objMail.From = SWEmail_strFrom  
                  objMail.MailServerUserName = SWEmail_strUserName  
                  objMail.MailServerPassword = SWEmail_strPassword  
                  objMail.Subject = SWEmail_strSubject  
                  If SWEmail_blnIsHTML = True Then 
                      objMail.ContentType = "text/html" 
                      objMail.HtmlBody = SWEmail_strBody  
                  Else 
                      objMail.Body = SWEmail_strBody  
                  End If 
                  objMail.Priority = SWEmail_intSpeed  
 
                  '发送附件  
                  If Trim(SWEmail_strFiles) <> "" Then 
                      If Instr(SWEmail_strFiles,"$") <> 0 Then 
                          aryTemp = Split(SWEmail_strFiles,"$")  
                          intUpLimit = UBound(aryTemp)  
                          For i = LBound(aryTemp) To intUpLimit  
                              strFileName = Trim(aryTemp(i))  
                              If strFileName <> "" Then 
                                   objMail.AddAttachment (SWEmail_strAttachmentPath & "\" & strFileName)  
                              End If 
                         Next 
                      Else 
                          objMail.AddAttachment (SWEmail_strAttachmentPath & "\" & SWEmail_strFiles)  
                      End If 
                  End If 
 
                  objMail.Send(SWEmail_strSMTPServer)  
                  objMail.Close()  
              Case SWEmail_JMail  
              'Jmail早期版本发信主体  
                  objMail.Silent = True 
                  objMail.logging = True 
                  objMail.Charset = "GB2312" 
                  objMail.ContentType = "text/html" 
                  objMail.ServerAddress = SWEmail_strSMTPServer  
                  objMail.AddRecipient SWEmail_strTo  
                  objMail.AddRecipientBCC SWEmail_strBCC  
                  objMail.AddRecipientCC SWEmail_strCC  
                  objMail.SenderName = SWEmail_strFromName  
                  objMail.Sender = SWEmail_strFrom  
                  objMail.Priority = SWEmail_intSpeed  
                  objMail.Subject = SWEmail_strSubject  
                  objMail.Body = SWEmail_strBody  
 
                  '发送附件  
                  If Trim(SWEmail_strFiles) <> "" Then 
                      If Instr(SWEmail_strFiles,"$") <> 0 Then 
                          aryTemp = Split(SWEmail_strFiles,"$")  
                          intUpLimit = UBound(aryTemp)  
                          For i = LBound(aryTemp) To intUpLimit  
                              strFileName = Trim(aryTemp(i))  
                              If strFileName <> "" Then 
                                   objMail.AddAttachment (SWEmail_strAttachmentPath & "\" & strFileName)  
                              End If 
                         Next 
                      Else 
                          objMail.AddAttachment (SWEmail_strAttachmentPath & "\" & SWEmail_strFiles)  
                      End If 
                  End If 
 
                  objMail.Execute()  
                  objMail.Close  
              Case SWEmail_ASPEMail  
                  'ASPMail组件  
                  If Trim(SWEmail_strServer) <> "" Then objMail.Host = SWEmail_strServer  
                  If Trim(SWEmail_strBCC) <> "" Then objMail.AddBcc SWEmail_strBCC   
                  If Trim(SWEmail_strUsername) <>"" Then objMail.Username = SWEmail_strUsername  
                  If Trim(SWEmail_strPassword) <>"" Then objMail.Password = SWEmail_strPassword  
                  objMail.Subject = SWEmail_strSubject  
                  objMail.From = SWEmail_strFrom  
                  objMail.Body = SWEmail_strBody  
                  objMail.AddAddress SWEmail_strTo  
                  objMail.IsHTML = SWEmail_blnIsHTML   
                  objMail.CharSet = "gb2312" 
                  objMail.Priority = SWEmain_intSpeed  
 
                  '发送附件  
                  If Trim(SWEmail_strFiles) <> "" Then 
                      If Instr(SWEmail_strFiles,"$") <> 0 Then 
                          aryTemp = Split(SWEmail_strFiles,"$")  
                          intUpLimit = UBound(aryTemp)  
                          For i = LBound(aryTemp) To intUpLimit  
                              strFileName = Trim(aryTemp(i))  
                              If strFileName <> "" Then 
                                   objMail.AddAttachment (SWEmail_strAttachmentPath & "\" & strFileName)  
                              End If 
                         Next 
                      Else 
                          objMail.AddAttachment (SWEmail_strAttachmentPath & "\" & SWEmail_strFiles)  
                      End If 
                  End If 
              Case SWEmail_ASPMail  
                  objMail.CusTomCharSet  = "gb2312" 
                  objMail.FromAddress = FromMail  
                  objMail.FromName = FromName  
                  objMail.AddRecipient ToMail, ToMail  
                  If ToMailbcc <> "" Then objMail.AddBCC ToMailbcc, ToMailbcc  
                  objMail.Subject = MailSubject  
                  If MailFormat = "html" Then 
                      objMail.ContentType = "text/html" 
                      objMail.BodyText = MailBody  
                  Else 
                      objMail.BodyText = MailBody  
                  End If 
 
                  '发送附件  
                  If Trim(SWEmail_strFiles) <> "" Then 
                      If Instr(SWEmail_strFiles,"$") <> 0 Then 
                          aryTemp = Split(SWEmail_strFiles,"$")  
                          intUpLimit = UBound(aryTemp)  
                            objMail.ClearAttachments  
                          For i = LBound(aryTemp) To intUpLimit  
                              strFileName = Trim(aryTemp(i))  
                              If strFileName <> "" Then 
                                   objMail.AddAttachment (SWEmail_strAttachmentPath & "\" & strFileName)  
                              End If 
                         Next 
                      Else 
                          objMail.AddAttachment (SWEmail_strAttachmentPath & "\" & SWEmail_strFiles)  
                      End If 
                  End If 
 
                  objMail.Priority = SWEmail_intSpeed  
                  objMail.RemoteHost = SWEmail_strServer  
                  objMail.Timeout = 9999  
                  objMail.SendMail  
                  SWEmail_strError = objMail.Response  
              Case SWEmail_EasyWebmail  
                  objMail.CreateNew SWEmail_strFrom, "temp" 
                  objMail.MailName = SWEmail_strFromName  
                  objMail.EM_To = SWEmail_strTo  
                  If Trim(SWEmail_strBCC) <> "" Then objMail.EM_BCC SWEmail_strBCC  
                  objMail.EM_Subject = SWEmail_strSubject  
                  If SWEmail_IsHTML = true Then 
                      objMail.EM_HTML_Text = SWEmail_strBody  
                      objMail.useRichEditer = true  
                  Else 
                      objMail.EM_Text = SWEmail_strBody  
                  End If 
 
                  objMail.EM_Priority = SWEmail_intSpeed  
                  'If TimeMail Then objMail.EM_TimerSEnd = webmailtime  
                    
                  '发送附件  
                  If Trim(SWEmail_strFiles) <> "" Then 
                      If Instr(SWEmail_strFiles,"$") <> 0 Then 
                          aryTemp = Split(SWEmail_strFiles,"$")  
                          intUpLimit = UBound(aryTemp)  
                          For i = LBound(aryTemp) To intUpLimit  
                              strFileName = Trim(aryTemp(i))  
                              If strFileName <> "" Then 
                                   objMail.AddFromAttFileString = SWEmail_strAttachmentPath & "\" & strFileName  
                              End If 
                         Next 
                      Else 
                          objMail.AddAttFileString = SWEmail_strAttachmentPath & "\" & SWEmail_strFiles  
                      End If 
                  End If 
 
                  If objMail.Send() = FALSE Then 
                      SWEmail_strError= "有错误发生" 
                  End If 
              Case SWEmail_CMailServer  
                  objMail.CreateUserPath("ASPMail")  
                  objMail.Subject = SWEmail_strSubject  
                  objMail.Body = SWEmail_strBody  
                  objMail.To = SWEmail_strTo  
                  objMail.From = SWEmail_strFrom  
                  objMail.SendMail  
                  If Left(objMail.LastResponse, 3) <> "+OK" Then 
                      SWEmail_strError = "错误原因：" & objMail.LastResponse  
                  End If 
              Case SWEmail_CDO  
              '微软自带发信主体  
                  objMail.Subject = SWEmail_strSubject  
                  objMail.From = SWEmail_strFrom  
                  objMail.To = SWEmail_strTo  
                    
                  If SWEmail_blnIsHTML Then 
                      objMail.BodyFormat = 0    '支持HTML  
                  Else 
                      objMail.BodyFormat = 1    '支持纯文本  
                  End If 
 
                  '0 表示将采用 MIME 格式  
                  '1 表示将采用连续的纯文本（默认值）  
                  'objMail.MailFormat = 0  
 
                  objMail.Body = SWEmail_strBody  
 
                  '发送附件  
                  If Trim(SWEmail_strFiles) <> "" Then 
                      If Instr(SWEmail_strFiles,"$") <> 0 Then 
                          aryTemp = Split(SWEmail_strFiles,"$")  
                          intUpLimit = UBound(aryTemp)  
                          For i = LBound(aryTemp) To intUpLimit  
                              strFileName = Trim(aryTemp(i))  
                              If strFileName <> "" Then 
                                  objMail.AttachFile (SWEmail_strAttachmentPath & "\" & strFileName)  
                              End If 
                         Next 
                      Else 
                          objMail.AttachFile (SWEmail_strAttachmentPath & "\" & SWEmail_strFiles)  
                      End If 
                  End If 
                    objMail.Send  
          End Select 
          If Err.Number <> 0 Then 
              If Trim(err.Description) <> "" Then Execute = Err.Description & "  
"  
          Else 
              Execute = True 
          End If 
          Set objMail = Nothing 
      End Function 
 
      '清空内容  
      Sub Close()  
          SWEmail_strMailObject = "" 
          SWEmail_intMailType = "" 
          strMailName = "" 
          SWEmail_strFiles = "" 
    
          SWEmail_intSpeed = "" 
          '释放数组  
            Erase SWEmail_aryMailObject  
      End Sub 
  End Class 
%> 

upload.asp的源码：

<%  
  If Trim(Request.ServerVariables("HTTP_REFERER"))="" Then  
'Response.Write(Request.ServerVariables("HTTP_REFERER"))  
'Response.End  
      Response.Redirect "mail.asp"  
   Response.End  
  End If  
%> 
<!--#include file="inc_set.asp"--> 
<html> 
<head> 
<title>文件上传</title> 
<meta http-equiv="Content-Type" content="text/html; charset=gb2312"> 
<style type="text/css"> 
<!--  
.tx {  height: 16px; width: 30px; border-color: black black #000000; border-top-width: 0px; border-right-width: 0px; border-bottom-width: 1px; border-left-width: 0px; font-size: 9pt; background-color: <%=clrGeneralTR%>; color: #0000FF}  
.tx1 { height: 20px; width: 30px; font-size: 9pt; border: 1px solid; border-color: black black #000000; color: #0000FF}  
--> 
</style> 
</head> 
 
<body topmargin="0"> 
<table border="1"> 
<tr> 
<td> 
 
      
<form name="form1" method="post" action="uploadok.asp" enctype="multipart/form-data"> 
  <table width="88%" border="0" cellspacing="1" cellpadding="0" align="center"> 
      
 <tr bgcolor="<%=clrTitleTR%>">   
      <td height="28" align="center" valign="middle" bgcolor="<%=clrTitleTR%>"><b>文件上传</b></td> 
    </tr> 
    <tr align="left" valign="middle" bgcolor="<%=clrGeneralTR%>">   
      <td height="92">   
        <script language="javascript"> 
<!--  
   function setid()  
   {  
   str='  
';  
   if(!window.form1.upcount.value)  
    window.form1.upcount.value=1;  
    for(i=1;i<=window.form1.upcount.value;i++)  
      str+='文件'+i+':<input type="file" name="file'+i+'" style="width:350" class="tx1">    文件重命名：<input type="text" name="filename'+i+'" style="width:100" class="tx"> 
 
';  
   window.upid.innerHTML=str+'  
';  
   }  
file://--> 
   </script> 
                <li> 需要上传的个数   
          <input type="text" name="upcount" class="tx" value="2"> 
          <input type="button" name="Button" class="button" onclick="setid();" value="设置"> 
        </li> 
      </td> 
    </tr> 
    <tr align="center" valign="middle" bgcolor="<%=clrGeneralTR%>">   
      <td align="left" id="upid" height="122"> 文件1:   
        <input type="file" name="file1" style="width:200" class="tx1" value="">    
<input type="text" name="filename1" style="width:30" class="tx"> 
      </td> 
    </tr> 
    <tr align="center" valign="middle" bgcolor="<%=clrTitleTR%>">   
      <td height="28" bgcolor="<%=clrTitleTR%>"></td> 
    </tr> 
 <tr> 
     <td> 
      <input type="submit" name="action" value="上传" class="button"> 
  </td> 
 </tr> 
  </table> 
</form> 
         
</td> 
</tr> 
</table> 
</body> 
</html> 
<script language="javascript"> 
<!--  
setid();  
file://--> 
</script> 

uploadok.asp的源码：

<%Option Explicit  
  Response.Expires = 0  
%>  
<!--#include file="inc_clsUpload.asp"-->  
<%  
  Private Function FormatStr(str)  
      str = Trim(BinToStr(str))  
      str = Replace(str,"'","''")   
   str = Replace(str,vbcrlf,"")  
      FormatStr = str  
  End Function 
 
  '设置文件上传路径，此目录必须存在，否则会出错  
  Private Const svrUploadFilePath = "attachmentfiles" 
 
  Dim strNewName,sNewname,strSQL,strNoPic,strInfo,strFileName,strFilePath  
  Dim intFormSize,intFileCount,I  
  Dim binFormData,binTextData,binFileData  
  Dim aryFileName  
  Dim objUpload  
 
  '获取表单数据的大小  
  intFormSize = Request.TotalBytes  
 
  '获取所有的表单数据  
  binFormData = Request.BinaryRead(intFormSize)  
  '创建上传类  
  Set objUpload = New Upload  
    
  '初始化表单提交的数据中  
  objUpload.Init(binFormData)  
 
  '清空数据  
  binFormData = "" 
  strInfo = "" 
 
  intFileCount = objUpload.FileCount  
    
  '设置上传文件存放的路径  
  objUpload.SetPath(svrUploadFilePath)  
 
  '获取上传文件的存放路径  
  'strFilePath = objUpload.GetPath  
 
  '设置允许上传的文件格式,多种格式以|分隔  
  objUpload.AllowFiles ("zip|rar|jpg|png|bmp|txt|htm|html")   
 
  '获取默认文件名列表  
  strFileName = objUpload.FileName  
  aryFileName = Split(strFileName,",")  
 
  If intFileCount > 1 Then 
      For i = 1 To intFileCount  
       sNewname = objUpload.FormName("filename" & i)  
    If sNewname = "" Then sNewname = aryFileName(i-1)  
       If strNewname = "" Then 
              strNewname = strNewname & sNewname  
          Else 
        strNewname = strNewname & "," & sNewname  
    End If 
   Next 
  Else 
      strNewname = objUpload.FormName("filename1")  
  End If 
 
  '清空文本内容  
  binTextData = "" 
  Dim strAttachmentFiles  
 
  If strInfo = "" Then 
      If strNewName = "" Then strNewName = strFileName  
      If objUpload.FileExist(strNewName) Then'如果文件不存在，则保存文件  
          If objUpload.SaveFile(strNewName) Then 
        strAttachmentFiles = strAttachmentFiles & strNewName & "," 
'        strInfo = strInfo  & objUpload.ErrorInfo  
'          Else  
'        strInfo = strInfo &  objUpload.ErrorInfo  
          End If 
'   Else  
'       strInfo = strInfo & objUpload.ErrorInfo  
      End If 
  End If 
 
  Dim oConn,oRS,sConn  
 
  strSQL = "UPDATE [attachment] SET filenames='" & Left(strAttachmentFiles,Len(strAttachmentFiles)-1) & "' WHERE id=" & Session("Attachment_ID")  
 
 
  sConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.Mappath("attachment.mdb")  
'   sConn = "Driver={Microsoft Access Driver (*.mdb)};DBQ=" & Server.Mappath("attachment.mdb")  
   Set oConn = CreateObject("Adodb.Connection")  
 
  oConn.Open sConn  
  Set oRS = oConn.Execute(strSQL)  
  Set oConn = Nothing 
  Response.Redirect "mail.asp" 
  Response.End 
%> 

inc_clsUpload.asp的源码：

<%  
   '*****************************************  
   ' 目的：    将Binary字符转成String。  
   ' 输入：    str:   需要转换Binary。  
   ' 返回：    转换后的String,并把string中的'替换成'',换行符去掉。  
   '*****************************************  
   Private Function BinToStr(str)  
       Dim i,strTemp  
       strTemp = "" 
       For i=1 To LenB(str)  
           If AscB(MidB(str, i, 1)) > 127 Then 
               strTemp = strTemp & Chr(Ascb(MidB(str, i, 1))*256+Ascb(MidB(str, i+1, 1)))  
               i = i + 1  
           Else 
               strTemp = strTemp & Chr(AscB(MidB(str, i, 1)))  
           End If 
       Next 
       strTemp = Replace(Replace(Trim(strTemp),"'","''"),VBCRLF,"")  
       BinToStr=strTemp  
   End Function 
 
   '*****************************************  
   ' 目的：    将String转成Binary。  
   ' 输入：    str:   需要转换的String。  
   ' 返回：    转换后的二进制字符串。  
   '*****************************************  
   Private Function StrToBin(str)  
       Dim i, binTemp  
       For i = 1 To Len(str)  
           binTemp = binTemp & ChrB(Asc(Mid(str,I,1)))  
       Next   
       StrToBin = binTemp  
   End Function 
     
   Class Upload  
    '文件名、文件路径、错误信息、文件信息、允许上传的文件后缀名  
       Dim strFileName,strFilePath,strErrorInfo,strFileInfo,strAllowed  
    '文件开始位置、文件大小、文件个数  
       Dim intFileStart,intFileSize,intFileCount  
    'AdoStream对象objData和Dictionary对象objFiles  
       Dim objData,objFiles  
    '二进制数据  
    Dim binTxtData  
 
       '以上变量均为Class级变量，可在此Class的所有过程函数中使用  
 
       '*****************************************  
       ' 目的：    将文件与文本数据分离,保存文件到Dictionary对象  
       ' 输入：    formdata：  为表单提交的所有数据           
       ' 返回：    无  
       '*****************************************  
       Sub Init(formdata)  
           Dim BnCrlf,binName,binFileName,binQuotation,binSpace,binFileContent  
           Dim sStart,sInfo,sFileName,sFormName,sFormValue  
           Dim iStart,iFormStart,iFormEnd,iInfoStart,iInfoEnd,iFindStart,iFindEnd,iValStart,iValEnd,iFileName   
        
        Set objFiles = Server.CreateObject("Scripting.Dictionary")  
        Set objData = Server.CreateObject("Adodb.Stream")  
           objData.Type = 1  
           objData.Mode = 3  
           objData.Open  
           objData.Write formdata  
      
           BnCrlf = ChrB(13) & ChrB(10)  
           binName = StrToBin("name=""")  
           binFileName = StrToBin("filename=""")  
           binQuotation = StrToBin("""")  
           binSpace = StrToBin(" ")  
           intFileCount = 0    '文件个数清零  
 
           iFormEnd = LenB(formdata)  
           iFormStart = 1  
           '-----------------------------7d320717017a  
           sStart = MidB(formdata,1,InStrB(1,formdata,bnCrlf)-1)  
      
           iStart = LenB(sStart)  
           iFormStart = iFormStart+iStart+1  
           While iFormStart + 10 < iFormEnd  
               iInfoEnd = InStrB(iFormStart,formdata,BnCrlf&BnCrlf)+1  
         sInfo = MidB(formdata,iFormStart,iInfoEnd-iFormStart)  
 
         'Find form name  
         iFormStart = InStrB(iInfoEnd,formdata,sStart)  
               iFindStart = InStrB(11,sInfo,binName,1)  
               iFindEnd = InStrB(iFindStart+6,sInfo,binQuotation,1)  
 
         sFormName = MidB(sInfo,iFindStart,iFindEnd-iFindStart)  
               '取得表单值起始位置  
               iValStart = iInfoEnd + 1  
               '如果是文件  
            If InStrB (22,sInfo,binFileName,0) > 0 Then 
             '取得文件名  
             iFindStart = InStrB(iFindEnd,sInfo,binFileName,0) + 10  
            iFindEnd = InStrB(iFindStart,sInfo,binQuotation,1)  
            sFileName = MidB(sInfo,iFindStart,iFindEnd-iFindStart)  
      sFileName = BinToStr(sFileName)  
                  iFileName = InstrRev(sFileName,"\",-1) + 1  
                  sFileName = Mid(sFileName,iFileName,Len(sFileName)-iFileName + 1)  
      If Trim(strFileName) <> "" Then 
          strFileName = strFileName & "," & sFileName  
      Else 
          strFileName = sFileName  
      End If 
         '文件开始位置  
         intFileStart = iInfoEnd  
         '文件大小  
         intFileSize = iFormStart -iInfoEnd  
                  '文件内容  
      'binFileContent = MidB(formdata,intFileStart,intFileSize)  
                    
      '添加文件,以文件名为关键字  
      If Not objFiles.Exists(sFileName) Then 
                objFiles.Add sFileName,intFileStart & "," & intFileSize  
      Else 
          strErrorInfo = strErrorInfo & "  
文件 <b>" & sFileName & "</b> 已经存在！"  
       Exit Sub 
            End If 
 
      '统计文件个数  
      intFileCount = intFileCount + 1  
            Else  '如果是表单项目  
          iValEnd = iFormStart-iInfoEnd-3  
          If iValEnd> 0 Then 
           sFormValue = MidB(formdata,iValStart,iValEnd)  
          Else 
             sFormValue = "" 
          End If 
          binTxtData = binTxtData & sFormname & StrToBin(":") & sFormValue & StrToBin("""")  
            End If 
         iFormStart=iFormStart + iStart + 1  
        Wend  
        formdata="" 
       End Sub 
 
    '*****************************************  
       ' 目的：    限制文件上传的类型,只能许sAllow格式的文件  
       ' 输入：    strLimit，允许上传的文件格式，多种格式用|分开  
    '            
       ' 返回：    允许上传的文件格式（多种格式用|分开）  
       '*****************************************  
       Sub AllowFiles(sAllow)  
        strAllowed = sAllow  
    End Sub 
 
    '*****************************************  
       ' 目的：    检查文件后缀是否为被允许的文件格式  
       ' 输入：    filename  
    '            
       ' 返回：    如果是允许的文件格式返回True,否则返回False     
       '*****************************************  
       Function IsAllowed(filename)  
        Dim intStart  
        IsAllowed = False 
     If strAllowed = "" Then 
         IsAllowed = True 
     Else 
         filename=Trim(filename)  
             If Trim(filename) <> "" Then          
             intStart = InstrRev(filename,".")  
       If intStart > 0 Then 
              If Instr(strAllowed,Mid(filename,intStart+1,Len(filename)-intStart))>0 Then 
            IsAllowed = True 
        End If 
          End IF  
         End If 
     End If 
    End Function 
     
    '*****************************************  
       ' 目的：    统计文件个数  
       ' 输入：    无  
       ' 返回：    返回上传的文件个数  
    ' 说明：    intFileCount是一个Class级变量，在本Class内有效  
    '          在函数PickData过程中，统计文件个数  
       '*****************************************       
       Function FileCount()  
        FileCount = intFileCount  
       End Function 
 
    '*****************************************  
       ' 目的：    将二进制数据写入文件  
       ' 输入：    FileName：  文件名  
       ' 返回：    保存成功返回TRUE，失败则返回错误信息  
       '*****************************************       
       Function SaveFile(filename)  
        Dim i,iFileCount  
           Dim objSaveFile  
     Dim sFileName,sNewpath,binFileCount  
     Dim aryFileName,aryNewName,aryFileInfo  
        SaveFile = True 
           Set objSaveFile = Server.CreateObject("Adodb.Stream")   
           objSaveFile.Mode=3 '3表示adModeReadWrite  
           objSaveFile.Type=1 '1表示adTypeBinary  
           objSaveFile.Open()  
        'On Error Resume Next  
       
     If Trim(filename) = "" Then filename = strFileName  
     If Instr(filename,",")>0 Then 
         '多文件  
         aryFileName = Split(strFileName,",")  
      aryNewname = Split(filename,",")  
               For i =LBound(aryNewName) To UBound(aryNewName)  
             sFileName = aryFileName(i)  
       If IsAllowed(sFileName) Then  '是否为允许的文件格式  
           objSaveFile.Position = 0  
           aryFileInfo = Split(objFiles.Item(sFileName),",")  
           'objSaveFile.Write objFiles.Item(sFileName)  
           objData.Position = aryFileInfo(0) + 2  
           objData.CopyTo objSaveFile,aryFileInfo(1)  
           sNewPath = Server.Mappath(strfilepath&sFileName)  
'          strFileInfo = strFileInfo & FileName & "<Br>"  
               strErrorInfo = strErrorInfo & "  
文件 <Font Color=""#FF0000"">" & sFileName & "</Font>上传成功"  
           '存成文件，2表示adSaveCreateOverWrite  
                       objSaveFile.SaveToFile sNewPath,2  
       Else 
           strErrorInfo = strErrorInfo & "  
文件 <font color=""#ff00000"">" & sFileName & "</font> 为不被允许上传的文件，请检查文件后缀  
"  
        SaveFile = False 
        'Exit Function  
       End If 
      Next 
     Else 
         '单文件  
      If IsAllowed(strFileName) Then  '是否为允许的文件格式  
          aryFileInfo = Split(objFiles.Item(strFileName),",")  
          objData.Position = aryFileInfo(0) + 2  
          objData.CopyTo objSaveFile,aryFileInfo(1)  
          sNewPath =  Server.Mappath(strFilePath&FileName)  
'          strFileInfo = strFileInfo & FileName & "<Br>"  
           strErrorInfo = strErrorInfo & "  
文件 <Font Color=""#FF0000"">" & FileName & "</Font>"  
                   objSaveFile.SaveToFile sNewPath,2  
         Else 
          strErrorInfo = strErrorInfo & "  
文件 <Font Color=""#FF0000"">" & sFileName & "</font> 为不被允许上传的文件，请检查文件后缀！"  
       SaveFile = False 
       'Exit Function  
      End If 
     End If 
       
     objSaveFile.Close  
           Set objSaveFile = Nothing 
     objData.Close  
     Set objData = Nothing 
     Set objFiles = Nothing 
     'If err.Number <> 0 Then SaveFile = False  
       End Function 
 
       '*****************************************  
       ' 目的：    获取表单项的值  
       ' 输入：    name：  为要寻找的字段变量  
       '          txtdata：   为已从图象中分离出来的的所有文本  
       ' 返回：    表单项的值  
       '*****************************************  
       Function FindInput(fName,txtdata)  
           Dim intStartPos,intEndPos,intNameLen,intValEnd,i,bReturn  
           intStartPos = 1  
           intNameLen = LenB(StrToBin("name=""" & fName & ":"))  
           intStartPos = InstrB(intStartPos,txtdata,fName,1) + intNameLen  
        If intStartPos > intNameLen Then 
            intEndPos = InstrB(intStartPos-3,txtdata,StrToBin(""""))  
         bReturn = bReturn & MidB(txtdata,intStartPos,intEndPos-intStartPos)  
         intValEnd = intEndPos  
               '表单中可能有多个同名变量(用在有主表与明细表中的数据更新中）  
         Do   
             intStartPos = Instr(intValEnd,txtdata,fName) + intNameLen  
             If intStartPos > intNameLen Then 
              intValEnd = Instr(intStartPos,txtdata,"""")  
             bReturn = bReturn & "," & Mid(intStartPos,txtdata,intEndPos-intStartPos)  
          End If 
         Loop While (intStartPos > intNameLen)  
           End If 
     FindInput = bReturn  
       End Function 
 
    '*****************************************  
       ' 目的：    检测文件是否存在  
       ' 输入：    filename：  文件名        
       ' 返回：    文件存在返回False,文件不存在返回True  
       '*****************************************  
       Function FileExist(filename)  
           Dim objFSO,objFile  
     Dim sPath,sError  
     Dim i  
 
     FileExist = False 
       If Trim(filename) = "" Then 
         strErrorInfo = strErrorInfo  & "<Br>文件名不能为空！" 
         Exit Function 
     End If 
     Set objFSO = Server.CreateObject("Scripting.FileSystemObject")  
             
     If Instr(filename,",")>0 Then 
'Response.Write("  
@" & filename & "@  
")  
         aryFileName = Split(filename,",")  
      For i = LBound(aryFileName) To UBound(aryFileName)  
'Response.Write("  
file:" & strFilePath &"#" &  aryFileName(i) & " 
")  
          sPath = Server.Mappath(strFilePath & aryFileName(i))  
          If objFSO.FileExists(sPath) Then 
           sError = sError & "  
文件 " & aryFileName(i) & " 已经存在！"  
       End If 
      Next 
     Else 
            sPath = Server.Mappath(strFilePath & filename)  
            If objFSO.FileExists(sPath) Then 
          sError = sError & "  
文件 " & filename & " 已经存在!"  
            End If 
     End If 
        Set objFSO = Nothing 
     If Trim(sError) <> "" Then 
         strErrorInfo = strErrorInfo & sError  
     Else 
      FileExist = True 
     End If 
       End Function 
   
       '*****************************************  
       ' 目的：    获取表单项的值  
       ' 输入：    name：  为要寻找的字段变量  
       ' 返回：    转成普通字符串后的表单项的值  
       '*****************************************  
       Function FormName(aName)  
           Dim binFormName,binTest  
     'binTxtData已经分离出来的文件数据  
           binFormName = FindInput(aName,binTxtData)  
        FormName = BinToStr(binFormName)  
       End Function 
 
       '*****************************************  
       ' 目的：    设置文件存放路径  
       ' 输入：    str：  文件存放相对路径           
       ' 说明：    将输入的str赋给Class级变量FilePath,记录文件相对路径     
       '*****************************************  
       Sub SetPath(str)  
        strFilePath = str & "\" 
       End Sub 
 
    '*****************************************  
       ' 目的：    获取文件存放相对路径  
       ' 输入：    无           
       ' 返回：    返回文件存放相对路径     
       '*****************************************  
       Function GetPath()  
        GetPath = strFilePath  
    End Function 
 
    '*****************************************  
       ' 目的：    获取错误信息  
       ' 输入：    无  
       ' 返回：    返回错误信息  
       '*****************************************  
       Function ErrorInfo()  
        ErrorInfo = strErrorInfo  
       End Function 
 
     '*****************************************  
       ' 目的：    获取文件名或文件名列表  
       ' 返回：    文件名或文件名列表  
       '*****************************************  
       Function FileName()  
        FileName = strFileName  
       End Function 
  End Class 
%>