本帖最后由 kfk 于 2017-12-31 14:21 编辑
本人还魂回来了……
楼主还健在吗？
后来发现上次的vbs不能处理Unicode(路径/文件名)，发奋重写，今日重发。呃……竟已拖了一个月……
新版说明：
◆若无参数（即 双击空运行），则提示：
--------------------------------------------------
(批量)创建快捷方式到指定文件夹
用法：
将 (多个)文件(夹) 发送/拖放 到此文件(或其快捷方式)：
...(本脚本的路径\文件名)
支持Unicode(路径/文件名)的命令行（可用在快捷方式中，以便[发送/拖放]）：
WScript "脚本路径" //u
▲是否创建这样的快捷方式？（之后您可以将它移到需要的位置去）
---------------------------
确定 取消
--------------------------------------------------
◆默认保存20个[历史路径]（数量可自改，详见脚本开头注释）。
▲[历史路径]保存在 本vbs所在夹中（同名txt），最好不要人为编辑，以免vbs读取时出问题。
▲本vbs会自动清理[历史路径]（删重，调序）。
◆询问路径时：
▲可以输入或粘贴（会自动创建）；
▲也可以输入/转用[浏览]进行选择（默认/，可自改，详见脚本开头注释）；
▲[历史路径]则可用(显示在左首的)代号来选择（代号是单个字符，默认是字母A-T(输入时大小写随意)，可自改，详见脚本开头注释）；
▲每条[历史路径]单行显示（因为折行看起来乱），然而窗宽有限，所以长路径中段用...省略。
发现问题我再改。
两个对话框，麻烦截图上来，让我看看在你那里的显示有没毛病。
以下代码仅供阅读（因为可能有些字符被网页转换了），运行请下载附件。
- '==============================
- 'CreateShortcut(s)To.vbs
- 'kfk 2017-12-29 @bbs.kafan.cn
- '============================================================
- '支持Unicode(路径/文件名)的命令行写法：WScript "脚本路径" //u
- '============================================================
- '▼可以是任意字符，但要避免:重复/大小写/两者冲突
- sK = "ABCDEFGHIJKLMNOPQRST" '[历史路径]的代号&数量
- sB = "/" '转向[浏览]
- Set oFSO = CreateObject("Scripting.FileSystemObject")
- Set oShellApp = CreateObject("Shell.Application")
- Set oArgs = WScript.Arguments
- If oArgs.Count = 0 Then
- sCommandLine = "WScript ""脚本路径"" //u"
- sPrompt =_
- "(批量)创建快捷方式到指定文件夹" & vbCr & vbCr &_
- "用法：" & vbCr &_
- "将 (多个)文件(夹) 发送/拖放 到此文件(或其快捷方式)：" & vbCr &_
- WScript.ScriptFullName & vbCr & vbCr &_
- "支持Unicode(路径/文件名)的命令行（可用在快捷方式中，以便[发送/拖放]）：" & vbCr &_
- sCommandLine & vbCr & vbCr &_
- "▲是否创建这样的快捷方式？（之后您可以将它移到需要的位置去）"
- If MsgBox(sPrompt, vbOkCancel) = vbCancel Then WScript.Quit
- sFolder = oFSO.GetParentFolderName(WScript.ScriptFullName)
- sLnk = WScript.ScriptName & " (此lnk支持Unicode路径文件名).lnk"
- sLnkPath = sFolder & "\" & sLnk
- oArgs = Array("WScript")
- Dim oFolderItem, oLnk
- sub_CreateLnk
- oLnk.Arguments = """" & WScript.ScriptFullName & """ //u"
- oLnk.Description = "命令行：" & vbCr & sCommandLine
- oLnk.Save
- Set oShell = WScript.CreateObject("WScript.Shell")
- oShell.Run "%WinDir%\explorer /n,/select,""" & sFolder & "\" & sLnk & """"
- WScript.Quit
- End If
- '▼读取[历史路径]：
- Const cReading = 1, cWriting = 2, cAppending = 8, cCreate = True, cUnicode = True
- sHistoryFile = WScript.ScriptFullName & ".txt"
- If oFSO.FileExists(sHistoryFile) Then
- Set oFile = oFSO.OpenTextFile(sHistoryFile, cReading, Not(cCreate), cUnicode)
- '▼文件为空时避免ReadAll出错：
- If Not oFile.AtEndOfStream Then sHistoryOld = oFile.ReadAll
- oFile.Close
- If sHistoryOld >"" Then
- aPath = Split(sHistoryOld, vbNewLine)
- sHistory = "|"
- For i = 0 To UBound(aPath)
- If aPath(i)>"" Then '跳过空行
- '▼清理重复数据（删旧留新）：
- sHistory = Replace(sHistory, "|" & aPath(i) & "|", "|") & aPath(i) & "|"
- End If
- Next
- aPath = Split(Mid(sHistory,2,Len(sHistory)-2), "|")
- '▼显示[历史路径]：
- For i = 0 To UBound(aPath)
- nLenB = fx_LenB(aPath(i))
- bSameLen = (nLenB = Len(aPath(i)))
- '▼窗宽所限，保证单行显示(清晰)，避免折行(杂乱)：
- If nLenB>36 Then
- If bSameLen Then
- sRight = Right(aPath(i), 30)
- Else
- nChar = 0
- Do
- sRight = Right(aPath(i), 15 + nChar)
- nLenB = fx_LenB(sRight)
- nChar = nChar + 1
- Loop Until nLenB>28
- End If
- sPath = Left(aPath(i),3) & "..." & sRight
- Else
- sPath = aPath(i)
- End If
- j=j+1
- sPrompt = sPrompt & Mid(sK,j,1) & "> " & sPath & vbCr
- Next
- sFolder = aPath(i-1)
- End If
- End If
- If j>3 Then j=3 '▼若[历史路径]数量<4，使提示文字下降接近输入栏
- sPrompt = sPrompt & String(5-j, vbCr) &_
- "创建快捷方式到：(会自动建夹，输" & sB & "转浏览)"
- Do
- sFolder = InputBox(sPrompt, WScript.ScriptName, sFolder)
- If sFolder = "" Then WScript.Quit
- If sFolder = sB Then '▼转向[浏览]
- Set oFolder = oShellApp.BrowseForFolder(0, "创建快捷方式到：", 1)
- If oFolder Is Nothing Then WScript.Quit
- sFolder = oFolder.Self.Path
- Exit Do
- ElseIf Len(sFolder) = 1 Then '[历史路径]代号
- nK = InStr(UCase(Left(sK,UBound(aPath)+1)), UCase(sFolder))
- If nK>0 Then
- sFolder = aPath(nK-1)
- Else
- WScript.Echo "代号不存在！"
- End If
- End If
- If Len(sFolder)>1 Then
- On Error Resume Next
- Set oFolder = oShellApp.NameSpace(Left(sFolder,3))
- oFolder.NewFolder Mid(sFolder,4)
- If Err<>0 Then WScript.Echo "路径有错误！"
- On Error GoTo 0
- End If
- Loop Until oFSO.FolderExists(sFolder)
- '▼清理重复数据（删旧留新）：
- If sHistory>"" Then
- sHistory = Replace(sHistory, "|" & sFolder & "|", "|") & sFolder
- sHistory = Mid(sHistory,2)
- aPath = Split(sHistory,"|")
- nDel = UBound(aPath) - Len(sK)
- For i = 0 To nDel
- aPath(i) = "*"
- Next
- sHistoryNew = Join(Filter(aPath,"*",False), vbNewLine)
- Else
- sHistoryNew = sFolder
- End If
- If sHistoryNew >< sHistoryOld Then
- Set oFile = oFSO.OpenTextFile(sHistoryFile, cWriting, cCreate, cUnicode)
- oFile.Write sHistoryNew
- oFile.Close
- End If
- For i = 0 To oArgs.Count - 1
- sTarget = oFSO.GetFileName(oArgs(i))
- j=1 : sN=""
- Do
- If j>1 Then sN = " {" & j
- sLnk = sTarget & sN & ".lnk"
- sLnkPath = sFolder & "\" & sLnk
- j=j+1
- Loop While oFSO.FileExists(sLnkPath)
- sub_CreateLnk
- Next
- Sub sub_CreateLnk
- oFSO.CreateTextFile sLnkPath ', bOverwrite, bUnicode
- '▲支持Unicode路径\文件名
- Set oFolderItem = oShellApp.NameSpace(sFolder).ParseName(sLnk)
- '▲不支持创建Unicode名，但可读取
- Set oLnk = oFolderItem.GetLink
- oLnk.Path = oArgs(i)
- oLnk.WorkingDirectory = oFSO.GetParentFolderName(oArgs(i))
- 'oLnk.Arguments = ""
- 'oLnk.Hotkey = 0
- 'oLnk.ShowCommand = 1
- 'oLnk.Description = ""
- 'oLnk.SetIconLocation oArgs(i), 0
- oLnk.Save
- End Sub
- '▼利用JScript得到双字节字符个数，以调整字符串显示宽度：
- Function fx_LenB(str)
- Set oSC = CreateObject("MSScriptControl.ScriptControl")
- oSC.Language = "JScript"
- sJS = Replace(str, "\", "*")
- sJS = "'" & sJS & "'.replace(/[^\x00-\xff]/g, '**').length"
- fx_LenB = oSC.Eval(sJS)
- End Function
|
楼主: 527907615
楼主
。对了怎么卡饭好像不支持移动光纤访问了？要开启DAI LI才能正常访问
发表于 2017-11-30 00:29:57
alt加拖放不就好了嘛，windows系统全都支持这个吧
