<!--////////程序说明/////////====
Intro  在某网页上选取部分文字，可以将其内容保存为相应文件。
FileName 网页文字保存工具
Author  2laoshi(youxi01)
Version  Beta1.0
Web  http://www.2laoshi.cn
MadeTime 2009-3-17~
<!--//////////设置hta格式////////////-->
<HTA:APPLICATION 
SCROLL="no" 
MaximizeButton="no"
MinimizeButton="no"
INNERBORDER="no" 
SHOWINTASKBAR="yes" 
SINGLEINSTANCE="yes" 
BORDER="thin"
/>
<style type="text/css">
a:link {color: blue}
a:visited {color: blue}
body  {background: #EEEEEE}
fieldset {border :1px solid #BEBEBE;width:98%;height:80px;padding:1px;}
legend {color:red;font-size:14px;margin-bottom:4px;}
button {
height:23px;
padding:2px 0 2px 0;
margin:0 2px 0 0;
}
.text {
background-color:#EEEEEF;
color:Green;
}
#btContainer {
width:100%;
text-align:center;
padding:5px 0 3px 0;
margin-bottom:8px;
}
.footer {
text-align:center;
margin:4px;
font-size:14px;
}
</style>
<script language="vbscript">
Function CHKclick()
tagID=window.event.srcElement.ID
set TagR=document.getElementbyid("text"&tagID)
if document.getElementbyid(tagID).checked then 
TagR.style.background="white"
TagR.disabled=false
else
TagR.style.background="#EEEEEF"
TagR.disabled=True
end if
End Function
</script>
<title>网页文字保存工具</title>
<fieldset>
<legend>默认设置</legend>
<input type=checkbox ID="1" onclick=CHKclick> 更改默认 路径 <input type=text size=22 title="设置文件默认保存路径,如：F:\" class="text" disabled id="text1">
<p style="margin:8px 0 5px 0;"><input type=checkbox id=2 onclick=CHKclick>更改默认文件名 <input type=text size=22 title="设置文件命名规律，如：SaveText" class="text" disabled id=text2>
</fieldset>
<div id="btcontainer">
<button onclick=UnInstall>卸载本工具</button>
<button onclick=savefile>保存设置</button>
<button onclick=self.close>退出</button>
</div>
<p class="footer"><a href="http://www.2laoshi.cn/post/165.html">详细使用说明</a></p>
<p class="footer">欢迎光临：<a href="http://www.2laoshi.cn" title="教师教育博客站">爱老师网</a></p>
<SCRIPT LANGUAGE = "vbScript"> 
on error resume next
set WSH=CreateObject("Wscript.shell")
set FSO=CreateObject("Scripting.FileSystemObject")
'/*配置文件；
FullName=Replace(window.location.href,"file:///","")
FullName=Replace(FullName,"/","\")
optionFile=fso.getfile(FullName).parentfolder&"SaveText.ini"
if not (fso.fileexists(optionFile)) then 
fso.createtextfile(optionFile)
Set f = fso.OpenTextFile(optionFile, 2, True)
f.Write "FilePath="&chr(34)&chr(34)&vbcrlf
f.Write "FileName="&chr(34)&"SaveText.txt"&chr(34)&vbcrlf
f.Close
end if
'/*读取配置文件内容;
Set f = fso.OpenTextFile(optionFile, 1, True)
do while f.atendofline<>true 
execute f.readline
loop
f.close
FSRegPath="HKCU\Software\Microsoft\Internet Explorer\MenuExt\保存选定文字\"
width=360
height=220
window.resizeTo width,height
ileft=(window.screen.width-width)/2
itop=(window.screen.height-height)/2       
window.moveTo ileft,itop

Sub Install
WSH.regwrite FSRegPath,FullName,"REG_SZ"
WSH.regwrite FSRegPath&"\Contexts","243","REG_DWORD"   
text1.value=FilePath
text2.value=FileName  
End Sub
Sub UnInstall
WSH.RegDelete FSRegPath 
FSO.deletefile(OptionFile)
msgbox "卸载成功!",vbexclamation,"提示"
End Sub
Function AddFolder()
Const WH = 0 
Const OPTIONS = &H10&  
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder (WH,"文章保存路径",OPTIONS,".")
If objFolder is Nothing Then
Exit Function
End If
AddFolder=objFolder.Self.Path
End Function
set oWindow = window.external.menuArguments
if not err.number=424 then
fileValue=oWindow.document.selection.createRange().text
if FilePath="" then FilePath=AddFolder
if FileName="" then FileName="SaveText.txt"

FileName=split(FileName,".")
for i=1 to 100    
    if not fso.FileExists(filepath&"\"&FileName(0)&" "&i&"."&FileName(1)) then
  NewFile=FileName(0)&" "&i&"."&FileName(1)
  exit for
    end if
next
set f=FSO.createtextfile(filepath&NewFile)
f.write fileValue
f.close
alert("文件已经保存为："&filepath&NewFile)
else
Install()
end if
Sub SaveFile
if text1.value="" then
Set f = fso.OpenTextFile(optionFile, 2, True)
f.Write "FilePath="&chr(34)&chr(34)&vbcrlf
f.Write "FileName="&chr(34)&text2.value&chr(34)&vbcrlf
f.Close
alert("保存成功!")
exit sub
end if

if right(text1.value,1)<>"\" then 
FilePath=text1.value&"\"
else
FilePath=text1.value
end if
if not fso.folderexists(FilePath) then
alert("请输入一个存在的合法路径")
else
Set f = fso.OpenTextFile(optionFile, 2, True)
f.Write "FilePath="&chr(34)&FilePath&chr(34)&vbcrlf
f.Write "FileName="&chr(34)&text2.value&chr(34)&vbcrlf
f.Close
alert("保存成功!")
end if
End Sub
Sub Window_onunload
set WSH=nothing
set FSO=nothing
End Sub
</script>
复制代码