复制代码 代码如下:
FSO的强大功能
标题：
行
'**************************
'*****超级大笨狼***********
'**************************
on error resume next
window.resizeTo window.screen.availWidth,window.screen.availHeight
window.moveTo 0,0
Set fso = CreateObject("Scripting.FileSystemObject")
dim thisFileDir'定义本文件绝对路径
dim thisFileName'定义本文件名
dim thisFileFolder'定义本文件夹路径
thisFileDir = replace(window.location.href,"file:///","")
thisFileDir = unescape(replace(thisFileDir,"/","\"))
thisFileName = LastOne(thisFileDir,"\")
thisFileFolder=getFolderDir(thisFileDir)
tree.title = thisFileFolder
dim currentDir'当前路径
dim currentFile'当前文件
dim currentDiv'当前DIV对象
dim currentSpan'当前Span对象
dim delatX
dim dragAble:dragAble = false
currentDir = thisFileFolder
set currentDiv = tree
tree.innerText = getTxtName(thisFileName)
showMe frmTree,frmSeach
showFolder tree
sub showLn
Ln.innerText = cint((window.event.offsetY-2)/15)+1
end sub
sub shortCut
if window.event.keyCode=83 and window.event.ctrlKey then
if currentFile<>"" then saveFile
window.event.cancelBubble = true
window.event.returnValue = false
end if
if window.event.keyCode=66 and window.event.ctrlKey then
browseMe
window.event.cancelBubble = true
window.event.returnValue = false
end if
if window.event.keyCode=78 and window.event.ctrlKey then
createFile
window.event.cancelBubble = true
window.event.returnValue = false
end if
end sub
sub browseMe
dim win
set win=window.open()
win.document.write txt.value
end sub
sub createFile
'点创建按钮，真的创建了．
if vartype(currentSpan)<>0 then currentSpan.style.color = "navy"
if currentDir ="" then
'如果点到了文件
currentDir=getFolderDir(currentFile)
else
'点到了文件夹
dim n
set n=currentDiv.nextSibling
do
if vartype(n) =9 then exit do
if left(n.title,len(currentDir)) <> currentDir then exit do
set currentDiv =n
set n=n.nextSibling
loop
end if
dim re,newFile,s,f
set re = new RegExp
re.Pattern = "[^\d]"
re.Global=true
newFile = currentDir & "新收藏" & re.Replace(mid(cstr(now()),3),"") & ".txt"
currentFile=newFile'新建文件是当前文件
'构造innerHTML
s = "
if currentDiv.className = "file" then
s = s & currentDiv.style.marginLeft & ";' > "
else
s = s & px2Int(currentDiv.style.marginLeft) + 8 & ";' > "
end if
s = s & "
s = s & "
s = s & "
'插入innerHTML
currentDiv.insertAdjacentHTML "AfterEnd",s
articleTitle.value = getTxtName(lastOne(newFile,"\"))
txt.value = ""
currentDir = ""
set currentDiv = currentDiv.nextSibling
set currentSpan = currentDiv.getElementsByTagName("SPAN")(0)
currentSpan.style.color = "red"
'创建文件
set f=fso.CreateTextFile(newFile)
f.close
end sub
function getFolderDir(fullDir)
'输入得到全路径，得到文件夹路径
s=LastOne(fullDir,"\")
getFolderDir = left(fullDir,len(fullDir)-len(s))
end function
sub saveFile
'保存对文件的修改
Dim st
Set st = fso.OpenTextFile(currentFile, 2, True)
st.Write txt.value
st.close
end sub
sub deletFile
'删除文件
dim n
if window.event.keyCode =46 and window.event.srcElement.tagName<>"INPUT" then
if currentFile<>"" then
if currentFile = thisFileDir then
alert "不允许删除本文件！"
exit sub
end if
if fso.FileExists(currentFile) then
fso.deletefile currentFile,true
currentDiv.parentElement.removeChild currentDiv
txt.value = ""
currentFile = ""
articleTitle.value = ""
end if
end if
if currentDir<>"" then
if currentDir = thisFileFolder then
alert "不允许删除根目录！"
exit sub
end if
set n = currentDiv.nextSibling
if window.confirm( currentDir & vbcrlf & "这个文件夹有子文件，你要删除全部子文件吗?") then
do
if vartype(n) =9 then exit do
if px2Int(n.style.marginLeft) <= px2Int(currentDiv.style.marginLeft) then exit do
n.parentElement.removeChild n
set n=currentDiv.nextSibling
loop
if fso.FolderExists(currentDir) then fso.DeleteFolder currentDir
currentDiv.parentElement.removeChild currentDiv
end if
end if
end if
end sub
sub showMe(obj1,obj2)
obj1.style.display=""
obj2.style.display="none"
end sub
sub beginDrag
'开始拖拽
delatX=window.event.clientX - px2Int(hide_control.currentStyle.left)
document.attachEvent "onmousemove",getRef("moveHandler")
dragAble = true
window.event.cancelBubble = true
end sub
sub moveHandler
'移动绑定事件
if not dragAble then exit sub
dim x
x = window.event.clientX - delatX
hide_control.style.left= x & "px"
frmTree.style.width = abs( x - 10) & "px"
frmSeach.style.width = abs( x - 10) & "px"
txtFrm.style.left=( x + 20) & "px"
window.event.cancelBubble=true
end sub
sub upHandler
'放开绑定事件
document.detachEvent "onmousemove",getRef("moveHandler")
dragAble = false
window.event.cancelBubble=true
end sub
function getTxtName(fullName)
'去掉文件名后缀
dim s:s=lastOne(fullName,".")
getTxtName = left(fullName ,len(fullName)-len(s)-1)
end function
sub reName(obj)
'改名
dim Arr,a
Arr=array("/","\",":","*","?",chr(34),"|","<",">")
for each a in Arr
if instr(obj.value,a) >0 then
alert "命名不能含有/\:*?" & chr(34) & "|<>其中的一个"
obj.focus
exit sub
end if
next
dim oldName,newName,oldPath,oldType
oldName = obj.parentElement.title
oldPath = getFolderDir(oldName)
oldType = lastOne(oldName,".")
newName = oldPath & obj.value & "." & oldType
Set f = fso.GetFile(oldName)
f.copy newName
f.delete True
obj.parentElement.title = newName
articleTitle.value = getTxtName(lastOne(newName,"\"))
end sub
Function LastOne(Str,splitStr)
'输入字符和分隔符，得到最后一部分
LastOne = right(Str,len(Str)-InStrRev(Str,splitStr))
End Function
sub selectControl
'控制页面选择的状态
if window.event.srcElement.tagName<>"INPUT" and window.event.srcElement.tagName<>"TEXTAREA" then
document.selection.clear
end if
end sub
function isTXT(fileNameStr)
'判断是否是文本类型的文件
dim s,Arr,a,returnValue
returnValue = false
s=lcase(LastOne(fileNameStr,"."))
Arr=array("txt","htm","html","asp","csv","aspx","xml","js","vbs","ini","bat","css","htc","hta","xsl","xslt","sql")
for each a in Arr
if a=s then
returnValue =true
exit for
end if
next
isTXT = returnValue
end function
sub showFolder(obj)
dim folderspec :folderspec = obj.title
obj.setAttribute "parsed",true
if not fso.FolderExists(folderspec) then
alert folderspec & "该文件夹不存在，也许是被移动了，所以刷新一下本程序"
window.location.reload
exit sub
end if
dim f, f1, sf,sf1,i,s,fName
set f=fso.GetFolder(folderspec)
set sf=f.Subfolders
re = re & f.name & "\"
s=""
for each sf1 in sf
s = s & "
s = s & "
next
For Each f1 in f.Files
if isTXT(f1.name) then
s = s & "
s = s & px2Int(obj.style.marginLeft) + 8 & ";' > "
s = s & "
s = s & "
s = s & fName & "' title='" & fName & "' onchange='vbs:reName me' />"
s = s & "