在vbs中选择文件夹可以直接调用系统的文件夹对话框

代码如下:

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>