在vbs中選擇文件夾可以直接調(diào)用系統(tǒng)的文件夾對話框

代碼如下:

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

但是這個(gè)代碼不能在hta里用，原因是權(quán)限不夠，不知道其它機(jī)子上能不能。

于是寫了個(gè)用vbs自帶函數(shù)和fso結(jié)合的文件夾選擇代碼，僅供參考

代碼如下:

<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="輸入序號為進(jìn)入，序號+#為選中(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="輸入序號為進(jìn)入，序號+#為選中(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 "已經(jīng)是根目錄！"

GetD s

elseif p=2 then

msgbox "已經(jīng)是最上層！"

GetD s

else

d=split(r(p),".")

spath=d(1)

'msgbox "進(jìn)入：" & 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 "進(jìn)入：根目錄"

else

spath=GetTheParent

'msgbox "進(jìn)入：" & GetTheParent

end if

SFolder

else

d=split(r(p),".")

spath=d(1)

'msgbox "進(jìn)入：" & 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>