求3742668版主的SendTo+(VBS版).rar - 中国DOS联盟论坛

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.打开文件夹.vbs

    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.快捷方式.vbs

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，不过不影响使用。等到有了好的创意后再重写代码。

第1楼　ccwan	发表于 2006-11-16 02:08
金牌会员　发帖 1,160　积分 2,725　来自河北廊坊
求3742668版主的SendTo+(VBS版).rar 各位，3742668版主的SendTo+(VBS版).rar链接好像无效了，相信大家都下了吧，请无私上传一下，谢谢。

第2楼　lxmxn	发表于 2006-11-16 02:35
版主　发帖 4,938　积分 11,386
去看看有没有。 http://zhenlove.com.cn/cndos/fileup/files/SendTo+.zip

第3楼　ccwan	发表于 2006-11-16 02:51
金牌会员　发帖 1,160　积分 2,725　来自河北廊坊
多谢lxmxn兄，不过这好像不是vbs版的。

第4楼　lxmxn	发表于 2006-11-16 04:06
版主　发帖 4,938　积分 11,386
哦，VBS版的我没有收藏，搜索下试试~~

第5楼　ccwan	发表于 2006-11-16 04:30
金牌会员　发帖 1,160　积分 2,725　来自河北廊坊
有劳费心了。

第6楼　3742668	发表于 2006-11-16 13:39
荣誉版主　发帖 718　积分 2,013
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.打开文件夹.vbs 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.快捷方式.vbs 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，不过不影响使用。等到有了好的创意后再重写代码。

第7楼　ccwan	发表于 2006-11-16 21:20
金牌会员　发帖 1,160　积分 2,725　来自河北廊坊
非常感谢3742668版主，很有价值。

第8楼　wydos	发表于 2006-11-16 21:47
中级用户　发帖 117　积分 304
太好了！先收下了！回去慢慢研究！

第9楼　hxuan999	发表于 2006-11-23 02:22
中级用户　发帖 161　积分 337
收下了

第10楼　jianyaogao	发表于 2007-03-17 20:58
初级用户　发帖 22　积分 49
keep it. Thanks

第11楼　slore	发表于 2007-03-18 01:59
铂金会员　发帖 2,478　积分 5,212
貌似没见一个Set xxx=Nothing?

第12楼　fnlwg	发表于 2007-04-07 05:53
新手上路　发帖 2　积分 4
感谢，终于找到了~~~

第13楼　SunRiseBoy	发表于 2007-06-28 23:46
初级用户　发帖 20　积分 38
下载收藏，非常好的工具

第14楼　wert123	发表于 2007-06-29 09:00
中级用户　发帖 135　积分 301
好啊~~ 收下了