vbs,hta中选择文件夹对话框实现代码
作者 佚名
来源 ASP编程
浏览
发布时间 2013-07-09
复制代码 代码如下: 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> |
凌众科技专业提供服务器租用、服务器托管、企业邮局、虚拟主机等服务,公司网站:http://www.lingzhong.cn 为了给广大客户了解更多的技术信息,本技术文章收集来源于网络,凌众科技尊重文章作者的版权,如果有涉及你的版权有必要删除你的文章,请和我们联系。以上信息与文章正文是不可分割的一部分,如果您要转载本文章,请保留以上信息,谢谢! |
你可能对下面的文章感兴趣
上一篇: VBS 下载方法(CDO.MESSAGE)下一篇: excel2access vbs脚本
关于vbs,hta中选择文件夹对话框实现代码的所有评论