繁體中文当前位置: 首页 > 图文教程 > 脚本技术 > VBScript > vbs,hta中选择文件夹对话框实现代码
- VBScript
- 一个最简单的vbs类实例代码
- 实用vbs提醒小程序
- 使用vbs下载文件的代码加强版
- vbs病毒制作之一复制自身的vbs脚本
- 用vbs实现的exe2swf工具脚本代码
- vbs更改3389远程桌面端口的脚本
- 用vbs实现的强制杀进程的脚本
- 用VBS脚本实现更换Windows Xp序列号的代码
- vbs实现右键菜单中添加CMD HERE
- 用VBS脚本删除指定以外的文件或文件夹
- 用VBS记录客户机操作的代码
- 用vbs删除某些类型文件和磁盘空间报告的脚本
- 两个批量挂马vbs脚本代码
- 关于vbs WebBrowser导航问题
- LCL.VBS 病毒源代码
- 用vbs实现向任何电子邮件发送邮件
- 用VBS检测Guest状态的脚本
- 用vbs实现的输入助手附使用方法
- vbs base64 解密脚本代码
- 用vbs实现修改dns的网关脚本
VBScript 中的 vbs,hta中选择文件夹对话框实现代码
出处:互联网 整理: 软晨网（RuanChen.com） 发布: 2009-09-11 浏览: 127 ::
收藏到网摘: n/a
复制代码 代码如下:
on error resume next
SelectFolder
function SelectFolder()
Const MY_COMPUTER = &H11&
Const WINDOW_HANDLE = 0
Const OPTIONS = 0
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(MY_COMPUTER)
Set objFolderItem = objFolder.Self
strPath = objFolderItem.Path
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(WINDOW_HANDLE, "选择文加夹:", OPTIONS, strPath)
If objFolder Is Nothing Then
msgbox "您没有选择任何有效目录!"
End If
Set objFolderItem = objFolder.Self
objPath = objFolderItem.Path
msgbox "您选择的文件夹是：" & objPath
end function
但是这个代码不能在hta里用，原因是权限不够，不知道其它机子上能不能。
于是写了个用vbs自带函数和fso结合的文件夹选择代码，仅供参考
复制代码 代码如下:
<script language=vbscript>
dim spath
spath="Root"
function SFolder()
on error resume next
Dim fso, drv, f, fc, nf, s, i, p, r, d
i=3
if spath="Root" then
Set fso =CreateObject("Scripting.FileSystemObject")
Set drv =fso.Drives
s="输入序号为进入，序号+#为选中(c为取消)"+chr(13)+chr(10)
s=s+"1.根目录"+chr(13)+chr(10)
s=s+"2.上层"+chr(13)+chr(10)
For Each a In drv
s=s+cstr(i)+"."+ a.Path+chr(13)+chr(10)
i=i+1
Next
GetD s
else
Set fso =CreateObject("Scripting.FileSystemObject")
if right(spath,1)<>"\" then
spath=spath+"\"
end if
Set fc =fso.GetFolder(spath).SubFolders
s="输入序号为进入，序号+#为选中(c为取消)"+chr(13)+chr(10)
s=s+"1.根目录"+chr(13)+chr(10)
s=s+"2.上层"+chr(13)+chr(10)
for each nf in fc
s=s+cstr(i)+"."+nf+chr(13)+chr(10)
i=i+1
next
GetF s
end if
end function
function GetD(s)
on error resume next
p=inputbox(s,"","")
if p="c" then
exit function
end if
r=split(s,chr(13)+chr(10))
if right(p,1)="#" then
if left(p,len(p)-1)=1 then
msgbox "这是根目录，不能选择根目录！"
GetD s
elseif left(p,len(p)-1)=2 then
msgbox "这是根目录，不能选择根目录！"
GetD s
else
d=split(r(left(p,len(p)-1)),".")
msgbox "选择：" & d(1)
Document.forms("ValidForm").FPath.Value=d(1)
spath="Root"
end if
else
if p=1 then
msgbox "已经是根目录！"
GetD s
elseif p=2 then
msgbox "已经是最上层！"
GetD s
else
d=split(r(p),".")
spath=d(1)
'msgbox "进入：" & d(1)
SFolder
end if
end if
end function
function GetF(s)
on error resume next
p=inputbox(s,"","")
if p="c" then
exit function
end if
r=split(s,chr(13)+chr(10))
if right(p,1)="#" then
if left(p,len(p)-1)=1 then
msgbox "这是根目录，不能选择根目录！"
GetD s
elseif left(p,len(p)-1)=2 then
GetTheParent =CreateObject("Scripting.FileSystemObject").GetParentFolderName(spath)
msgbox "选择：" & GetTheParent
Document.forms("ValidForm").FPath.Value=GetTheParent
else
d=split(r(left(p,len(p)-1)),".")
msgbox "选择：" & d(1)
Document.forms("ValidForm").FPath.Value=d(1)
spath="Root"
end if
else
if p=1 then
spath="Root"
SFolder
elseif p=2 then
GetTheParent =CreateObject("Scripting.FileSystemObject").GetParentFolderName(spath)
if GetTheParent="" then
spath="Root"
'msgbox "进入：根目录"
else
spath=GetTheParent
'msgbox "进入：" & GetTheParent
end if
SFolder
else
d=split(r(p),".")
spath=d(1)
'msgbox "进入：" & d(1)
SFolder
end if
end if
end function
</script>
<form id="ValidForm" method="POST" action="--WEBBOT-SELF--">
<p><input type="text" name="FPath" size="50" onclick="PastePath"><input type="button" value="选择文件夹" name="SelFolder" onclick="SFolder"></p>
</form>
评论 (0) All
