中国DOS联盟论坛 - Powered by Discuz! Board

标题: 复制路径到剪贴板→VBS版 [打印本页]

作者: baomaboy 时间: 2007-3-18 10:46 标题: 复制路径到剪贴板→VBS版

忘了是从哪得到的PathCopyEx.DLL文件，注册后会在右键菜单中多出一项“复制路径到剪贴板”，日常路径复制操作中确实方便快捷了很多，后来我仿制了功能相同的其它4个版本的“复制路径到到剪贴板”。

①PathCopyEx_DLL原版，只要注册了PathCopyEx.DLL，右键菜单就会出现。
http://zhenlove.com.cn/cndos/fileup/files/PathCopyEx_DLL.rar

②PathCopyEx_Excel.rar，仿制版，缺点是需要EXCEL支持。
http://zhenlove.com.cn/cndos/fileup/files/PathCopyEx_Excel.rar

③PathCopyEx_IE.rar，仿制版，缺点是需要IE支持。
http://zhenlove.com.cn/cndos/fileup/files/PathCopyEx_IE.rar

④PathCopyEx_Notepad.rar，仿制版，优点是无需另外安装支持程序，只需要有记事本功能和wscript这都是系统自带且默认安装的。缺点是操作过程中有记事本窗口闪过。
http://zhenlove.com.cn/cndos/fileup/files/PathCopyEx_Notepad.rar

⑤PathCopyEx_Winclip.rar，仿制版，缺点是需要第三方Winclip的支持。
http://zhenlove.com.cn/cndos/fileup/files/PathCopyEx_Winclip.rar

Last edited by baomaboy on 2007-3-18 at 10:50 AM ]

作者: electronixtar 时间: 2007-3-18 12:39

还是IE版最爽。偶一直用。

作者: baomaboy 时间: 2007-3-18 12:48

Originally posted by electronixtar at 2007-3-18 12:39:
还是IE版最爽。偶一直用。

electronixtar兄用IE版不知遇到过这种情况没，

我安装了Maxthon且是默认的，当我开着Maxthon窗口时再运行IE版的复制路径就会打开一个Maxthon的空白页窗口（about:blank），运行一次开一个，真是让人郁闷。

作者: electronixtar 时间: 2007-3-18 12:51

Originally posted by baomaboy at 2007-3-18 12:48:

electronixtar兄用IE版不知遇到过这种情况没，

我安装了Maxthon且是默认的，当我开着Maxthon窗口时再运行IE版的复制路径就会打开一个Maxthon的空白页窗口（about:blank），运行一次开一个，真是让人郁闷。

当然遇到啦。解决方法：
1. 改MT的配置文件。

2. 用其他的object。不过目前还暂时没有成熟方法。兄有兴趣可以论坛全文搜索 htmlfile 和 about:blank

作者: baomaboy 时间: 2007-3-18 12:54

Originally posted by electronixtar at 2007-3-18 12:51:

当然遇到啦。解决方法：
1. 改MT的配置文件。

2. 用其他的object。不过目前还暂时没有成熟方法。兄有兴趣可以论坛全文搜索 htmlfile 和 about:blank

原来早有解决办法了谢谢兄了

作者: zh159 时间: 2007-3-18 12:56

我下不了文件，贴个IE版的我看看

作者: electronixtar 时间: 2007-3-18 12:59

http://www.cn-dos.net/forum/viewthread.php?tid=24064

http://www.cn-dos.net/forum/viewthread.php?tid=22649

http://www.cn-dos.net/forum/viewthread.php?tid=20933

另外你可以加这个群哈，34021244，里面全是及其牛X的人物，其中9527的WMI和 ADSI 达到了高深莫测的地步，要多多向他学习 vbs。9527 和当年的 kevin1986 都是相当的猛啊。论坛里的前版主 3742668 也是高手中的高手，可惜现在他不上线……

作者: zh159 时间: 2007-3-18 13:25

electronixtar兄，我这里下不了上传系统的文件，贴个IE版的我看看

作者: baomaboy 时间: 2007-3-18 13:28

Originally posted by zh159 at 2007-3-18 13:25:
electronixtar兄，我这里下不了上传系统的文件，贴个IE版的我看看

Set objIE = CreateObject("InternetExplorer.Application")
objIE.Navigate("about:blank")
str = objIE.document.parentwindow.clipboardData.GetData("text")
WScript.Echo str

作者: zh159 时间: 2007-3-18 13:35

这段是显示剪贴板内容？

作者: baomaboy 时间: 2007-3-18 13:41

Originally posted by zh159 at 2007-3-18 13:35:
这段是显示剪贴板内容？

objIE.document.parentwindow.clipboardData.SetData "text", strCopy

strCopy是已取得的字符串

作者: baomaboy 时间: 2007-4-13 13:46

Winclip版



Dim WshSHell,FSO

On Error Resume Next

Set WshSHell = WScript.CreateObject("WScript.Shell")

Set FSO = CreateObject("Scripting.FileSystemObject")

Set WinVer = WshSHell.Environment("Process")

Set Args = WScript.Arguments

CloseTime = 5

FileName = WScript.ScriptName

FileFullName = WScript.ScriptFullName

FilePath = FSO.GetParentFolderName(FileFullName)

InsPath = FSO.GetSpecialFolder(1)

InsFullName = FSO.BuildPath(InsPath ,FileName)

LnkPathNT = WshSHell.SpecialFolders(2)

LnkPath9X = WshSHell.SpecialFolders(14)

LnkPathAll = WshSHell.SpecialFolders("StartMenu")

OtherFileName="winclip.exe"

OtherFilePath=FSO.GetSpecialFolder(1)

TemFileName="无标题"

TemFilePath=FSO.GetSpecialFolder(2)

Copyright="玲珑科技"

QQ="QQ:25926183"

Email="Email:fty1995@163.com"

InsTitle="复制路径到剪贴板-Winclip版"

InsAnswer="复制路径到剪贴板"

RegPath1="HKEY_CLASSES_ROOT\*\shell\PathCopyEx_Winclip\"

RegValue1="复制路径到剪贴板"

RegForm1="REG_SZ"

RegPath2="HKEY_CLASSES_ROOT\*\shell\PathCopyEx_Winclip\command\"

RegValue2="wscript.exe " & chr(34) & InsFullName & chr(34) & " " & chr(34) & "%L" & chr(34)

RegForm2="REG_SZ"

RegPath3="HKEY_CLASSES_ROOT\Directory\shell\PathCopyEx_Winclip\"

RegValue3="复制路径到剪贴板"

RegForm3="REG_SZ"

RegPath4="HKEY_CLASSES_ROOT\Directory\shell\PathCopyEx_Winclip\command\"

RegValue4="wscript.exe " & chr(34) & InsFullName & chr(34) & " " & chr(34) & "%L" & chr(34)

RegForm4="REG_SZ"

RegPath9="HKEY_CLASSES_ROOT\Drive\shell\"

RegPath10="HKEY_CLASSES_ROOT\Directory\shell\"

RegValue13="open"

WshSHell.RegWrite RegPath9,RegValue13,RegForm1

WshSHell.RegWrite RegPath10,RegValue13,RegForm1

IF FileFullName <> InsFullName then

intAnswer = MsgBox("【是】将“"+ InsAnswer +"”加入到右键菜单，"&Chr(10)&Chr(10)&"【否】将“"+ InsAnswer +"”从右键菜单删除。 ", vbQuestion + vbYesNoCancel, "安装 - "+ InsTitle +" - "+ Copyright)

    If intAnswer = vbYes Then

WshSHell.RegWrite RegPath1,RegValue1,RegForm1

WshSHell.RegWrite RegPath2,RegValue2,RegForm2

WshSHell.RegWrite RegPath3,RegValue3,RegForm3

WshSHell.RegWrite RegPath4,RegValue4,RegForm4

FSO.GetFile(FileFullName).Copy(InsFullName)

If (FSO.FileExists(FSO.BuildPath(FilePath,"winclip.llkj"))) Then

FSO.GetFile(FSO.BuildPath(FilePath,"winclip.llkj")).Copy(FSO.BuildPath(OtherFilePath,OtherFileName))

else

Call alltovbs

end if

FSO.GetFile(FSO.BuildPath(FilePath,"winclip.llkj")).Copy(FSO.BuildPath(OtherFilePath,OtherFileName))

WshSHell.popup _

"添加脚本文件："+chr(10)+InsFullName+chr(10)+chr(10)+ _

"添加执行文件："+chr(10)+FSO.BuildPath(OtherFilePath,OtherFileName)+chr(10)+chr(10)+ _

"添加注册表项："+chr(10)+chr(34)+ RegPath1 +chr(34)+chr(10)+chr(34)+ RegPath3 +chr(34)+chr(10) & _

chr(10) & CloseTime & " 秒钟后本窗口将自动关闭!" +chr(10)+chr(10)+ _

chr(10) & "Copyright(C)  " + Copyright +"   " & QQ &"   " + Email _

, CloseTime, "安装成功 - "+ InsTitle +" - "+ Copyright, 0 + 64

end if

        If intAnswer = vbNo Then

WshSHell.RegDelete RegPath4

WshSHell.RegDelete RegPath3

WshSHell.RegDelete RegPath2

WshSHell.RegDelete RegPath1

FSO.DeleteFile InsFullName

FSO.DeleteFile FSO.BuildPath(OtherFilePath,OtherFileName)

WshSHell.popup _

"删除脚本文件："+chr(10)+InsFullName+chr(10)+chr(10)+ _

"删除执行文件："+chr(10)+FSO.BuildPath(OtherFilePath,OtherFileName)+chr(10)+chr(10)+ _

"删除注册表项："+chr(10)+chr(34)+ RegPath1 +chr(34)+chr(10)+chr(34)+ RegPath3 +chr(34)+chr(10) & _

chr(10) & CloseTime & " 秒钟后本窗口将自动关闭!" +chr(10)+chr(10)+ _

chr(10) & "Copyright(C)  " + Copyright +"   " & QQ &"   " + Email _

, CloseTime, "卸载成功 - "+ InsTitle +" - "+ Copyright, 0 + 64

end if

        If intAnswer = vbCancel Then

end if

ELSE

If (FSO.FileExists(FSO.BuildPath(OtherFilePath,OtherFileName))) Then

Set TempFile = FSO.CreateTextFile(FSO.BuildPath(TemFilePath ,TemFileName), True)

TempFile.WriteLine(Args(0))

TempFile.Close

WshSHell.Run (FSO.BuildPath(OtherFilePath,OtherFileName) & " -c " & FSO.BuildPath(TemFilePath ,TemFileName)), vbHide

else

WshSHell.popup +chr(10)+ _

"操作失败了!" +chr(10)+chr(10)+ _

"您的系统丢失文件 “Winclip.exe” ，因此您的操作请求未能成功。" + chr(10)+chr(10)+ _

"对此我们感到非常抱歉，重新执行安装程序可能会解决此问题。" + _

chr(10)+chr(10) & CloseTime & " 秒后本窗口自动关闭!" +chr(10)+chr(10)+ _

chr(10) & "Copyright(C)  " + Copyright +"   " & QQ &"   " + Email _

, CloseTime, "操作失败 - "+ InsTitle +" - "+ Copyright, 0 + 48

End If

End IF

Set WshSHell = Nothing

Set FSO = Nothing

Set Args = Nothing

WScript.Quit(0)



sub alltovbs()

'自生成Winclip.exe

end sub

作者: baomaboy 时间: 2007-4-13 13:48

Notepa版



Dim WshSHell,FSO

On Error Resume Next

Set WshSHell = WScript.CreateObject("WScript.Shell")

Set FSO = CreateObject("Scripting.FileSystemObject")

Set WinVer = WshSHell.Environment("Process")

Set Args = WScript.Arguments

CloseTime = 5

FileName = WScript.ScriptName

FileFullName = WScript.ScriptFullName

FilePath = FSO.GetParentFolderName(FileFullName)

InsPath = FSO.GetSpecialFolder(1)

InsFullName = FSO.BuildPath(InsPath ,FileName)

LnkPathNT = WshSHell.SpecialFolders(2)

LnkPath9X = WshSHell.SpecialFolders(14)

LnkPathAll = WshSHell.SpecialFolders("StartMenu")

OtherFileName="winclip.exe"

OtherFilePath=FSO.GetSpecialFolder(1)

TemFileName="无标题"

TemFilePath=FSO.GetSpecialFolder(2)

Copyright="玲珑科技"

QQ="QQ:25926183"

Email="Email:fty1995@163.com"

InsTitle="复制路径到剪贴板-Notepad版"

InsAnswer="复制路径到剪贴板"

RegPath1="HKEY_CLASSES_ROOT\*\shell\PathCopyEx_Notepad\"

RegValue1="复制路径到剪贴板"

RegForm1="REG_SZ"

RegPath2="HKEY_CLASSES_ROOT\*\shell\PathCopyEx_Notepad\command\"

RegValue2="wscript.exe " & chr(34) & InsFullName & chr(34) & " " & chr(34) & "%L" & chr(34)

RegForm2="REG_SZ"

RegPath3="HKEY_CLASSES_ROOT\Directory\shell\PathCopyEx_Notepad\"

RegValue3="复制路径到剪贴板"

RegForm3="REG_SZ"

RegPath4="HKEY_CLASSES_ROOT\Directory\shell\PathCopyEx_Notepad\command\"

RegValue4="wscript.exe " & chr(34) & InsFullName & chr(34) & " " & chr(34) & "%L" & chr(34)

RegForm4="REG_SZ"

RegPath9="HKEY_CLASSES_ROOT\Drive\shell\"

RegPath10="HKEY_CLASSES_ROOT\Directory\shell\"

RegValue13="open"

WshSHell.RegWrite RegPath9,RegValue13,RegForm1

WshSHell.RegWrite RegPath10,RegValue13,RegForm1

IF FileFullName <> InsFullName then

intAnswer = MsgBox("【是】将“"+ InsAnswer +"”加入到右键菜单，"&Chr(10)&Chr(10)&"【否】将“"+ InsAnswer +"”从右键菜单删除。 ", vbQuestion + vbYesNoCancel, "安装 - "+ InsTitle +" - "+ Copyright)

    If intAnswer = vbYes Then

WshSHell.RegWrite RegPath1,RegValue1,RegForm1

WshSHell.RegWrite RegPath2,RegValue2,RegForm2

WshSHell.RegWrite RegPath3,RegValue3,RegForm3

WshSHell.RegWrite RegPath4,RegValue4,RegForm4

FSO.GetFile(FileFullName).Copy(InsFullName)

WshSHell.popup _

"添加脚本文件："+chr(10)+InsFullName+chr(10)+chr(10)+ _

"添加注册表项："+chr(10)+chr(34)+ RegPath1 +chr(34)+chr(10)+chr(34)+ RegPath3 +chr(34)+chr(10) & _

chr(10) & CloseTime & " 秒钟后本窗口将自动关闭!" +chr(10)+chr(10)+ _

chr(10) & "Copyright(C)  " + Copyright +"   " & QQ &"   " + Email _

, CloseTime, "安装成功 - "+ InsTitle +" - "+ Copyright, 0 + 64

end if

        If intAnswer = vbNo Then

WshSHell.RegDelete RegPath4

WshSHell.RegDelete RegPath3

WshSHell.RegDelete RegPath2

WshSHell.RegDelete RegPath1

FSO.DeleteFile InsFullName

WshSHell.popup _

"删除脚本文件："+chr(10)+InsFullName+chr(10)+chr(10)+ _

"删除注册表项："+chr(10)+chr(34)+ RegPath1 +chr(34)+chr(10)+chr(34)+ RegPath3 +chr(34)+chr(10) & _

chr(10) & CloseTime & " 秒钟后本窗口将自动关闭!" +chr(10)+chr(10)+ _

chr(10) & "Copyright(C)  " + Copyright +"   " & QQ &"   " + Email _

, CloseTime, "卸载成功 - "+ InsTitle +" - "+ Copyright, 0 + 64

end if

        If intAnswer = vbCancel Then

end if

ELSE

If (FSO.FileExists(FSO.BuildPath(FSO.GetSpecialFolder(0) ,"Notepad.exe"))) or (FSO.FileExists(FSO.BuildPath(FSO.GetSpecialFolder(0) ,"Notepad.exe"))) Then

Set TempFile = FSO.CreateTextFile(FSO.BuildPath(TemFilePath ,TemFileName), True)

TempFile.WriteLine(Args(0))

TempFile.Close

WshSHell.Run ("Notepad.exe " & FSO.BuildPath(TemFilePath ,TemFileName))

WScript.Sleep 230

If WshSHell.AppActivate(TemFileName & " - 记事本") = True Then

WshSHell.Sendkeys "^{a}^{c}"

WshSHell.Sendkeys "%FX"

else

WshSHell.AppActivate(TemFileName & " - 记事本")

WScript.Sleep 200

WshSHell.Sendkeys "^{a}^{c}"

WshSHell.Sendkeys "%FX"

End If

Else

WshSHell.popup +chr(10)+ _

"操作失败了!" +chr(10)+chr(10)+ _

"您的系统没有安装 Notepad ，因此您的操作请求未能成功！" + chr(10)+chr(10)+ _

"呵呵呵....你装的什么外星系统啊，怎么连“记事本”都没有！" + _

chr(10)+chr(10) & CloseTime & " 秒后本窗口自动关闭!" +chr(10)+chr(10)+ _

chr(10) & "Copyright(C)  " + Copyright +"   " & QQ &"   " + Email _

, CloseTime, "操作失败 - "+ InsTitle +" - "+ Copyright, 0 + 48

End If

End IF

Set WshSHell = Nothing

Set FSO = Nothing

Set Args = Nothing

WScript.Quit(0)

作者: baomaboy 时间: 2007-4-13 13:50

IE版



Dim WshSHell,FSO

On Error Resume Next

Set WshSHell = WScript.CreateObject("WScript.Shell")

Set FSO = CreateObject("Scripting.FileSystemObject")

Set WinVer = WshSHell.Environment("Process")

Set Args = WScript.Arguments

CloseTime = 5

FileName = WScript.ScriptName

FileFullName = WScript.ScriptFullName

FilePath = FSO.GetParentFolderName(FileFullName)

InsPath = FSO.GetSpecialFolder(1)

InsFullName = FSO.BuildPath(InsPath ,FileName)

LnkPathNT = WshSHell.SpecialFolders(2)

LnkPath9X = WshSHell.SpecialFolders(14)

LnkPathAll = WshSHell.SpecialFolders("StartMenu")

OtherFileName="winclip.exe"

OtherFilePath=FSO.GetSpecialFolder(1)

TemFileName = "无标题"

TemFilePath = FSO.GetSpecialFolder(2)

Copyright="玲珑科技"

QQ="QQ:25926183"

Email="Email:fty1995@163.com"

InsTitle="复制路径到剪贴板-IE版"

InsAnswer="复制路径到剪贴板"

RegPath1="HKEY_CLASSES_ROOT\*\shell\PathCopyEx_IE\"

RegValue1="复制路径到剪贴板"

RegForm1="REG_SZ"

RegPath2="HKEY_CLASSES_ROOT\*\shell\PathCopyEx_IE\command\"

RegValue2="wscript.exe " & chr(34) & InsFullName & chr(34) & " " & chr(34) & "%L" & chr(34)

RegForm2="REG_SZ"

RegPath3="HKEY_CLASSES_ROOT\Directory\shell\PathCopyEx_IE\"

RegValue3="复制路径到剪贴板"

RegForm3="REG_SZ"

RegPath4="HKEY_CLASSES_ROOT\Directory\shell\PathCopyEx_IE\command\"

RegValue4="wscript.exe " & chr(34) & InsFullName & chr(34) & " " & chr(34) & "%L" & chr(34)

RegForm4="REG_SZ"

RegPath9="HKEY_CLASSES_ROOT\Drive\shell\"

RegPath10="HKEY_CLASSES_ROOT\Directory\shell\"

RegValue13="open"

WshSHell.RegWrite RegPath9,RegValue13,RegForm1

WshSHell.RegWrite RegPath10,RegValue13,RegForm1

IF FileFullName <> InsFullName then

intAnswer = MsgBox("【是】将“"+ InsAnswer +"”加入到右键菜单，"&Chr(10)&Chr(10)&"【否】将“"+ InsAnswer +"”从右键菜单删除。 ", vbQuestion + vbYesNoCancel, "安装 - "+ InsTitle +" - "+ Copyright)

    If intAnswer = vbYes Then

WshSHell.RegWrite RegPath1,RegValue1,RegForm1

WshSHell.RegWrite RegPath2,RegValue2,RegForm2

WshSHell.RegWrite RegPath3,RegValue3,RegForm3

WshSHell.RegWrite RegPath4,RegValue4,RegForm4

FSO.GetFile(FileFullName).Copy(InsFullName)

WshSHell.popup _

"添加脚本文件："+chr(10)+InsFullName+chr(10)+chr(10)+ _

"添加注册表项："+chr(10)+chr(34)+ RegPath1 +chr(34)+chr(10)+chr(34)+ RegPath3 +chr(34)+chr(10) & _

chr(10) & CloseTime & " 秒钟后本窗口将自动关闭!" +chr(10)+chr(10)+ _

chr(10) & "Copyright(C)  " + Copyright +"   " & QQ &"   " + Email _

, CloseTime, "安装成功 - "+ InsTitle +" - "+ Copyright, 0 + 64

end if

        If intAnswer = vbNo Then

WshSHell.RegDelete RegPath4

WshSHell.RegDelete RegPath3

WshSHell.RegDelete RegPath2

WshSHell.RegDelete RegPath1

FSO.DeleteFile InsFullName

WshSHell.popup _

"删除脚本文件："+chr(10)+InsFullName+chr(10)+chr(10)+ _

"删除注册表项："+chr(10)+chr(34)+ RegPath1 +chr(34)+chr(10)+chr(34)+ RegPath3 +chr(34)+chr(10) & _

chr(10) & CloseTime & " 秒钟后本窗口将自动关闭!" +chr(10)+chr(10)+ _

chr(10) & "Copyright(C)  " + Copyright +"   " & QQ &"   " + Email _

, CloseTime, "卸载成功 - "+ InsTitle +" - "+ Copyright, 0 + 64

end if

        If intAnswer = vbCancel Then

end if

ELSE

Dim objIE

Set objIE = WScript.CreateObject("InternetExplorer.Application")

if objIE is Nothing then

WshSHell.popup +chr(10)+ _

"操作失败了!" +chr(10)+chr(10)+ _

"检测到您的系统没有安装 InternetExplorer ，因此您的操作请求未能成功！" + _

chr(10)+chr(10) & CloseTime & " 秒后本窗口自动关闭!" +chr(10)+chr(10)+ _

chr(10) & "Copyright(C)  " + Copyright +"   " & QQ &"   " + Email _

, CloseTime, "操作失败 - "+ InsTitle +" - "+ Copyright, 0 + 48

else

objIE.Visible = False

strCopy = Args(0)

objIE.Navigate("about:blank") 

objIE.document.parentwindow.clipboardData.SetData "text", strCopy

Set objIE = Nothing

end if

End IF

Set WshSHell = Nothing

Set FSO = Nothing

Set Args = Nothing

WScript.Quit(0)

作者: baomaboy 时间: 2007-4-13 13:51

Excel版



Dim WshSHell,FSO

On Error Resume Next

Set WshSHell = WScript.CreateObject("WScript.Shell")

Set FSO = CreateObject("Scripting.FileSystemObject")

Set WinVer = WshSHell.Environment("Process")

Set Args = WScript.Arguments

CloseTime = 5

FileName = WScript.ScriptName

FileFullName = WScript.ScriptFullName

FilePath = FSO.GetParentFolderName(FileFullName)

InsPath = FSO.GetSpecialFolder(1)

InsFullName = FSO.BuildPath(InsPath ,FileName)

LnkPathNT = WshSHell.SpecialFolders(2)

LnkPath9X = WshSHell.SpecialFolders(14)

LnkPathAll = WshSHell.SpecialFolders("StartMenu")

OtherFileName="winclip.exe"

OtherFilePath=FSO.GetSpecialFolder(1)

TemFileName = "无标题"

TemFilePath = FSO.GetSpecialFolder(2)

Copyright="玲珑科技"

QQ="QQ:25926183"

Email="Email:fty1995@163.com"

InsTitle="复制路径到剪贴板-Excel版"

InsAnswer="复制路径到剪贴板"

RegPath1="HKEY_CLASSES_ROOT\*\shell\PathCopyEx_Excel\"

RegValue1="复制路径到剪贴板"

RegForm1="REG_SZ"

RegPath2="HKEY_CLASSES_ROOT\*\shell\PathCopyEx_Excel\command\"

RegValue2="wscript.exe " & chr(34) & InsFullName & chr(34) & " " & chr(34) & "%L" & chr(34)

RegForm2="REG_SZ"

RegPath3="HKEY_CLASSES_ROOT\Directory\shell\PathCopyEx_Excel\"

RegValue3="复制路径到剪贴板"

RegForm3="REG_SZ"

RegPath4="HKEY_CLASSES_ROOT\Directory\shell\PathCopyEx_Excel\command\"

RegValue4="wscript.exe " & chr(34) & InsFullName & chr(34) & " " & chr(34) & "%L" & chr(34)

RegForm4="REG_SZ"

RegPath9="HKEY_CLASSES_ROOT\Drive\shell\"

RegPath10="HKEY_CLASSES_ROOT\Directory\shell\"

RegValue13="open"

WshSHell.RegWrite RegPath9,RegValue13,RegForm1

WshSHell.RegWrite RegPath10,RegValue13,RegForm1

IF FileFullName <> InsFullName then

intAnswer = MsgBox("【是】将“"+ InsAnswer +"”加入到右键菜单，"&Chr(10)&Chr(10)&"【否】将“"+ InsAnswer +"”从右键菜单删除。 ", vbQuestion + vbYesNoCancel, "安装 - "+ InsTitle +" - "+ Copyright)

    If intAnswer = vbYes Then

WshSHell.RegWrite RegPath1,RegValue1,RegForm1

WshSHell.RegWrite RegPath2,RegValue2,RegForm2

WshSHell.RegWrite RegPath3,RegValue3,RegForm3

WshSHell.RegWrite RegPath4,RegValue4,RegForm4

FSO.GetFile(FileFullName).Copy(InsFullName)

WshSHell.popup _

"添加脚本文件："+chr(10)+InsFullName+chr(10)+chr(10)+ _

"添加注册表项："+chr(10)+chr(34)+ RegPath1 +chr(34)+chr(10)+chr(34)+ RegPath3 +chr(34)+chr(10) & _

chr(10) & CloseTime & " 秒钟后本窗口将自动关闭!" +chr(10)+chr(10)+ _

chr(10) & "Copyright(C)  " + Copyright +"   " & QQ &"   " + Email _

, CloseTime, "安装成功 - "+ InsTitle +" - "+ Copyright, 0 + 64

end if

        If intAnswer = vbNo Then

WshSHell.RegDelete RegPath4

WshSHell.RegDelete RegPath3

WshSHell.RegDelete RegPath2

WshSHell.RegDelete RegPath1

FSO.DeleteFile InsFullName

WshSHell.popup _

"删除脚本文件："+chr(10)+InsFullName+chr(10)+chr(10)+ _

"删除注册表项："+chr(10)+chr(34)+ RegPath1 +chr(34)+chr(10)+chr(34)+ RegPath3 +chr(34)+chr(10) & _

chr(10) & CloseTime & " 秒钟后本窗口将自动关闭!" +chr(10)+chr(10)+ _

chr(10) & "Copyright(C)  " + Copyright +"   " & QQ &"   " + Email _

, CloseTime, "卸载成功 - "+ InsTitle +" - "+ Copyright, 0 + 64

end if

        If intAnswer = vbCancel Then

end if

ELSE

Dim objXL

Set objXL = WScript.CreateObject("Excel.Application")

if objXL is Nothing then

WshSHell.popup +chr(10)+ _

"操作失败了!" +chr(10)+chr(10)+ _

"检测到您的系统没有安装 Excel ，因此您的操作请求未能成功！" + _

chr(10)+chr(10) & CloseTime & " 秒后本窗口自动关闭!" +chr(10)+chr(10)+ _

chr(10) & "Copyright(C)  " + Copyright +"   " & QQ &"   " + Email _

, CloseTime, "操作失败 - "+ InsTitle +" - "+ Copyright, 0 + 48

else

objXL.Visible = False

objXL.CutCopyMode = False

objXL.WorkBooks.Add

objXL.Range("A1").Value = Args(0)

objXL.Range("A1").Select

objXL.Range("A1").copy

objXL.DisplayAlerts = False

objXL.WorkBooks.Close

objXL.Quit

objXL.DisplayAlerts = True

Set objXL = Nothing

end if

End IF

Set WshSHell = Nothing

Set FSO = Nothing

Set Args = Nothing

WScript.Quit(0)

作者: baomaboy 时间: 2007-4-13 14:02 标题: DLL版



Dim WshSHell,FSO

On Error Resume Next

Set WshSHell = WScript.CreateObject("WScript.Shell")

Set FSO = CreateObject("Scripting.FileSystemObject")

Set WinVer = WshSHell.Environment("Process")

Set Args = WScript.Arguments

CloseTime = 5

FileName = WScript.ScriptName

FileFullName = WScript.ScriptFullName

FilePath = FSO.GetParentFolderName(FileFullName)

InsPath = FSO.GetSpecialFolder(1)

InsFullName = FSO.BuildPath(InsPath ,FileName)

LnkPathNT = WshSHell.SpecialFolders(2)

LnkPath9X = WshSHell.SpecialFolders(14)

LnkPathAll = WshSHell.SpecialFolders("StartMenu")

OtherFileName="PathCopyEx.dll"

OtherFilePath=FSO.GetSpecialFolder(1)

TemFileName = "PathCopyEx.reg"

TemFilePath = FSO.GetSpecialFolder(1)

Copyright="玲珑科技"

QQ="QQ:25926183"

Email="Email:fty1995@163.com"

InsTitle="复制路径到剪贴板-DLL版"

InsAnswer="复制路径到剪贴板"

RegPath1="HKEY_CLASSES_ROOT\*\shellex\ContextMenuHandlers\PathCopyMenu\"

RegPath2="HKEY_CLASSES_ROOT\Directory\shellex\ContextMenuHandlers\PathCopyMenu\"

IF FileFullName <> InsFullName then

intAnswer = MsgBox("【是】将“"+ InsAnswer +"”加入到右键菜单，"&Chr(10)&Chr(10)&"【否】将“"+ InsAnswer +"”从右键菜单删除。 ", vbQuestion + vbYesNoCancel, "安装 - "+ InsTitle +" - "+ Copyright)

    If intAnswer = vbYes Then

If (FSO.FileExists(FSO.BuildPath(OtherFilePath,OtherFileName))) Then

WshSHell.Run ("regsvr32 /s " & FSO.BuildPath(OtherFilePath,OtherFileName)), vbHide

Else

If (FSO.FileExists(FSO.BuildPath(FilePath,"PathCopyEx.llkj"))) Then

FSO.GetFile(FSO.BuildPath(FilePath,"PathCopyEx.llkj")).Copy(FSO.BuildPath(OtherFilePath,OtherFileName))

else

Call alltovbs

end if

WScript.Sleep 2000

WshSHell.Run ("regsvr32 /s " & FSO.BuildPath(OtherFilePath,OtherFileName)), vbHide

end if

WshSHell.popup _

"添加动态链接："+chr(10)+FSO.BuildPath(OtherFilePath,OtherFileName)+chr(10)+chr(10)+ _

"添加注册表项："+chr(10)+chr(34)+ RegPath1 +chr(34)+chr(10)+chr(34)+ RegPath2 +chr(34)+chr(10) & _

chr(10) & CloseTime & " 秒钟后本窗口将自动关闭!" +chr(10)+chr(10)+ _

chr(10) & "Copyright(C)  " + Copyright +"   " & QQ &"   " + Email _

, CloseTime, "安装成功 - "+ InsTitle +" - "+ Copyright, 0 + 64

end if

        If intAnswer = vbNo Then

WshSHell.Run ("regsvr32 /u /s " & FSO.BuildPath(OtherFilePath,OtherFileName)), vbHide

FSO.DeleteFile FSO.BuildPath(OtherFilePath,OtherFileName)

If (FSO.FileExists(FSO.BuildPath(OtherFilePath,OtherFileName))) Then

WshSHell.popup +chr(10)+ _

"链接库文件 "&FSO.BuildPath(OtherFilePath,OtherFileName)&" 正被系统占用，" + chr(10)+chr(10)+ _

"现在尝试重启Explorer后再删除。" + _

chr(10)+chr(10) & CloseTime & " 秒后本窗口自动关闭!" +chr(10)+chr(10)+ _

chr(10) & "Copyright(C)  " + Copyright +"   " & QQ &"   " + Email _

, CloseTime, "卸载过程 - "+ InsTitle +" - "+ Copyright, 0 + 64

If WinVer("OS") <> "Windows_NT" Then

WshSHell.Run ("RUNDLL32 SHELL32.DLL,SHExitWindowsEx -1"), vbHide

WScript.Sleep 3000

FSO.DeleteFile FSO.BuildPath(OtherFilePath,OtherFileName)

If (FSO.FileExists(FSO.BuildPath(OtherFilePath,OtherFileName))) Then''如重启explorer仍拒删，写入Wininit.ini下次启动时删除，用于winme

if (FSO.FileExists(FSO.BuildPath(FSO.GetSpecialFolder(0) ,"Wininit.ini"))) Then

Set OldFile = FSO.OpenTextFile(FSO.BuildPath(FSO.GetSpecialFolder(0) ,"Wininit.ini"), 8, True)

OldFile.WriteLine("")

OldFile.WriteLine("nul="&FSO.BuildPath(OtherFilePath,FSo.GetFile(FSO.BuildPath(OtherFilePath,OtherFileName)).ShortName))

OldFile.Close

else

Set NewFile = FSO.CreateTextFile(FSO.GetSpecialFolder(0) &"\Wininit.ini", True)

NewFile.WriteLine("")

NewFile.WriteLine("")

NewFile.WriteLine("nul="&FSO.BuildPath(OtherFilePath,FSo.GetFile(FSO.BuildPath(OtherFilePath,OtherFileName)).ShortName))

NewFile.Close

end if

if (FSO.FileExists(FSO.BuildPath(FSO.GetSpecialFolder(0) ,"winstart.bat"))) Then''如重启explorer仍拒删，写入winstart.bat下次启动时删除，用于win98

Set OldFile = FSO.OpenTextFile(FSO.BuildPath(FSO.GetSpecialFolder(0) ,"winstart.bat"), 8, True)

OldFile.WriteLine("")

OldFile.WriteLine("deltree /y "&FSO.BuildPath(OtherFilePath,FSo.GetFile(FSO.BuildPath(OtherFilePath,OtherFileName)).ShortName))

OldFile.WriteLine("@ del %0")

OldFile.Close

else

Set NewFile = FSO.CreateTextFile(FSO.GetSpecialFolder(0) &"\winstart.bat", True)

NewFile.WriteLine("@echo off")

NewFile.WriteLine("")

NewFile.WriteLine("deltree /y "&FSO.BuildPath(OtherFilePath,FSo.GetFile(FSO.BuildPath(OtherFilePath,OtherFileName)).ShortName))

NewFile.WriteLine("@ del %0")

NewFile.Close

end if

else

Call delok

end if

else

For Each Process in GetObject("winmgmts:"). _

ExecQuery ("select * from Win32_Process where name='explorer.exe'")

Process.terminate(0)

Next

WScript.Sleep 3000

FSO.DeleteFile FSO.BuildPath(OtherFilePath,OtherFileName)

WScript.Sleep 3000

for each ps in getobject _

("winmgmts:\\.\root\cimv2:win32_process").instances_

if LCase(ps.name)="explorer.exe" then

expl="yes"

exit for

else

expl="no"

end if

next

if expl="no" then

WshSHell.Run ("explorer.exe")

end if

If (FSO.FileExists(FSO.BuildPath(OtherFilePath,OtherFileName))) Then''如重启explorer仍拒删，写入注册表下次启动时删除，用于winxp

Set NewRegFile = FSO.CreateTextFile(FSO.BuildPath(TemFilePath ,TemFileName), True)

NewRegFile.WriteLine("Windows Registry Editor Version 5.00")

NewRegFile.WriteLine("")

NewRegFile.WriteLine("")

NewRegFile.WriteLine(chr(34)&"PendingFileRenameOperations"&chr(34)&"=hex(7):5c,00,3f,00,3f,00,5c,00,43,00,3a,00,5c,00,\")

NewRegFile.WriteLine("  57,00,49,00,4e,00,44,00,4f,00,57,00,53,00,5c,00,73,00,79,00,73,00,74,00,65,\")

NewRegFile.WriteLine("  00,6d,00,33,00,32,00,5c,00,50,00,61,00,74,00,68,00,43,00,6f,00,70,00,79,00,\")

NewRegFile.WriteLine("  45,00,78,00,2e,00,64,00,6c,00,6c,00,00,00,00,00")

NewRegFile.Close''可以用WMI创建多字符串值

WshSHell.Run ("regedit.exe /s "&FSO.BuildPath(TemFilePath ,TemFileName)), vbHide

else

Call delok

end if

end if

If (FSO.FileExists(FSO.BuildPath(OtherFilePath,OtherFileName))) Then

WshSHell.popup +chr(10)+ _

"链接库文件 "&FSO.BuildPath(OtherFilePath,OtherFileName)&" 正被系统占用，" + chr(10)+chr(10)+ _

"只能在系统重启后被删除。" + _

chr(10)+chr(10) & CloseTime & " 秒后本窗口自动关闭!" +chr(10)+chr(10)+ _

chr(10) & "Copyright(C)  " + Copyright +"   " & QQ &"   " + Email _

, CloseTime, "卸载成功 - "+ InsTitle +" - "+ Copyright, 0 + 64

end if

Else

Call delok

end if

End If

        If intAnswer = vbCancel Then

end if

End IF

Set WshSHell = Nothing

Set FSO = Nothing

Set Args = Nothing

WScript.Quit(0)

Sub delok()

WshSHell.popup _

"删除动态链接："+chr(10)+FSO.BuildPath(OtherFilePath,OtherFileName)+chr(10)+chr(10)+ _

"删除注册表项："+chr(10)+chr(34)+ RegPath1 +chr(34)+chr(10)+chr(34)+ RegPath2 +chr(34)+chr(10) & chr(10) + _

chr(10)+chr(10) & CloseTime & " 秒钟后本窗口将自动关闭!" +chr(10)+chr(10)+ _

chr(10) & "Copyright(C)  " + Copyright +"   " & QQ &"   " + Email _

, CloseTime, "卸载成功 - "+ InsTitle +" - "+ Copyright, 0 + 64

End Sub

sub alltovbs()

'自生成PathCopyEx.Dll

end sub