asp文件操作

<%

sub rd(mName)  '用来删除目录
 set fs=createobject("scripting.filesystemobject")
 if instr(filename,":\")<>0 then
   path=mName
 else
   path=server.MapPath(mName)
 end if
 
  ' Response.Write path&"<br>"
 On Error Resume Next
    fs.deletefolder path,TRUE
    set ts=nothing
end sub


Function TESTFILe(FileName)  '这是一个用于检测一个文件是否存在的函数
  On Error Resume Next
 set fs=createobject("scripting.filesystemobject")
 if instr(filename,":\")<>0 then
   path=filename
 else
   path=server.MapPath(FileName)
 end if
 PA=FS.GETFILE(PATH)
    set fs=nothing
    if er() then
      testfile=False
    else
      testfile=True
    end if
end Function

sub createfold(foname)  '用来建立一个目录
   set fs=createobject("scripting.filesystemobject")
   fs.createfolder(foname)
   set fs=nothing
end sub

function tesfold(foname) '用来检测指定的目录是否存在
   set fs=createobject("scripting.filesystemobject")
   if fs.folderexists(foname) then
      tesfold=True
   else
      tesfold= False
   end if
   set fs=nothing
end function

function replfile(lr,st,en,relr)  '此函数的作用为把LR中以ST开始,EN结束的那一段用RELR来替换
  lr1=ucase(lr)
  str1=ucase(st)
  end1=ucase(en)
  str1a=instr(lr1,str1)-1
  if str1a>0 then
     lr1=right(lr1,len(lr1)-str1a-len(st))
     str1b=instr(lr1,end1)
     if str1b>0 then
        lr1=right(lr1,len(lr1)-str1b+1)

       str1b=len(lr1)
       lr1a=left(lr,str1a)
       lr1b=right(lr,str1b-len(en))

       lr2=lr1a&relr&lr1b
       replfile=lr2
     else
       replfile=lr
     end if
  else
    replfile=lr
  end if
end function


function ReadText(FileName)  '这是一个用于读出文本文件的函数
 set adf=server.CreateObject("Adodb.Stream")
 if instr(filename,":\")<>0 then
   path=filename
 else
  
   path=server.MapPath(FileName)
 end if
 with adf
        'Response.Write path
  .Type=2
  .LineSeparator=13
  .Open
  .LoadFromFile (path)
  .Charset="GB2312"
  .Position=2
  ReadText=.ReadText
  .Cancel()
  .Close()
 end with
 set adF=nothing
end function

function Readfile(FileName)  '这是一个用于读出二进制文件的函数
 set adf=server.CreateObject("Adodb.Stream")
 if instr(filename,":\")<>0 then
   path=filename
 else
   path=server.MapPath(FileName)
 end if
 with adf
  .Type=1
  .Open
  .LoadFromFile (path)
   Readfile=.Read
  .Cancel()
  .Close()
 end with
 set adF=nothing
end function

function exname(FileNamm)  '此函数用于取出一个文件名的扩展名
    filenama=filenamm
    filenama=right(filenama,12)
    str=instr(filenama,".")
    exname=right(filenama,len(filenama)-str)
end function

function MYFILEname(FileName)  '此函数用于取出一个路径中的文件名
  filename=replace(filename,"/","\")
  str=instr(filename,"\")
  do while str<>0
    filename=right(filename,len(filename)-str)
    str=instr(filename,"\")
  loop
  myfilename=filename
end function

function Readtab(TAB,field,id)  '这是一个用于读出指定表中的,指定ID的,指定字段,同时可读取二进制数据
   SQL="SELECT  "&FIELD&"  FROM "&TAB&"  WHERE id="&id
   Set rs=Server.CreateObject("ADODB.RecordSet")
   rs.Open sql,conn,1,1
   readtab=rs(field)
   rs.close
   set rs=nothing
end function


sub SaveText(FileName,Data)  '这是一个用于写文本文件的过程
 set fs=createobject("scripting.filesystemobject")
 if instr(filename,":\")<>0 then
   path=filename
 else
   path=server.MapPath(FileName)
 end if
    set ts=fs.createtextfile(path,true)
    ts.writeline(data)
    ts.close
    set ts=nothing
    set fs=nothing
end sub

sub SaveText1(FileName,Data)  '这是一个用于写文本文件的过程
 if instr(filename,":\")<>0 then
   path=filename
 else
   path=server.MapPath(FileName)
 end if
    set ts=fs.createtextfile(path,true)
    ts.writeline(data)
    ts.close
    set ts=nothing
end sub

sub delfile(FileName)  '这是一个用于删除文件的过程,如未指定文件名,将删除该目录下所有文件
  On Error Resume Next
 set fs=createobject("scripting.filesystemobject")
 if instr(filename,":\")<>0 then
   path=filename
 else
   path=server.MapPath(FileName)
 end if
 if instr(path,".")=0 then
     path=path&"\*.*"
 end if
  ' Response.Write path

    fs.deletefile path,TRUE
    set ts=nothing
end sub

sub ren(FileName1,filename2)  '这是一个用于改文件名的函数
  On Error Resume Next
 set fs=createobject("scripting.filesystemobject")
 if instr(filename1,":\")<>0 then
   path1=filename1
 else
   path1=server.MapPath(FileName1)
 end if

 if instr(filename2,":\")<>0 then
   path1=filename2
 else
   path2=server.MapPath(FileName2)
 end if

    fs.movefile path1,path2
    set ts=nothing
end sub

sub copyfile(FileName1,filename2)  '这是一个用于改文件名的函数
  On Error Resume Next
 set fs=createobject("scripting.filesystemobject")
 if instr(filename1,":\")<>0 then
   path1=filename1
 else
   path1=server.MapPath(FileName1)
 end if

 if instr(filename2,":\")<>0 then
   path1=filename2
 else
   path2=server.MapPath(FileName2)
 end if
    IF right(FILENAME1,1)="/" THEN PATH1=PATH1&"\*.*"
     Response.Write  PATH1
    fs.copyfile path1,path2
    set ts=nothing
end sub


SUB SAVEFILE(FILENAME,DATA)  '用于写入二进制的内容
  SET ADF=SERVER.CREATEOBJECT("ADODB.STREAM")
 if instr(filename,":\")<>0 then
   path=filename
 else
   path=server.MapPath(FileName)
 end if

  WITH ADF
  .Type=1
  .Open
  .Write Data
  .SaveToFile path,2
  .Cancel()
  .Close()
  END WITH
  SET ADF=NOTHING
END sub

sub dir(path)  '用于读出指定目录下的文件名，并将它们存入一个SESSION("DIR")对象中,最多350个文件,SESSIno是一个数组,第一个元素是文件路径和文件名,第二个是文件名
   set fso=createobject("scripting.filesystemobject")
 if instr(path,":\")<>0 then
   path=path
 else
   path=server.MapPath(path)
 end if

   set myfolder=fso.getfolder(path)
   dim di(350,2) 
   i=0
   for each x in myfolder.files
      
       di(i,1)=x
       di(i,2)=fso.getfilename(x)
       i=i+1
   next
   session("dir")=di
end sub

function DIRNAME(PATH) '读出路径下的文件名,并存在一个数组中第一个元素是路径加文件名,第二个是文件名
   set fso=createobject("scripting.filesystemobject")
 if instr(path,":\")<>0 then
   path=path
 else
   path=server.MapPath(path)
 end if
   set myfolder=fso.getfolder(path)
   dim di(3500,2) 
   i=0
   for each x in myfolder.files
       di(i,1)=x
       di(i,2)=fso.getfilename(x)
       i=i+1
   next
   DIRNAME=DI
END function

Function Er()  '错误处理
        If Err.Number = 0 Then
        Er = False
        Else
        Err.Clear
        Er = True
        End If
 End Function


SUB REPLACEFILE(FILENAME,LR1,LR2)
  FILELR=READTEXT(FILENAME)
  FILELR=ReplaceTest(filelr,LR1,LR2)
  CALL SAVETEXT(FILENAME,FILELR)
END SUB

sub no(filename,lr)
    filr=readtext(filename)
    filr=lr&"<br>"&chr(13)&chr(10)&filr
    call savetext(filename,filr)
end sub

Function ASCII2Unicode(str)
 dim strLen,res,I
 strLen=LenB(str)
 I=1
 While I < strLen+1
  If I<>strLen And AscB(MidB(str,I,1))>127 Then
   res=res&Chr(AscB(MidB(str,I,1))*256+AscB(MidB(str,I+1,1)))
   I=I+1
  Else
   res=res&ChrW(AscB(MidB(str,I,1)))
  End If
  I=I+1
 Wend
 ASCII2Unicode=res
End Function

function s2f(filename,data,file_size)   '把从表单中读出的二进制存为文件
 formdata=data
 bncrlf=chrB(13) & chrB(10)
   divider=leftB(formdata,clng(instrb(formdata,bncrlf))-1)
   datastart=instrb(formdata,bncrlf & bncrlf)+4
  dataend=instrb(datastart+1,formdata,divider)-datastart
  filesize=lenb(formdata)
   if filesize>file_size then
  
      s2f="0" '文件大小超越上限     
     
   else

       ty=chrb(ascb("T"))&chrb(ascb("y"))&chrb(ascb("p"))&chrb(ascb("e"))&chrb(ascb(":"))
      name=chrb(ascb("e"))&chrb(ascb("n"))&chrb(ascb("a"))&chrb(ascb("m"))&chrb(ascb("e"))&chrb(ascb("="))&chrb(ascb(chr(34)))
      star2=instrb(formdata,ty)+6
      mydata2=midb(formdata,star2,datastart-4-star2)
      star3=instrb(formdata,name)+7
      star4=instrb(formdata,chrb(ascb("C"))&chrb(ascb("o"))&chrb(ascb("n"))&chrb(ascb("t"))&chrb(ascb("e"))&chrb(ascb("n"))&chrb(ascb("t"))&chrb(ascb("-"))&chrb(ascb("T"))&chrb(ascb("y"))&chrb(ascb("p"))&chrb(ascb("e")))
      mydata4=midb(formdata,star3,star4-star3-3)

      for i=1 to lenb(mydata2)
         mydata3=mydata3&chr(ascb(midb(mydata2,i,1)))
      next

      do while instrb(mydata4,chrb(ascb("\")))<>0
        stara=instrb(mydata4,chrb(ascb("\")))+1
        mydata4=midb(mydata4,stara,200)
      loop
      mydata4=ascii2unicode(mydata4)
      EXNA=EXNAME(MYDATA4)
      mydata5_1=ucase(MYDATA4)
      if SESSION("USERNAME")="" OR  SESSION("USERDSF")="" OR instr(MYDATA5_1,".ASP")<>0 OR  instr(MYDATA5_1,".HTR")<>0 OR  instr(MYDATA5_1,".ASA")<>0 OR  instr(MYDATA5_1,".CGI")<>0 OR  instr(MYDATA5_1,".PHP")<>0 OR    instr(MYDATA5_1,".DLL")<>0 OR   instr(MYDATA5_1,".ASPX")<>0 OR  instr(MYDATA5_1,".CER")<>0 OR  instr(MYDATA5_1,".SHTM")<>0 OR  instr(MYDATA5_1,".CDX")<>0 OR  instr(MYDATA5_1,".STM")<>0 OR  instr(MYDATA5_1,".PLX")<>0 OR  instr(MYDATA5_1,".PL")<>0  THEN
        EXNA="HTML"
      END IF

       set ads=server.CreateObject("Adodb.Stream")
       ads.Type=1
       ads.mode=3
       ads.Open
       set data=server.CreateObject("Adodb.Stream")
       data.Type=1
       data.mode=3
       data.Open
       data.write formdata
       data.position=datastart-1
       data.copyto ads,dataend-2
       with ads
         .SaveToFile server.MapPath(filename&"."&exna),2
         .Cancel()
         .Close()
       end with
       data.cancel()
       data.close()
       set ads=nothing
       set data=nothing
       S2F=filesize&","&MYDATA4&","&EXNA&","&FILENAME&"."&EXNA '文件大小,文件原名,文件扩展名, 目标文件名
end if

end function


function  testEMAIL()
     On Error Resume Next
     Set mail = Server.CreateObject("CDONTS.NewMail")
     set mail=nothing

     if er() then
       testEMAIL=False
     else
       testEMAIL=True
     end if
end function

function  testjmail()
     On Error Resume Next
     Set JMail = Server.CreateObject("JMail.SMTPMail")
     set jmail=nothing

     if er() then
       testJMAIL=False
     else
       testJMAIL=True
     end if
end function


function outJmail(text,bodylr,tomail,frommail)  '发送邮件,参数分别为:主题,内容,接收者,发送者 能发为真，没有能发为假。
  ' On Error Resume Next
   
  
   Dim JMail
 Set JMail = Server.CreateObject("JMail.Message")
 JMail.silent=true
 JMail.Logging = True
 JMail.Charset = "gb2312"
 If Not(MAILUSER= "" Or MAILPAS = "") Then
  JMail.MailServerUserName = MAILUSER '您的邮件服务器登录名
  JMail.MailServerPassword = MAILPAS '登录密码
 End If
 JMail.ContentType = "text/html"
 JMail.Priority = 1
 JMail.From = frommail
 if session("username")<>"" then
       jMail.FromName = session("username")
 else
     jMail.FromName = "网站信息"
 
 end if
 JMail.AddRecipient lcase(tomail)
 JMail.Subject = TEXT
 JMail.Body = BODYLR
' if mailuser<>"" or mailpas<>"" then
'     JMail.Send (mailuser&":"&mailpas&"@"&MAILSER)
'   else
     JMail.Send (MAILSER)
'   end if
 jmail.close
   if er()  then
      outJmail=False
   else
     outJmail=True
   end if
   set jmail=nothing
  
  
END FUNCTION

function outemail(text,bodylr,tomail,frommail)  '发送邮件,参数分别为:主题,内容,接收者,发送者 能发为真，没有能发为假。
  select case mo
    case ""
      MYMAIL=False
    case "CDONTS"
     mymail=outmail(text,bodylr,tomail,frommail)
    case "JMAIL"
     mymail=outJmail(text,bodylr,tomail,frommail)
   END SELECT
   if NOT MYMAIL then
      outEmail=False
   else
     outEmail=True
   end if
end function

function outmail(text,bodylr,tomail,frommail)  '发送邮件,参数分别为:主题,内容,接收者,发送者 能发为真，没有能发为假。
   On Error Resume Next
'   response.write  "主题:"&text&" 发信人: "&frommail&" 收信人:"&tomail&" 内容:"&bodylr&"<br>"
   Set mail = Server.CreateObject("CDONTS.NewMail")
   mail.TO = TOMAIL
   mail.From = frommail
   'Mail.AttachFile="c:\a.txt"
   mail.Subject = text
   mail.Body =bodylr
   MAIL.lngAType=1
   Mail.MailFormat= 0  '为1是纯文本
   Mail.BodyFormat =0
   mail.Send
   set mail=nothing
   if er() then
     outmail=False
   else
     outmail=True
   end if
end function


FUNCTION TESEMAIL(MAIL) '邮件地址验证,正确为真，否则为假
if len(MAIL)>70 or len(mail)<=4 then
   tesEMAIL=False
ELSE
    MAIL=replace(MAIL," ","")
    MAIL=UCASE(MAIL)
    IF left(MAIL,1)="@" OR RIGHT(MAIL,1)="@" then
          tesEMAIL=False
    ELSE
      IF INSTR(MAIL,"@")=0 THEN
          tesEMAIL=False
      ELSE
        IF   INSTR(MAIL,".COM")+INSTR(MAIL,".NET")+INSTR(MAIL,".INFO")+INSTR(MAIL,".BIZ")+INSTR(MAIL,".TV")+INSTR(MAIL,".CC")+INSTR(MAIL,".CN")+INSTR(MAIL,".ORG")+INSTR(MAIL,".GOV")=0  THEN
          tesEMAIL=False
        ELSE
          if instr(instr(mail,"@")+1,mail,"@")<>0 then
             tesEMAIL=False
          else
             mail1=replace(mail,"@","")
             mail1=replace(mail1,".","")
             mail1=replace(mail1,"-","")
             mail1=replace(mail1,"_","")
             IF SERVER.URLENCODE(MAIL1)<>MAIL1 THEN
                tesEMAIL=False
             ELSE
                tesEMAIL=True
             END IF
          end if
        END IF
      END IF   
    END IF
END IF
END FUNCTION  

%>