标题: 求3742668版主的SendTo+(VBS版).rar [打印本页]
作者: ccwan 时间: 2006-11-16 02:08 标题: 求3742668版主的SendTo+(VBS版).rar
各位，3742668版主的SendTo+(VBS版).rar链接好像无效了，相信大家都下了吧，请无私上传一下，谢谢。
作者: lxmxn 时间: 2006-11-16 02:35
去看看有没有。
http://zhenlove.com.cn/cndos/fileup/files/SendTo+.zip
作者: ccwan 时间: 2006-11-16 02:51
多谢lxmxn兄，不过这好像不是vbs版的。
作者: lxmxn 时间: 2006-11-16 04:06
哦，VBS版的我没有收藏，搜索下试试~~
作者: ccwan 时间: 2006-11-16 04:30
有劳费心了。
作者: 3742668 时间: 2006-11-16 13:39
1.安装.vbs
On Error Resume Next
strCurrentPath = CreateObject("Scripting.FileSystemObject") _
.GetFile(WScript.ScriptFullName).ParentFolder
Set objShell = CreateObject("WScript.Shell")
strPath = objShell.SpecialFolders("SendTo")
'安装快捷方式部分
strPathQuick = strPath & "\快捷方式"
CreateDir strPathQuick
strPrefix = "填加到 "
strSourceFile = strCurrentPath & "\快捷方式.vbs"
CreateLink strPathQuick,strPrefix,strSourceFile,"快速启动",165
CreateLink strPathQuick,strPrefix,strSourceFile,"开始菜单",39
CreateLink strPathQuick,strPrefix,strSourceFile,"收藏夹",43
CreateLink strPathQuick,strPrefix,strSourceFile,"其他文件夹",4
'安装打开文件夹部分
strPathOpen = strPath & "\打开目录"
CreateDir strPathOpen
strPrefix = "打开 "
strSourceFile = strCurrentPath & "\打开文件夹.vbs"
CreateLink strPathOpen,strPrefix,strSourceFile,"控制面板",21
CreateLink strPathOpen,strPrefix,strSourceFile,"我的文档",126
CreateLink strPathOpen,strPrefix,strSourceFile,"收藏夹",43
CreateLink strPathOpen,strPrefix,strSourceFile,"启动",130
CreateLink strPathOpen,strPrefix,strSourceFile,"最近打开的文档",20
CreateLink strPathOpen,strPrefix,strSourceFile,"发送到",137
CreateLink strPathOpen,strPrefix,strSourceFile,"网上邻居",17
CreateLink strPathOpen,strPrefix,strSourceFile,"Windows",38
CreateLink strPathOpen,strPrefix,strSourceFile,"System32",27
CreateLink strPathOpen,strPrefix,strSourceFile,"程序",36
CreateLink strPathOpen,strPrefix,strSourceFile,"当前用户根目录",170
CreateLink strPathOpen,"",strSourceFile,"添加当前目录",4
CreateLink strPathOpen,"",strSourceFile,"移除当前目录",4
Function CreateDir(strPath)
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.CreateFolder(strPath)
CreateDir = f.Path
End Function
Sub CreateLink(strPath,strPrefix,strSourceFile,strArg,intIconNumber)
strFullName = strPath & "\" & strPrefix & strArg & ".lnk"
strArg = Chr(34) & strSourceFile & Chr(34) & Space(1) & strArg
With CreateObject("WScript.Shell").CreateShortcut(strFullName) '快捷方式完整路径
.TargetPath = WScript.FullName '源文件,这里应该是wscript.exe
.Arguments = strArg '参数
' .WindowStyle = 1 '运行方式
' .Hotkey = "" '快捷键
.IconLocation = "shell32.dll," & intIconNumber '图标
' .Description = "" '备注
' .WorkingDirectory = "" '起始目录
.Save
End With
End Sub
2.打开文件夹.vbsstrCurrentPath = CreateObject("Scripting.FileSystemObject") _
.GetFile(WScript.ScriptFullName).ParentFolder
Set objShell = CreateObject("WScript.Shell")
strPath = objShell.SpecialFolders("SendTo")
'安装快捷方式部分
strPathQuick = strPath & "\快捷方式"
CreateDir strPathQuick
strPrefix = "填加到 "
strSourceFile = strCurrentPath & "\快捷方式.vbs"
CreateLink strPathQuick,strPrefix,strSourceFile,"快速启动",165
CreateLink strPathQuick,strPrefix,strSourceFile,"开始菜单",39
CreateLink strPathQuick,strPrefix,strSourceFile,"收藏夹",43
CreateLink strPathQuick,strPrefix,strSourceFile,"其他文件夹",4
'安装打开文件夹部分
strPathOpen = strPath & "\打开目录"
CreateDir strPathOpen
strPrefix = "打开 "
strSourceFile = strCurrentPath & "\打开文件夹.vbs"
CreateLink strPathOpen,strPrefix,strSourceFile,"控制面板",21
CreateLink strPathOpen,strPrefix,strSourceFile,"我的文档",126
CreateLink strPathOpen,strPrefix,strSourceFile,"收藏夹",43
CreateLink strPathOpen,strPrefix,strSourceFile,"启动",130
CreateLink strPathOpen,strPrefix,strSourceFile,"最近打开的文档",20
CreateLink strPathOpen,strPrefix,strSourceFile,"发送到",137
CreateLink strPathOpen,strPrefix,strSourceFile,"网上邻居",17
CreateLink strPathOpen,strPrefix,strSourceFile,"Windows",38
CreateLink strPathOpen,strPrefix,strSourceFile,"System32",27
CreateLink strPathOpen,strPrefix,strSourceFile,"程序",36
CreateLink strPathOpen,strPrefix,strSourceFile,"当前用户根目录",170
CreateLink strPathOpen,"",strSourceFile,"添加当前目录",4
CreateLink strPathOpen,"",strSourceFile,"移除当前目录",4
Function CreateDir(strPath)
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.CreateFolder(strPath)
CreateDir = f.Path
End Function
Sub CreateLink(strPath,strPrefix,strSourceFile,strArg,intIconNumber)
strFullName = strPath & "\" & strPrefix & strArg & ".lnk"
strArg = Chr(34) & strSourceFile & Chr(34) & Space(1) & strArg
With CreateObject("WScript.Shell").CreateShortcut(strFullName) '快捷方式完整路径
.TargetPath = WScript.FullName '源文件,这里应该是wscript.exe
.Arguments = strArg '参数
' .WindowStyle = 1 '运行方式
' .Hotkey = "" '快捷键
.IconLocation = "shell32.dll," & intIconNumber '图标
' .Description = "" '备注
' .WorkingDirectory = "" '起始目录
.Save
End With
End Sub
On Error Resume Next
Set objArgs = WScript.Arguments
If objArgs.Count < 1 Then WScript.Quit
arrArgs = Array("IE","所有程序","控制面板","打印机和传真", _
"我的文档","收藏夹","启动","最近打开的文档","发送到", _
"回收站","开始菜单","暂缺","我的音乐","我的视频", _
"暂缺","桌面","我的电脑","网上邻居","NetHood", _
"字体","Templates","AllUser开始菜单","AllUser所有程序",_
"AllUser启动","AllUser桌面","MY_AppData","PrintHood", _
"MY_AppData2","暂缺","暂缺","AllUser收藏夹","IE缓存", _
"Cookies","历史记录","AllUserAppData","Windows","System32", _
"程序","我的图片","当前用户根目录","公共组件","暂缺",_
"暂缺","暂缺","AllUserTemplates","共享文档", _
"AllUserManagement","管理工具","网络连接","暂缺","暂缺", _
"暂缺","AllUserMusic","AllUserPictures","AllUserVideos", _
"桌面主题","Resources2","none","CD_Burning")
For i = 0 To UBound(arrArgs)
If UCase(arrArgs(i)) = UCase(objArgs(0)) Then
intNumber = i + 1
End If
Next
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(intNumber)
Set objFolderItem = objFolder.Self
If Err.Number <> 0 Then
If UCase(objArgs(0)) = UCase("添加当前目录") Then
AddCurrentFolder(objArgs(1))
ElseIf UCase(objArgs(0)) = UCase("移除当前目录") Then
DelCurrentFolder(objArgs(1))
Else
objShell.Open objArgs(0)
'WScript.Quit
End If
End If
objShell.Open objFolderItem.Path
Sub AddCurrentFolder(str)
On Error Resume Next
strSendTo = CreateObject("Shell.Application").Namespace(9).Self.Path
Set fso = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("WScript.Shell")
Set objFile = fso.GetFile(str)
If Err.Number <> 0 Then
Set objDir = fso.GetFolder(str)
strPath = objDir.Path
strName = objDir.Name
Else
strPath = objFile.ParentFolder.Path
strName = objFile.ParentFolder.Name
End If
strFullName = strSendTo & "\打开目录\打开 " & strName & ".lnk"
With CreateObject("WScript.Shell").CreateShortcut(strFullName)
.TargetPath = WScript.FullName
.Arguments = Chr(34) & WScript.ScriptFullName & Chr(34) & _
Space(1) & Chr(34) & strPath & Chr(34)
.IconLocation = "shell32.dll,4"
.Save
End With
End Sub
Sub DelCurrentFolder(str)
On Error Resume Next
strSendTo = CreateObject("Shell.Application").Namespace(9).Self.Path
Set fso = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("WScript.Shell")
Set objFile = fso.GetFile(str)
If Err.Number <> 0 Then
Set objDir = fso.GetFolder(str)
strPath = objDir.Path
Else
strPath = objFile.ParentFolder.Path
End If
Set objFolder = fso.GetFolder(strSendTo & "\打开目录")
For Each i In objFolder.Files
Set objLink = objShell.CreateShortcut(i)
If objLink.Arguments = Chr(34) & WScript.ScriptFullName & _
Chr(34) & Space(1) & Chr(34) & strPath & Chr(34) Then
fso.DeleteFile i
End If
Next
End Sub
3.快捷方式.vbsSet objArgs = WScript.Arguments
If objArgs.Count < 1 Then WScript.Quit
arrArgs = Array("IE","所有程序","控制面板","打印机和传真", _
"我的文档","收藏夹","启动","最近打开的文档","发送到", _
"回收站","开始菜单","暂缺","我的音乐","我的视频", _
"暂缺","桌面","我的电脑","网上邻居","NetHood", _
"字体","Templates","AllUser开始菜单","AllUser所有程序",_
"AllUser启动","AllUser桌面","MY_AppData","PrintHood", _
"MY_AppData2","暂缺","暂缺","AllUser收藏夹","IE缓存", _
"Cookies","历史记录","AllUserAppData","Windows","System32", _
"程序","我的图片","当前用户根目录","公共组件","暂缺",_
"暂缺","暂缺","AllUserTemplates","共享文档", _
"AllUserManagement","管理工具","网络连接","暂缺","暂缺", _
"暂缺","AllUserMusic","AllUserPictures","AllUserVideos", _
"桌面主题","Resources2","none","CD_Burning")
For i = 0 To UBound(arrArgs)
If UCase(arrArgs(i)) = UCase(objArgs(0)) Then
intNumber = i + 1
End If
Next
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(intNumber)
Set objFolderItem = objFolder.Self
If Err.Number <> 0 Then
If UCase(objArgs(0)) = UCase("添加当前目录") Then
AddCurrentFolder(objArgs(1))
ElseIf UCase(objArgs(0)) = UCase("移除当前目录") Then
DelCurrentFolder(objArgs(1))
Else
objShell.Open objArgs(0)
'WScript.Quit
End If
End If
objShell.Open objFolderItem.Path
Sub AddCurrentFolder(str)
On Error Resume Next
strSendTo = CreateObject("Shell.Application").Namespace(9).Self.Path
Set fso = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("WScript.Shell")
Set objFile = fso.GetFile(str)
If Err.Number <> 0 Then
Set objDir = fso.GetFolder(str)
strPath = objDir.Path
strName = objDir.Name
Else
strPath = objFile.ParentFolder.Path
strName = objFile.ParentFolder.Name
End If
strFullName = strSendTo & "\打开目录\打开 " & strName & ".lnk"
With CreateObject("WScript.Shell").CreateShortcut(strFullName)
.TargetPath = WScript.FullName
.Arguments = Chr(34) & WScript.ScriptFullName & Chr(34) & _
Space(1) & Chr(34) & strPath & Chr(34)
.IconLocation = "shell32.dll,4"
.Save
End With
End Sub
Sub DelCurrentFolder(str)
On Error Resume Next
strSendTo = CreateObject("Shell.Application").Namespace(9).Self.Path
Set fso = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("WScript.Shell")
Set objFile = fso.GetFile(str)
If Err.Number <> 0 Then
Set objDir = fso.GetFolder(str)
strPath = objDir.Path
Else
strPath = objFile.ParentFolder.Path
End If
Set objFolder = fso.GetFolder(strSendTo & "\打开目录")
For Each i In objFolder.Files
Set objLink = objShell.CreateShortcut(i)
If objLink.Arguments = Chr(34) & WScript.ScriptFullName & _
Chr(34) & Space(1) & Chr(34) & strPath & Chr(34) Then
fso.DeleteFile i
End If
Next
End Sub
On Error Resume Next
Set objArgs = WScript.Arguments
If objArgs.Count < 1 Then WScript.Quit
intBeganArg = 1
strPath = GetSystemFolder(objArgs(0))
If Len(Trim(strPath)) = 0 Then
If objArgs(0) = "快速启动" Then
strPath = GetQuickLaunch()
Else
intBeganArg = 0
strPath = GetDirectory()
End If
End If
For i = intBeganArg To objArgs.Count - 1
CreateLink strPath,objArgs(i)
Next
'************************************************************************************
'创建快捷方式
'************************************************************************************
Sub CreateLink(strPath,strFile)
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder(strFile)
If Err.Number <> 0 Then
Set f = fso.GetFile(strFile)
strLinkName = Mid(f.Name,1,InStrRev(f.Name,".")-1)
Else
strLinkName = f.Name
End If
If Len(Trim(strLinkName)) = 0 Or Len(Trim(strFile)) = 0 Then Exit Sub
Set objShell = CreateObject("WScript.Shell")
With objShell.CreateShortcut(strPath &"\" & strLinkName & ".lnk") '存放目录及文件名
.TargetPath = strFile '指向的可执行文件
' .WindowStyle = 1 '运行方式
' .Hotkey = "" '快捷键
' .IconLocation = "c:\xxx\xxx, 0" '图标
' .Description = "" '备注
' .WorkingDirectory = "" '起始目录
.Save
End With
End Sub
'************************************************************************************
'弹出窗口选择目录
'************************************************************************************
Function GetDirectory()
Const MY_COMPUTER = &H10
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 _
(0, "选择文件夹:", 0, strPath)
If objFolder Is Nothing Then
WScript.Quit
End If
Set objFolderItem = objFolder.Self
GetDirectory = objFolderItem.Path
End Function
'************************************************************************************
'获得快速启动的路径
'************************************************************************************
Function GetQuickLaunch()
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(40)
Set objFolderItem = objFolder.Self
GetQuickLaunch = objFolderItem.Path
GetQuickLaunch = GetQuickLaunch & _
"\Application Data\Microsoft\Internet Explorer\Quick Launch"
' Set objNetwork = CreateObject("Wscript.Network")
' strUserName = objNetwork.UserName
' Set fso = CreateObject("Scripting.FileSystemObject")
' Set f = fso.GetFolder(objShell.SpecialFolders(Favorites))
' GetQuickLaunch = f.ParentFolder.ParentFolder & "\" &strUserName & _
' "\Application Data\Microsoft\Internet Explorer\Quick Launch"
End Function
'************************************************************************************
'获得系统文件夹
'************************************************************************************
Function GetSystemFolder(str)
arrArgs = Array("IE","所有程序","控制面板","打印机和传真", _
"我的文档","收藏夹","启动","最近打开的文档","发送到", _
"回收站","开始菜单","暂缺","我的音乐","我的视频", _
"暂缺","桌面","我的电脑","网上邻居","NetHood", _
"字体","Templates","AllUser开始菜单","AllUser所有程序",_
"AllUser启动","AllUser桌面","MY_AppData","PrintHood", _
"MY_AppData2","暂缺","暂缺","AllUser收藏夹","IE缓存", _
"Cookies","历史记录","AllUserAppData","Windows","System32", _
"程序","我的图片","当前用户根目录","公共组件","暂缺",_
"暂缺","暂缺","AllUserTemplates","共享文档", _
"AllUserManagement","管理工具","网络连接","暂缺","暂缺", _
"暂缺","AllUserMusic","AllUserPictures","AllUserVideos", _
"桌面主题","Resources2","none","CD_Burning")
For i = 0 To UBound(arrArgs)
If UCase(arrArgs(i)) = UCase(str) Then
intNumber = i + 1
End If
Next
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(intNumber)
Set objFolderItem = objFolder.Self
GetSystemFolder = objFolderItem.Path
End Function
注意:脚本中有小bug，不过不影响使用。等到有了好的创意后再重写代码。Set objArgs = WScript.Arguments
If objArgs.Count < 1 Then WScript.Quit
intBeganArg = 1
strPath = GetSystemFolder(objArgs(0))
If Len(Trim(strPath)) = 0 Then
If objArgs(0) = "快速启动" Then
strPath = GetQuickLaunch()
Else
intBeganArg = 0
strPath = GetDirectory()
End If
End If
For i = intBeganArg To objArgs.Count - 1
CreateLink strPath,objArgs(i)
Next
'************************************************************************************
'创建快捷方式
'************************************************************************************
Sub CreateLink(strPath,strFile)
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder(strFile)
If Err.Number <> 0 Then
Set f = fso.GetFile(strFile)
strLinkName = Mid(f.Name,1,InStrRev(f.Name,".")-1)
Else
strLinkName = f.Name
End If
If Len(Trim(strLinkName)) = 0 Or Len(Trim(strFile)) = 0 Then Exit Sub
Set objShell = CreateObject("WScript.Shell")
With objShell.CreateShortcut(strPath &"\" & strLinkName & ".lnk") '存放目录及文件名
.TargetPath = strFile '指向的可执行文件
' .WindowStyle = 1 '运行方式
' .Hotkey = "" '快捷键
' .IconLocation = "c:\xxx\xxx, 0" '图标
' .Description = "" '备注
' .WorkingDirectory = "" '起始目录
.Save
End With
End Sub
'************************************************************************************
'弹出窗口选择目录
'************************************************************************************
Function GetDirectory()
Const MY_COMPUTER = &H10
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 _
(0, "选择文件夹:", 0, strPath)
If objFolder Is Nothing Then
WScript.Quit
End If
Set objFolderItem = objFolder.Self
GetDirectory = objFolderItem.Path
End Function
'************************************************************************************
'获得快速启动的路径
'************************************************************************************
Function GetQuickLaunch()
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(40)
Set objFolderItem = objFolder.Self
GetQuickLaunch = objFolderItem.Path
GetQuickLaunch = GetQuickLaunch & _
"\Application Data\Microsoft\Internet Explorer\Quick Launch"
' Set objNetwork = CreateObject("Wscript.Network")
' strUserName = objNetwork.UserName
' Set fso = CreateObject("Scripting.FileSystemObject")
' Set f = fso.GetFolder(objShell.SpecialFolders(Favorites))
' GetQuickLaunch = f.ParentFolder.ParentFolder & "\" &strUserName & _
' "\Application Data\Microsoft\Internet Explorer\Quick Launch"
End Function
'************************************************************************************
'获得系统文件夹
'************************************************************************************
Function GetSystemFolder(str)
arrArgs = Array("IE","所有程序","控制面板","打印机和传真", _
"我的文档","收藏夹","启动","最近打开的文档","发送到", _
"回收站","开始菜单","暂缺","我的音乐","我的视频", _
"暂缺","桌面","我的电脑","网上邻居","NetHood", _
"字体","Templates","AllUser开始菜单","AllUser所有程序",_
"AllUser启动","AllUser桌面","MY_AppData","PrintHood", _
"MY_AppData2","暂缺","暂缺","AllUser收藏夹","IE缓存", _
"Cookies","历史记录","AllUserAppData","Windows","System32", _
"程序","我的图片","当前用户根目录","公共组件","暂缺",_
"暂缺","暂缺","AllUserTemplates","共享文档", _
"AllUserManagement","管理工具","网络连接","暂缺","暂缺", _
"暂缺","AllUserMusic","AllUserPictures","AllUserVideos", _
"桌面主题","Resources2","none","CD_Burning")
For i = 0 To UBound(arrArgs)
If UCase(arrArgs(i)) = UCase(str) Then
intNumber = i + 1
End If
Next
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(intNumber)
Set objFolderItem = objFolder.Self
GetSystemFolder = objFolderItem.Path
End Function
作者: ccwan 时间: 2006-11-16 21:20
非常感谢3742668版主，很有价值。
作者: wydos 时间: 2006-11-16 21:47
太好了！先收下了！回去慢慢研究！
作者: hxuan999 时间: 2006-11-23 02:22
收下了
作者: jianyaogao 时间: 2007-3-17 20:58
keep it. Thanks
作者: slore 时间: 2007-3-18 01:59
貌似没见一个Set xxx=Nothing?
作者: fnlwg 时间: 2007-4-7 05:53
感谢，终于找到了~~~
作者: SunRiseBoy 时间: 2007-6-28 23:46
下载收藏，非常好的工具
作者: wert123 时间: 2007-6-29 09:00
好啊~~
收下了