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

146 阅读 0 评论 97 点赞

我是靠谱客的博主生动春天，最近开发中收集的这篇文章主要介绍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>