生成同名文件夹→VBS版 - 中国DOS联盟论坛


Dim WshSHell,FSO
On Error Resume Next
Set WshSHell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WinVer = WshSHell.Environment("Process")
Set Args = WScript.Arguments
CloseTime = 5
FileName = WScript.ScriptName
FileFullName = WScript.ScriptFullName
FilePath = FSO.GetParentFolderName(FileFullName)
InsPath = FSO.GetSpecialFolder(1)
InsFullName = FSO.BuildPath(InsPath ,FileName)
LnkPathNT = WshSHell.SpecialFolders(2)
LnkPath9X = WshSHell.SpecialFolders(14)
LnkPathAll = WshSHell.SpecialFolders("StartMenu")
OtherFileName="winclip.exe"
OtherFilePath=FSO.GetSpecialFolder(1)
TemFileName="无标题"
TemFilePath=FSO.GetSpecialFolder(2)
Copyright="玲珑科技"
QQ="QQ:25926183"
Email="Email:fty1995@163.com"
InsTitle="生成同名文件夹"
InsAnswer="生成同名文件夹"
RegPath1="HKEY_CLASSES_ROOT\*\shell\RepeatNameToFolder\"
RegValue1="生成与此同名文件夹"
RegForm1="REG_SZ"
RegPath2="HKEY_CLASSES_ROOT\*\shell\RepeatNameToFolder\command\"
RegValue2="wscript.exe " & chr(34) & InsFullName & chr(34) & " " & chr(34) & "%L" & chr(34)
RegForm2="REG_SZ"
RegPath9="HKEY_CLASSES_ROOT\Drive\shell\"
RegPath10="HKEY_CLASSES_ROOT\Directory\shell\"
RegValue13="open"
WshSHell.RegWrite RegPath9,RegValue13,RegForm1
WshSHell.RegWrite RegPath10,RegValue13,RegForm1
IF FileFullName <> InsFullName then
intAnswer = MsgBox("【是】将“"+ InsAnswer +"”加入到右键菜单，"&Chr(10)&Chr(10)&"【否】将“"+ InsAnswer +"”从右键菜单删除。 ", vbQuestion + vbYesNoCancel, "安装 - "+ InsTitle +" - "+ Copyright)
    If intAnswer = vbYes Then
WshSHell.RegWrite RegPath1,RegValue1,RegForm1
WshSHell.RegWrite RegPath2,RegValue2,RegForm2
FSO.GetFile(FileFullName).Copy(InsFullName)
WshSHell.popup _
"添加脚本文件："+chr(10)+InsFullName+chr(10)+chr(10)+ _
"添加注册表项："+chr(10)+chr(34)+ RegPath1 +chr(34)+chr(10)+ _
chr(10) & CloseTime & " 秒钟后本窗口将自动关闭!" +chr(10)+chr(10)+ _
chr(10) & "Copyright(C)  " + Copyright +"   " & QQ &"   " + Email _
, CloseTime, "安装成功 - "+ InsTitle +" - "+ Copyright, 0 + 64
end if
        If intAnswer = vbNo Then
WshSHell.RegDelete RegPath2
WshSHell.RegDelete RegPath1
FSO.DeleteFile InsFullName
WshSHell.popup _
"删除脚本文件："+chr(10)+InsFullName+chr(10)+chr(10)+ _
"删除注册表项："+chr(10)+chr(34)+ RegPath1 +chr(34)+chr(10)+ _
chr(10) & CloseTime & " 秒钟后本窗口将自动关闭!" +chr(10)+chr(10)+ _
chr(10) & "Copyright(C)  " + Copyright +"   " & QQ &"   " + Email _
, CloseTime, "卸载成功 - "+ InsTitle +" - "+ Copyright, 0 + 64
end if
        If intAnswer = vbCancel Then
end if
ELSE
if Args.count="0" then:WScript.Quit(0):end if

If WinVer("OS") <> "Windows_NT" Then'''由环境变量中取可简化判断
CMD="Command.com /C"
else
CMD="CMD.exe /C"
end if
Package = WScript.Arguments.Item(0)
PkgName=FSO.GetBaseName(Package)
PkgPath=FSO.GetParentFolderName(Package)
if (FSO.FolderExists(FSO.BuildPath(PkgPath ,PkgName))) Then
WshSHell.popup +chr(10)+ _
"您要生成的文件夹已经存在，现在将退出。" + _
chr(10)+chr(10) & CloseTime & " 秒后本窗口自动关闭!" +chr(10)+chr(10)+ _
chr(10) & "Copyright(C)  " + Copyright +"   " & QQ &"   " + Email _
, CloseTime, "操作失败 - "+ InsTitle +" - "+ Copyright, 0 + 48
Call quitch
else
Set NewFile = FSO.CreateFolder(FSO.BuildPath(PkgPath ,PkgName))
end if
End IF
Call quitch
sub quitch()
Set WshSHell = Nothing
Set FSO = Nothing
Set Args = Nothing
WScript.Quit(0)
end sub

第1楼　baomaboy	发表于 2007-03-18 05:14
银牌会员　发帖 554　积分 1,513
生成同名文件夹→VBS版 DownLoad文件夹满满的都是收集到的软件，分类存放时总要为每个软件新建个文件夹，然后改名为这软件的名称，然后再把文件拖到文件中，累……于是写了这个小东西，在文件上点右键会有“生成同名文件夹”的选项，执行后会自动在当前目录下生成和文件相同名称的文件夹。 http://zhenlove.com.cn/cndos/fileup/files/RepeatNameToFolder.rar

第2楼　kich	发表于 2007-03-19 10:56
中级用户　发帖 168　积分 397
我想学习VBS，为什么察看原代码的时候，感觉是乱码呢？

第3楼　baomaboy	发表于 2007-03-19 11:11
银牌会员　发帖 554　积分 1,513
用这个解密 http://www.cn-dos.net/forum/viewthread.php?tid=28614&fpage=3

第4楼　kich	发表于 2007-03-19 12:10
中级用户　发帖 168　积分 397
baomaboy 兄，我爱你！想不出其他的词了！

第5楼　kich	发表于 2007-03-24 09:15
中级用户　发帖 168　积分 397
能不能直接帖出代码？？那个解码程序不知道我什么在的机器上运行不了！！

第6楼　baomaboy	发表于 2007-03-24 12:28
银牌会员　发帖 554　积分 1,513
Dim WshSHell,FSO On Error Resume Next Set WshSHell = WScript.CreateObject("WScript.Shell") Set FSO = CreateObject("Scripting.FileSystemObject") Set WinVer = WshSHell.Environment("Process") Set Args = WScript.Arguments CloseTime = 5 FileName = WScript.ScriptName FileFullName = WScript.ScriptFullName FilePath = FSO.GetParentFolderName(FileFullName) InsPath = FSO.GetSpecialFolder(1) InsFullName = FSO.BuildPath(InsPath ,FileName) LnkPathNT = WshSHell.SpecialFolders(2) LnkPath9X = WshSHell.SpecialFolders(14) LnkPathAll = WshSHell.SpecialFolders("StartMenu") OtherFileName="winclip.exe" OtherFilePath=FSO.GetSpecialFolder(1) TemFileName="无标题" TemFilePath=FSO.GetSpecialFolder(2) Copyright="玲珑科技" QQ="QQ:25926183" Email="Email:fty1995@163.com" InsTitle="生成同名文件夹" InsAnswer="生成同名文件夹" RegPath1="HKEY_CLASSES_ROOT\\shell\RepeatNameToFolder\" RegValue1="生成与此同名文件夹" RegForm1="REG_SZ" RegPath2="HKEY_CLASSES_ROOT\\shell\RepeatNameToFolder\command\" RegValue2="wscript.exe " & chr(34) & InsFullName & chr(34) & " " & chr(34) & "%L" & chr(34) RegForm2="REG_SZ" RegPath9="HKEY_CLASSES_ROOT\Drive\shell\" RegPath10="HKEY_CLASSES_ROOT\Directory\shell\" RegValue13="open" WshSHell.RegWrite RegPath9,RegValue13,RegForm1 WshSHell.RegWrite RegPath10,RegValue13,RegForm1 IF FileFullName <> InsFullName then intAnswer = MsgBox("【是】将“"+ InsAnswer +"”加入到右键菜单，"&Chr(10)&Chr(10)&"【否】将“"+ InsAnswer +"”从右键菜单删除。 ", vbQuestion + vbYesNoCancel, "安装 - "+ InsTitle +" - "+ Copyright) If intAnswer = vbYes Then WshSHell.RegWrite RegPath1,RegValue1,RegForm1 WshSHell.RegWrite RegPath2,RegValue2,RegForm2 FSO.GetFile(FileFullName).Copy(InsFullName) WshSHell.popup _ "添加脚本文件："+chr(10)+InsFullName+chr(10)+chr(10)+ _ "添加注册表项："+chr(10)+chr(34)+ RegPath1 +chr(34)+chr(10)+ _ chr(10) & CloseTime & " 秒钟后本窗口将自动关闭!" +chr(10)+chr(10)+ _ chr(10) & "Copyright(C) " + Copyright +" " & QQ &" " + Email _ , CloseTime, "安装成功 - "+ InsTitle +" - "+ Copyright, 0 + 64 end if If intAnswer = vbNo Then WshSHell.RegDelete RegPath2 WshSHell.RegDelete RegPath1 FSO.DeleteFile InsFullName WshSHell.popup _ "删除脚本文件："+chr(10)+InsFullName+chr(10)+chr(10)+ _ "删除注册表项："+chr(10)+chr(34)+ RegPath1 +chr(34)+chr(10)+ _ chr(10) & CloseTime & " 秒钟后本窗口将自动关闭!" +chr(10)+chr(10)+ _ chr(10) & "Copyright(C) " + Copyright +" " & QQ &" " + Email _ , CloseTime, "卸载成功 - "+ InsTitle +" - "+ Copyright, 0 + 64 end if If intAnswer = vbCancel Then end if ELSE if Args.count="0" then:WScript.Quit(0):end if If WinVer("OS") <> "Windows_NT" Then'''由环境变量中取可简化判断 CMD="Command.com /C" else CMD="CMD.exe /C" end if Package = WScript.Arguments.Item(0) PkgName=FSO.GetBaseName(Package) PkgPath=FSO.GetParentFolderName(Package) if (FSO.FolderExists(FSO.BuildPath(PkgPath ,PkgName))) Then WshSHell.popup +chr(10)+ _ "您要生成的文件夹已经存在，现在将退出。" + _ chr(10)+chr(10) & CloseTime & " 秒后本窗口自动关闭!" +chr(10)+chr(10)+ _ chr(10) & "Copyright(C) " + Copyright +" " & QQ &" " + Email _ , CloseTime, "操作失败 - "+ InsTitle +" - "+ Copyright, 0 + 48 Call quitch else Set NewFile = FSO.CreateFolder(FSO.BuildPath(PkgPath ,PkgName)) end if End IF Call quitch sub quitch() Set WshSHell = Nothing Set FSO = Nothing Set Args = Nothing WScript.Quit(0) end sub

第7楼　jmz573515	发表于 2007-04-06 08:27
银牌会员　发帖 464　积分 1,212
楼主可不可以说一下加密原理，谢谢！

第8楼　baomaboy	发表于 2007-04-06 10:04
银牌会员　发帖 554　积分 1,513
Originally posted by jmz573515 at 2007-4-6 08:27: 楼主可不可以说一下加密原理，谢谢！字符串颠倒，msgbox====sgoxbm,解密时还原字符转换，a→n,b→o，c→p。。。z→n，y→m，解密时还原数字同上，变量名随机