文件、文件夹合并与拆分的VBS工具WinSCF

HAT · 发表于 2010-2-26 15:13:44

有一种叫做“存储压缩”，后缀为 .tar 的文件，它是把很多东西原封不动地塞到一个文件中，我这个工具就跟它基本一样，
区别是它的结构是“信息1+数据1+信息2+数据2...”，而我的是“所有信息+所有数据”。

用我这个工具合并出来的文件的数据部分和用 copy /b + 命令合并出来的一样，但是想把用 copy 合并的各个文件、文件夹以及属性还原出来就不行了，
这个工具之所以能还原出来，是因为我在文件头部加上了需要的信息，程序解析之后就能知道什么是什么了，这就是本工具的原理。

我将生成出来的文件的扩展名固定为 .scf，目的有两个，一是为了美观，你们可以自己设置它的图标，详情见注释；而是对菜鸟来说这种文件双击不能打开，也没有打开方式，避免麻烦。

如果你对VBS脚本比较了解的话，还可以自己修改这个工具，在最前面的一些常量是强烈建议大家修改的，比如自定义图标，右键菜单名，更重要的是修改文件头的分隔符，这样的话即使别人也有这个程序，也会由于解析错误而不能打开你的文件（当然，这只是针对一般人而言）。

刚用 ADODB.Stream 不久，还不太熟练，有些问题不懂，比如怎么将一个字符串追加到二进制流中等，要是行的话代码还能精简很多，忘知情人士指点指点。
代码比较长就不贴出来了，自己用记事本打开看，自我认为注释应该还是比较详细的。

图片是使用说明，建议添加到右键---发送到菜单，很方便的。

第一次使用：

合并和拆分都会要求选择存放路径：

如果选中多个文件则合并：

选中一个文件且后缀为scf则提示是否拆分：

HAT · 发表于 2010-2-26 15:21:23

Option Explicit
' 生成的文件的图标
Const FILE_ICON = "shell32.dll,47"
' 我在 “右键---发送到” 菜单中的名字
Const SEND_TO_NAME = "『据说是李先生』"
' 我在 “右键---发送到” 菜单中的图标
Const SEND_TO_ICON = "shell32.dll,44"
' 文件头中用于分隔数据的符号
' 为了保持其唯一性请使用包含非法文件名字符的字符串，
' 且他们依次不能是被包含关系，如依次为 (*_*)，|囧|，*^?^* 等。
' 文件夹和文件数据的分隔
Const DELIM_FOLDERS_FILES = "*"
' 各条目的分隔
Const DELIM_ITEMS = "|"
' 各属性数据的分隔
Const DELIM_PROPERTIES = "?"
' 文件头的长度不超过此位数数字代表的大小
Const HEAD_MAX_SIZE_LENGTH = 8
' 废物，有且仅有一个（字节）
Const CHING = "@"
If WScript.Arguments.Count < 1 Then AboutMe
'*****************************************************************************************************
'全局变量：
' 文件名截断位置，“当前文件夹（含最后的\）”，文件数，文件夹数，
' 包装文件头，临时文件名，
' ADODB.Stream对象（用于写），ADODB.Stream对象（用于读），FileSystemObject对象，
' files （key="路径",value="相对文件名|属性|大小（字节）"）
' folders （key="路径",value="相对文件名|属性"）
Dim cutPos, destDir, filesCount, foldersCount, fileHead, tempFile, wst, rst, fso, files, folders
cutPos = InStrRev(WScript.Arguments(0), "") + 1
destDir = Left(WScript.Arguments(0), cutPos - 1)
filesCount = 0
foldersCount = 0
fileHead = ""
Set wst = CreateObject("ADODB.Stream")
Set rst = CreateObject("ADODB.Stream")
Set fso = CreateObject("Scripting.FileSystemObject")
Set files = CreateObject("Scripting.Dictionary")
Set folders = CreateObject("Scripting.Dictionary")
tempFile = fso.GetSpecialFolder(2).Path & "\~$ching$.tmp"
Dim JoinOrSplit
JoinOrSplit = True
If WScript.Arguments.Count = 1 Then
If LCase(Right(WScript.Arguments(0), 4)) = ".scf" Then
JoinOrSplit = MsgBox("此文件可能是已经合并了的, 你是想把它释放出来吗 ?", 4131, "询问")
If JoinOrSplit = 6 Then
JoinOrSplit = False
ElseIf JoinOrSplit = 2 Then
WScript.Quit
End If
End If
End If
If JoinOrSplit Then
JoinMain
Else
SplitMain
End If
'*****************************************************************************************************
'************************
'** 合并文件的主函数 **
'************************
Sub JoinMain()
Dim saveFolder, saveFilePath, isOverWrite, timeStart
isOverWrite = False
saveFolder = selectOneFolder()
saveFilePath = inputOneFile(saveFolder, isOverWrite)
timeStart = Timer
'把参数中所有指定的东西都浏览一遍，并将有用信息记录保存在 files 和 folders 对象中
Dim pathspec
For Each pathspec In WScript.Arguments
If fso.FileExists(pathspec) Then SearchFile pathspec
If fso.FolderExists(pathspec) Then SearchFolder pathspec
Next
' 用 fso 创建纯文本的文件头
CreateHead
' 合并所有文件
JoinFiles saveFilePath, isOverWrite
MsgBox "耗时 " & Timer - timeStart & " 秒，将所有文件和文件夹合并为（你可能看不到扩展名）:" & vbCrLf & vbCrLf & " " & saveFilePath, 4160, "完成"
End Sub
'************************
'** 分离文件的主函数 **
'************************
Sub SplitMain()
' 循环变量，循环变量，下标上限值，文件，字符串，临时数组，开始时间计时器
Dim i, j, n, fs, sb, tempArr, timeStart
' 处理的文件，初始字节，文件夹信息二维数组，文件信息三维数组，释放路径
Dim filespec, startPos, foldersArr(), filesArr(), saveFolder
filespec = WScript.Arguments(0)
' 读取文件头包含的信息
Set fs = fso.OpenTextFile(filespec, 1)
sb = fs.ReadLine()
startPos = Replace(sb, CHING, "")
fs.SkipLine:fs.SkipLine:fs.SkipLine
sb = fs.ReadLine()
fs.Close
On Error Resume Next
' 提取文件夹信息
tempArr = Split(Split(sb, DELIM_FOLDERS_FILES)(0), DELIM_ITEMS)
n = UBound(tempArr)
ReDim foldersArr(n, 1)
For i = 0 To n
For j = 0 To 1
foldersArr(i, j) = Split(tempArr(i), DELIM_PROPERTIES)(j)
Next
Next
' 提取文件信息
tempArr = Split(Split(sb, DELIM_FOLDERS_FILES)(1), DELIM_ITEMS)
n = UBound(tempArr)
ReDim filesArr(n, 2)
For i = 0 To n
For j = 0 To 2
filesArr(i, j) = Split(tempArr(i), DELIM_PROPERTIES)(j)
Next
Next
If Err.Number <> 0 Then
MsgBox "这个文件不是我搞出来的，或者已损坏！", 4112, "错误"
WScript.Quit
End If
Err.Clear
On Error Goto 0
' 选择释放路径
saveFolder = selectOneFolder()
timeStart = Timer
' 创建所有文件夹
MakeFolders saveFolder, foldersArr
' 释放所有文件
MakeFiles filespec, startPos, saveFolder, filesArr
MsgBox "耗时 " & Timer - timeStart & " 秒，所有文件及文件夹已经成功释放！", 4160, "完成"
End Sub
'*****************************************************************************************************
'* 关于
'*------------
Sub AboutMe()
If MsgBox( "┏━━━━━━━━━━━━━━━━━━━━━━┓" & vbCrLf & _
"┃ 文件、文件夹合并与分离工具 ┃" & vbCrLf & _
"┃ ┃" & vbCrLf & _
"┃ (P)&(C) 2010 『据说是李先生』 ┃" & vbCrLf & _
"┃ ┃" & vbCrLf & _
"┃ qinchun36\cn-dos.net caofackri@gmail.com ┃" & vbCrLf & _
"┗━━━━━━━━━━━━━━━━━━━━━━┛" & vbCrLf & vbCrLf & _
" 用法:" & vbCrLf & _
" 1. 把一些东西拖到我上面" & vbCrLf & _
" 2. wscript.exe """ & WScript.ScriptName & """ %*" & vbCrLf & _
" 3. 选中一个或一堆东西，右键、发送到，选我" & vbCrLf & vbCrLf & _
" ※ 把我添加到右键---发送到菜单 ?" & vbCrLf, 4100, "关于") = 6 Then AddToSendTo
WScript.Quit
End Sub
'* 把我添加到右键---发送到菜单
'*----------------
Sub AddToSendTo()
With CreateObject("WScript.Shell").CreateShortcut( _
CreateObject("WScript.Shell").SpecialFolders("SendTo") & _
"" & SEND_TO_NAME & ".lnk")
.TargetPath = WScript.ScriptFullName
.IconLocation = SEND_TO_ICON
.Description = "Created by caofackri@gmail.com"
.Save
End With
End Sub
'* 将一个文件信息记录下来。
'* 相对文件名|属性数值|大小字节数
'*-----------------------
Sub SearchFile(filespec)
Dim f
Set f = fso.GetFile(filespec)
filesCount = filesCount + 1
files.Add f.Path, Mid(filespec, cutPos) & DELIM_PROPERTIES & f.Attributes & DELIM_PROPERTIES & f.Size
End Sub
'* 将一个文件夹及其子文件夹，以及所有子文件的信息记录下来
'* 相对文件名|属性数值
'*--------------------------
Sub SearchFolder(folderspec)
Dim fd, sbfd, f
Set fd = fso.GetFolder(folderspec)
foldersCount = foldersCount + 1
folders.Add fd.Path, Mid(folderspec, cutPos) & DELIM_PROPERTIES & fd.Attributes
For Each f In fd.Files
SearchFile f.Path
Next
For Each sbfd In fd.SubFolders
SearchFolder sbfd.Path
Next
End Sub
'* 将一串文本保存到纯文本文件
'* 草，为什么不直接用 f.Write text
'*--------------------------------
Sub SaveTextToFile(text, filespec)
Dim f, i, l, temp
i = 0
l = Len(text)
temp = text
fso.CreateTextFile filespec, True
Set f = fso.OpenTextFile(filespec, 2)
While i < l
f.Write Left(temp, 1024)
i = i + 1024
temp = Mid(temp, 1025)
WEnd
f.Write temp
f.Close
End Sub
'* 生成最终的文件头信息
'* 第一行共 HEAD_MAX_SIZE_LENGTH 个字节，包含的是这个文件头的总字节数（不足的在前面用 CHING 填充）
'* 第二、三行控制 scf 文件的图标信息，第四行是NULL，
'* 第五行是将要封装到此文件中的所有文件和文件夹信息
'*---------------
Sub CreateHead()
Dim firstLine, key, styleControl, l
firstLine = ""
styleControl = vbCrLf & "[Shell]" & vbCrLf & "IconFile=" & FILE_ICON & vbCrLf
styleControl = styleControl & Chr(1) & Chr(7) & Chr(0) & Chr(3) & Chr(6) & vbCrLf
For Each key In folders
fileHead = fileHead & folders.Item(key) & DELIM_ITEMS
Next
fileHead = fileHead & DELIM_PROPERTIES & DELIM_FOLDERS_FILES
For Each key In files
fileHead = fileHead & files.Item(key) & DELIM_ITEMS
Next
fileHead = fileHead & DELIM_PROPERTIES & DELIM_PROPERTIES & vbCrLf
SaveTextToFile fileHead, tempFile
l = fso.GetFile(tempFile).Size + Len(styleControl)
While l + Len(firstLine) + Len(l + Len(firstLine)) < l + HEAD_MAX_SIZE_LENGTH
firstLine = CHING & firstLine
WEnd
firstLine = firstLine & (l + Len(firstLine) + Len(l + Len(firstLine)))
fileHead = firstLine & styleControl & fileHead
SaveTextToFile fileHead, tempFile
End Sub
'* 向 wst 中追加一个文件的内容
'*----------------------
Sub AddOneFile(filespec)
rst.Type = 1
rst.Open
rst.LoadFromFile filespec
If rst.Size > 0 Then wst.Write rst.Read
rst.Close
End Sub
'* 将 files 中所有文件都以二进制合并到 filespec 中
'* 是否改写现有文件 isOverWrite（True=改写，false=保留）
'-----------------------------------
Sub JoinFiles(filespec, isOverWrite)
Dim isOW, temp
If isOverWrite Then
isOW = 2
Else
isOW = 1
End If
wst.Type = 1
wst.Open
' 我不知道文本怎么写入二进制流，因此只能保存为文件再操作，还请高人指点
AddOneFile tempFile
fso.DeleteFile tempFile, True
For Each temp In files
AddOneFile temp
Next
wst.SaveToFile filespec, isOW
wst.Close
End Sub
'* 浏览并选择一个文件夹
'*-------------------------
Function selectOneFolder()
Dim app, fd, fdi, temp
Set app = CreateObject("Shell.Application")
On Error Resume Next
Set fd = app.BrowseForFolder(0, "选择一个存储位置:", 0)
Set fdi = fd.Self
temp = fdi.Path
If temp="" Or Not fso.FolderExists(temp) Then
If MsgBox("无法将你的选择识别为文件夹路径, 使用当前文件夹并继续 ?", 4132, "警告") = 7 Then WScript.Quit
temp = Left(destDir, Len(destDir) - 1)
End If
selectOneFolder = temp
End Function
'* 输入一个文件名
'* 返回的文件名是绝对可以用的！
'*-------------------------
Function inputOneFile(saveFolder, isOverWrite)
Dim flag, temp, tempPath
flag = True
While flag
temp = InputBox("输入文件名(不要扩展名):","文件名")
If temp = "" Then
If MsgBox("你确定要取消本次操作吗 ?", 4132, "取消") = 6 Then WScript.Quit
Else
tempPath = saveFolder & "" & temp & ".scf"
If fso.FileExists(tempPath) Then
If MsgBox("已存在此文件，是否覆盖 ?", 4132, "提示") = 6 Then
isOverWrite = True
fso.DeleteFile tempPath
flag = False
End If
Else
On Error Resume Next
fso.CreateTextFile tempPath
If Err.Number <> 0 Then
MsgBox "不能创建这个文件，请重新输入！", 4112, "警告"
Else
fso.DeleteFile tempPath, True
flag = False
End If
Err.Clear
On Error Goto 0
End If
End If
WEnd
inputOneFile = tempPath
End Function
'* 将数组中记录的信息还原成文件夹
'*--------------------------
Sub MakeFolders(saveFolder, foldersArr)
Dim i, folderPath
For i=0 To UBound(foldersArr)
folderPath = saveFolder & "" & foldersArr(i, 0)
' 创建文件夹
If foldersArr(i, 0) <> "" And Not fso.FolderExists(folderPath) Then
fso.CreateFolder folderPath
End If
' 更改属性
If foldersArr(i, 1) <> "" Then
fso.GetFolder(folderPath).Attributes = foldersArr(i, 1)
End If
Next
End Sub
'* 将数组中记录的信息还原成文件
'*--------------------------
Sub MakeFiles(filespec, startPos, saveFolder, filesArr)
' 循环编号，临时变量
Dim i, filePath, currentStartPos, isOverWrite
' 以二进制方式载入要处理的文件
isOverWrite = 1
rst.Type = 1
rst.Open
rst.LoadFromFile filespec
' 初始化初始位置
currentStartPos = CLng(startPos)
For i = 0 To UBound(filesArr)
' 如果文件名不为空，这个是由于合并时的技术问题造成
If filesArr(i, 0) <> "" Then
' 重组目标文件名
filePath = saveFolder & "" & filesArr(i, 0)
' 确定是否改写已存在文件
If fso.FileExists(filePath) Then
If isOverWrite = 2 Then
' 之所以用 fso 删除，是因为 wst.SaveToFile xxx, 2 在某些特殊属性时会出错
fso.DeleteFile filePath
Else
If MsgBox("文件已存在, 我将总是覆盖他们并不再提示, 是否继续 ?", 4132, "询问") = 6 Then
isOverWrite = 2
Else
WScript.Quit
End If
End If
End If
rst.Position = currentStartPos
' 将开始位置移动到下一个要分离的文件的起始处
currentStartPos = currentStartPos + CLng(filesArr(i, 2))
' 读取二进制数据并保存到文件
wst.Type = 1
wst.Open
If filesArr(i, 2) > 0 Then wst.Write rst.Read(filesArr(i, 2))
wst.SaveToFile filePath, isOverWrite
wst.Close
' 更改文件属性
fso.GetFile(filePath).Attributes = CInt(filesArr(i, 1))
End If
Next
rst.Close
End Sub

复制代码

		自动登录	找回密码
密码			注册

[新手上路]批处理新手入门导读	[视频教程]批处理基础视频教程	[视频教程]VBS基础视频教程	[批处理精品]批处理版照片整理器
[批处理精品]纯批处理备份&还原驱动	[批处理精品]CMD命令50条不能说的秘密	[在线下载]第三方命令行工具	[在线帮助]VBScript / JScript 在线参考

文件、文件夹合并与拆分的VBS工具WinSCF

浏览过的版块