中国DOS联盟

-- 联合DOS 推动DOS 发展DOS --

联盟域名：www.cn-dos.net　论坛域名：www.cn-dos.net/forum
DOS，代表着自由开放与发展，我们努力起来，学习FreeDOS和Linux的自由开放与GNU精神，共同创造和发展美好的自由与GNU GPL世界吧！

游客 注册 登录 会员 网志 搜索 命令提示符 Bash 上传 统计
中国DOS联盟论坛
现在时间是 2026-06-14 19:01
欢迎新会员 luminwei　 RSS
共 47,998 篇主题 / 350,065 篇帖子 / 今日 2 篇 / 48,211 位会员
中国DOS联盟论坛 » DOS批处理 & 脚本技术（批处理室） » 求3742668版主的SendTo+(VBS版).rar
推荐给朋友 分享到 X 分享到 微博 分享到 Telegram 分享到 QQ空间 复制链接 二维码
楼 主 求3742668版主的SendTo+(VBS版).rar 发表于 2006-11-16 02:08　·　 中国 河北 廊坊 三河市 移动
ccwan
金牌会员
★★★★
积分 2,725
发帖 1,160
注册 2006-09-23 12:00
UID 63486
来自 河北廊坊
状态 离线
各位，3742668版主的SendTo+(VBS版).rar链接好像无效了，相信大家都下了吧，请无私上传一下，谢谢。
三人行，必有吾师焉。 学然后知不足，教然后知困，然后能自强也。
第 2 楼 发表于 2006-11-16 02:35　·　 中国 湖北 武汉 电信
lxmxn
版主
★★★★★
积分 11,386
发帖 4,938
注册 2006-07-23 17:10
UID 59080
状态 离线
去看看有没有。
http://zhenlove.com.cn/cndos/fileup/files/SendTo+.zip
第 3 楼 发表于 2006-11-16 02:51　·　 中国 河北 廊坊 三河市 移动
ccwan
金牌会员
★★★★
积分 2,725
发帖 1,160
注册 2006-09-23 12:00
UID 63486
来自 河北廊坊
状态 离线
多谢lxmxn兄，不过这好像不是vbs版的。
三人行，必有吾师焉。 学然后知不足，教然后知困，然后能自强也。
第 4 楼 发表于 2006-11-16 04:06　·　 中国 湖北 武汉 电信
lxmxn
版主
★★★★★
积分 11,386
发帖 4,938
注册 2006-07-23 17:10
UID 59080
状态 离线

　　哦，VBS版的我没有收藏，搜索下试试~~
第 5 楼 发表于 2006-11-16 04:30　·　 中国 河北 廊坊 三河市 移动
ccwan
金牌会员
★★★★
积分 2,725
发帖 1,160
注册 2006-09-23 12:00
UID 63486
来自 河北廊坊
状态 离线
有劳费心了。
三人行，必有吾师焉。 学然后知不足，教然后知困，然后能自强也。
第 6 楼 发表于 2006-11-16 13:39　·　 中国 湖北 荆门 电信
3742668
荣誉版主
★★★
积分 2,013
发帖 718
注册 2006-02-18 07:07
UID 50550
状态 离线
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 楼 发表于 2006-11-16 21:20　·　 中国 河北 廊坊 三河市 移动
ccwan
金牌会员
★★★★
积分 2,725
发帖 1,160
注册 2006-09-23 12:00
UID 63486
来自 河北廊坊
状态 离线
非常感谢3742668版主，很有价值。
三人行，必有吾师焉。 学然后知不足，教然后知困，然后能自强也。
第 8 楼 发表于 2006-11-16 21:47　·　 中国 贵州 贵阳 电信
wydos
中级用户
★★
积分 304
发帖 117
注册 2006-04-04 18:43
UID 53325
性别 男
状态 离线
太好了！先收下了！回去慢慢研究！
第 9 楼 发表于 2006-11-23 02:22
hxuan999
中级用户
★★
DOS之日
积分 337
发帖 161
注册 2006-11-04 05:27
UID 69523
性别 男
状态 离线
收下了
for /f %%h in (`echo hxuan`) do for /f %%x in (`echo hxuan`) do if %%h==%%x nul
第 10 楼 发表于 2007-03-17 20:58　·　 中国 上海 黄浦区 电信
jianyaogao
初级用户
★
积分 49
发帖 22
注册 2005-08-04 13:44
UID 41332
性别 男
状态 离线
keep it. Thanks
第 11 楼 发表于 2007-03-18 01:59　·　 中国 陕西 西安 电信
slore
铂金会员
★★★★
积分 5,212
发帖 2,478
注册 2007-02-08 23:39
UID 79003
性别 男
状态 离线
貌似没见一个Set xxx=Nothing?
第 12 楼 发表于 2007-04-07 05:53　·　 中国 安徽 阜阳 电信
fnlwg
新手上路
★
积分 4
发帖 2
注册 2006-08-23 22:24
UID 61150
状态 离线
感谢，终于找到了~~~
第 13 楼 发表于 2007-06-28 23:46　·　 中国 湖北 十堰 郧西县 联通
SunRiseBoy
初级用户
★
积分 38
发帖 20
注册 2006-07-04 16:50
UID 58001
状态 离线
下载收藏，非常好的工具
第 14 楼 发表于 2007-06-29 09:00　·　 中国 湖北 武汉 电信
wert123
中级用户
★★
积分 301
发帖 135
注册 2007-05-15 16:49
UID 88615
性别 男
状态 离线
好啊~~
收下了
可打印版本 | 订阅主题 | 收藏主题
论坛跳转:
[ 联系联盟系统管理团队 - 中国DOS联盟 ]

Sponsored by ifanr Inc | © 2001–2023