[问题求助] 【已解决】VBS如何以管理员权限运行/执行当前目录下子目录内的指定程序？

doswork

以下代码xp下执行正常，但win10下无法执行，因为涉及了注册表操作（这个必须是管理员权限才行），网上找到了一段儿“以管理员权限运行”的代码，但是运行之后将“vbs的当前路径”给固定到“c:\windows\system32”这个位置了，造成VBS执行时“找不到指定的文件”，请教这个问题怎么解决？  多谢！

set qq = CreateObject("Wscript.Shell")
ww = qq.CurrentDirectory
wscript.echo ww                  ' 假如当前路径是  “ 桌面\123\ ”，在执行“以管理员权限运行”那段儿代码之后就自动变成“c:\windows\system32”了……

                qq.RegWrite "HKCR\.7z\",  "7zip", "REG_SZ"
                qq.Run ww + "\x64\7zFM.exe",1,true   

'问题：如果不用“以管理员权限运行”这段儿代码，其它run命令可以正常执行（ww是正确的桌面路径），但注册表操作一直提示“……根路径无效……”（因为没有用管理员权限运行）
        ' 用了“以管理员权限运行”这段儿代码之后，上面的注册表也好，这里的执行程序也好，ww的值都是“c:\windows\system32”，造成注册表、执行程序都不正确！

'====== 上面是要用到的代码；下面是“以管理员权限运行”的代码，运行之后“当前路径”取得的值就只能是c:\windows\system32”了……
http://www.bathome.net/redirect. ... 1903&ptid=34121

yu2n

Option Explicit

RunAsAdmin

Msgbox CreateObject("WScript.Shell").CurrentDirectory

' 以管理员身份运行 By Yu2n
Sub RunAsAdmin()
	Dim oItems, vItem, sVer, nVer, vArg, sArgs, sCurDir
	Set oItems = GetObject("winmgmts:").InstancesOf("Win32_OperatingSystem")
	For Each vItem In oItems
		sVer = vItem.Version
	Next
	Set oItems = Nothing
	nVer = Clng(Split(sVer, ".")(0) & Split(sVer, ".")(1))
	If nVer >= 60 Then
		If Not WScript.Arguments.Named.Exists("RunAsAdmin") Then
			For Each vArg In WScript.Arguments
				sArgs = sArgs & " """ & vArg & """"
			Next
			sArgs = sArgs & " /RunAsAdmin:True"
			CreateObject("Shell.Application").ShellExecute "WScript.exe", _
				"""" & WScript.ScriptFullName & """" & sArgs, "", "runas", 1
			WScript.Quit(0)
		Else
			sCurDir = Left(WScript.ScriptFullName, InStrRev(WScript.ScriptFullName, "\") -1)
			CreateObject("WScript.Shell").CurrentDirectory = sCurDir
		End If
	End If
End Sub
复制代码

doswork

回复 2# yu2n


       非常感谢！  您的代码是正确的，好用！
    我网上找的和您的很相似，第一次搜索到您的帖子看“一样”就没仔细看……

测试完回复到您另一个回复上了（窗口没关……），这里再此感谢！

doswork

回复 1# doswork


        版主的扣分接受，但应该不是重复贴码，因为我贴的代码和站内代码是不一样的（很像，但只有站内“yu2n”老师的代码解决了问题）……
        个人对代码并不懂，为了解决一些问题而“啃”代码，开始搜索带站内关于解决注册表的那个帖子了，因为看着和我网上找的“一样”，就没仔细看，直接关闭了，而我找的那个是不能解决问题的，直到刚仔细看并测试才发现“yu2n”老师的代码更严谨、更好，解决了问题。


另把一个新入站的感受给版主说下，并不是抵触版主和论坛，而是把个人一些想法说出来，版主就当做个参考。
该惩罚扣分的还是要扣分，但有时候可能多些灵活性会更好些；现在是感觉“无忧论坛”有些太宽松了，贵论坛又有些太严了。

比如本帖的“代码重复”也要扣分，一方面我并不知道怎么来快速判断代码是不是完全一样，另一方面由于两个确实很像，也就没仔细看，造成“重复代码”的问题。

也可能和论坛以问题和解释要有“唯一性”为标准，所以多余的任何都会被扣分、删除，但从另一个角度来说的话，这样会限制一部分会员的积极性和活跃度。

doswork

yu2n 发表于 2016-7-2 01:46

    您好“yu2n”老师，有个问题还得请教您：

        我想实现的功能：通过运行“c:\test\del.vbs” 彻底删除“c:\test”目录及子目录所有文件，无论是否有“只读/隐藏”属性的文件/文件夹

找到一个代码，可以实现上面的功能，但是只能在XP系统下使用有效，结合您给的“以管理员权限运行”代码，组合之后在win7以上系统运行无效，帮忙看下是哪里的问题，多谢！

组合之后的代码如下：

Option Explicit

RunAsAdmin

'Msgbox CreateObject("WScript.Shell").CurrentDirectory


' 以管理员身份运行 By Yu2n
Sub RunAsAdmin()
 Dim oItems, vItem, sVer, nVer, vArg, sArgs, sCurDir
 Set oItems = GetObject("winmgmts:").InstancesOf("Win32_OperatingSystem")
 For Each vItem In oItems
  sVer = vItem.Version
 Next
 Set oItems = Nothing
 nVer = Clng(Split(sVer, ".")(0) & Split(sVer, ".")(1))
 If nVer >= 60 Then
  If Not WScript.Arguments.Named.Exists("RunAsAdmin") Then
   For Each vArg In WScript.Arguments
    sArgs = sArgs & " """ & vArg & """"
   Next
   sArgs = sArgs & " /RunAsAdmin:True"
   CreateObject("Shell.Application").ShellExecute "WScript.exe", _
    """" & WScript.ScriptFullName & """" & sArgs, "", "runas", 1
   WScript.Quit(0)
  Else
   sCurDir = Left(WScript.ScriptFullName, InStrRev(WScript.ScriptFullName, "\") -1)
   CreateObject("WScript.Shell").CurrentDirectory = sCurDir
  End If
 End If
End Sub




dim fso,VBSFolder,tempbat,cbat,obat

Set fso = CreateObject("Scripting.FileSystemObject")
VBSFolder = fso.GetFile(Wscript.ScriptFullName).ParentFolder.Path
tempbat = fso.GetSpecialFolder(2)+"\tem.bat"
set Cbat=fso.createtextfile(tempbat,true)
Cbat.writeline "pushd "+chr(34)+fso.GetSpecialFolder(2)+chr(34)
Cbat.close
set Obat = fso.opentextfile(tempbat,8)
Obat.writeline "timeout /T 1 /NOBREAK"
Obat.writeline "rd /s /q "+chr(34)+VBSFolder+chr(34)
Obat.writeline "del /F /Q %0"
Obat.close
createobject("wscript.shell").run chr(34)+tempbat+chr(34),0,false
WScript.Quit
复制代码

yu2n

回复 5# doswork

Option Explicit

'以管理员身份运行
RunAsAdmin

'待删除文件夹
Const DEL_DIR = "C:\TEST"

Dim wso, cmdLine
Set wso = CreateObject("WScript.Shell")

'命令：移除属性，删除文件夹/子文件/子文件夹
cmdLine = "cmd /c " & _
	"attrib -R -A -S -H /S /D """ & DEL_DIR & """ & " & _
	"if exist """ & DEL_DIR & """ rd /s /q """ & DEL_DIR & """"

'	等于执行CMD命令：
'	attrib -R -A -S -H /S /D "C:\test"
'	if exist "C:\test" rd /s /q "C:\test"

'执行命令，回报结果
If wso.Run(cmdLine, 0, True) = 0 Then
	Msgbox DEL_DIR & " 删除成功!", vbInformation, WScript.ScriptFullName
Else
	Msgbox DEL_DIR & " 删除失败!", vbCritical, WScript.ScriptFullName
End If



' 以管理员身份运行 By Yu2n
Sub RunAsAdmin()
	Dim oItems, vItem, sVer, nVer, vArg, sArgs, sCurDir
	Set oItems = GetObject("winmgmts:").InstancesOf("Win32_OperatingSystem")
	For Each vItem In oItems
		sVer = vItem.Version
	Next
	Set oItems = Nothing
	nVer = Clng(Split(sVer, ".")(0) & Split(sVer, ".")(1))
	If nVer >= 60 Then
		If Not WScript.Arguments.Named.Exists("RunAsAdmin") Then
			For Each vArg In WScript.Arguments
				sArgs = sArgs & " """ & vArg & """"
			Next
			sArgs = sArgs & " /RunAsAdmin:True"
			CreateObject("Shell.Application").ShellExecute "WScript.exe", _
				"""" & WScript.ScriptFullName & """" & sArgs, "", "runas", 1
			WScript.Quit(0)
		Else
			sCurDir = Left(WScript.ScriptFullName, InStrRev(WScript.ScriptFullName, "\") -1)
			CreateObject("WScript.Shell").CurrentDirectory = sCurDir
		End If
	End If
End Sub
复制代码

doswork

回复 6# yu2n


    多谢“yu2n”老师提供的方法，不过您这个代码如果test.vbs放在要删除的目录里面就没法删除根目录，只删除了“c:\test”文件夹里面的所有文件/文件夹，但不能删除“c:\test”目录，和原来那个代码还是有区别的，我主要就是想解决这个问题，要不然还得将test.vbs专门找个目录来放置。

    原来代码特点：只要将test.vbs丢到要删除的文件夹里面，运行后就可以自动删除所在根目录以及里面所有文件夹/文件，速度很快，但就是在win7以上系统无效了，不知道哪里的原因……

    原代码出处链接：http://zhidao.baidu.com/question ... BC%D0%3F&ie=gbk

pcl_test

回复 7# doswork

修改6楼前面几行代码

Option Explicit

'以管理员身份运行
RunAsAdmin

Dim wso, cmdLine, DEL_DIR
Set wso = CreateObject("WScript.Shell")
'更改当前目录为C盘根目录，也可以改成别的非VBS文件所在的目录
CreateObject("WScript.Shell").CurrentDirectory = "C:\"
'待删除文件夹
DEL_DIR = CreateObject("Scripting.FileSystemObject").GetFile(Wscript.ScriptFullName).ParentFolder.Path
……
复制代码

yu2n

Option Explicit

Main
Sub Main()

	'以管理员身份运行
	RunAsAdmin

	'待删除文件夹
	Const DEL_DIR = "C:\TEST"

	Dim wso, cmdLine
	Set wso = CreateObject("WScript.Shell")

	'命令：移除属性，删除文件夹/子文件/子文件夹
	cmdLine = "cmd /c " & _
		"attrib -R -A -S -H /S /D """ & DEL_DIR & """ & " & _
		"if exist """ & DEL_DIR & """ rd /s /q """ & DEL_DIR & """"
	Call wso.Run(cmdLine, 0, True)

	'命令：创建文件夹
	cmdLine = "cmd /c " & _
		"if not exist """ & DEL_DIR & """ md """ & DEL_DIR & """"
	Call wso.Run(cmdLine, 0, True)
	
	'提示完成
	Msgbox "完成！", vbInformation, WScript.ScriptFullName
	
End Sub

' 以管理员身份运行 By Yu2n
Sub RunAsAdmin()
	Dim oItems, vItem, sVer, nVer, vArg, sArgs, sCurDir
	Set oItems = GetObject("winmgmts:").InstancesOf("Win32_OperatingSystem")
	For Each vItem In oItems
		sVer = vItem.Version
	Next
	Set oItems = Nothing
	nVer = Clng(Split(sVer, ".")(0) & Split(sVer, ".")(1))
	If nVer >= 60 Then
		If Not WScript.Arguments.Named.Exists("RunAsAdmin") Then
			For Each vArg In WScript.Arguments
				sArgs = sArgs & " """ & vArg & """"
			Next
			sArgs = sArgs & " /RunAsAdmin:True"
			CreateObject("Shell.Application").ShellExecute "WScript.exe", _
				"""" & WScript.ScriptFullName & """" & sArgs, "", "runas", 1
			WScript.Quit(0)
		Else
			sCurDir = Left(WScript.ScriptFullName, InStrRev(WScript.ScriptFullName, "\") -1)
			CreateObject("WScript.Shell").CurrentDirectory = sCurDir
		End If
	End If
End Sub
复制代码

注意：无法删除使用中的文件/文件夹。

doswork

回复 8# pcl_test


    多谢版主回复！可以运行了~

doswork

回复 9# yu2n


    多谢帮助！
    后来又测试，发现原百度贴吧里面的示例第二段儿代码，通过添加延时也解决了问题，单独使用无法删除vbs所在文件夹。
    pcl_test版主的替换后也可以删除VBS所在文件夹。