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
复制代码