vbs,hta中选择文件夹对话框实现代码

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>