中国DOS联盟

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

    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

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