Board logo

标题: 文件、文件夹合并与拆分的VBS工具WinSCF [打印本页]

作者: HAT    时间: 2010-2-26 15:13     标题: 文件、文件夹合并与拆分的VBS工具WinSCF

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

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

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

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

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

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

第一次使用:


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


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


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

作者: HAT    时间: 2010-2-26 15:21

  1. Option Explicit
  2. ' 生成的文件的图标
  3. Const FILE_ICON = "shell32.dll,47"
  4. ' 我在 “右键---发送到” 菜单中的名字
  5. Const SEND_TO_NAME = "『据说是李先生』"
  6. ' 我在 “右键---发送到” 菜单中的图标
  7. Const SEND_TO_ICON = "shell32.dll,44"
  8. ' 文件头中用于分隔数据的符号
  9. '   为了保持其唯一性请使用包含非法文件名字符的字符串,
  10. '   且他们依次不能是被包含关系,如依次为 (*_*),|囧|,*^?^* 等。
  11. '     文件夹和文件数据的分隔
  12. Const DELIM_FOLDERS_FILES = "*"
  13. '     各条目的分隔
  14. Const DELIM_ITEMS = "|"
  15. '     各属性数据的分隔
  16. Const DELIM_PROPERTIES = "?"
  17. ' 文件头的长度不超过此位数数字代表的大小
  18. Const HEAD_MAX_SIZE_LENGTH = 8
  19. ' 废物,有且仅有一个(字节)
  20. Const CHING = "@"
  21. If WScript.Arguments.Count < 1 Then AboutMe
  22. '*****************************************************************************************************
  23. '全局变量:
  24. '    文件名截断位置,“当前文件夹(含最后的\)”,文件数,文件夹数,
  25. '    包装文件头,临时文件名,
  26. '    ADODB.Stream对象(用于写),ADODB.Stream对象(用于读),FileSystemObject对象,
  27. '    files   (key="路径",value="相对文件名|属性|大小(字节)")
  28. '    folders (key="路径",value="相对文件名|属性")
  29. Dim cutPos, destDir, filesCount, foldersCount, fileHead, tempFile, wst, rst, fso, files, folders
  30. cutPos = InStrRev(WScript.Arguments(0), "\") + 1
  31. destDir = Left(WScript.Arguments(0), cutPos - 1)
  32. filesCount = 0
  33. foldersCount = 0
  34. fileHead = ""
  35. Set wst = CreateObject("ADODB.Stream")
  36. Set rst = CreateObject("ADODB.Stream")
  37. Set fso = CreateObject("Scripting.FileSystemObject")
  38. Set files = CreateObject("Scripting.Dictionary")
  39. Set folders = CreateObject("Scripting.Dictionary")
  40. tempFile = fso.GetSpecialFolder(2).Path & "\~$ching$.tmp"
  41. Dim JoinOrSplit
  42. JoinOrSplit = True
  43. If WScript.Arguments.Count = 1 Then
  44. If LCase(Right(WScript.Arguments(0), 4)) = ".scf" Then
  45. JoinOrSplit = MsgBox("此文件可能是已经合并了的, 你是想把它释放出来吗 ?", 4131, "询问")
  46. If JoinOrSplit = 6 Then
  47. JoinOrSplit = False
  48. ElseIf JoinOrSplit = 2 Then
  49. WScript.Quit
  50. End If
  51. End If
  52. End If
  53. If JoinOrSplit Then
  54. JoinMain
  55. Else
  56. SplitMain
  57. End If
  58. '*****************************************************************************************************
  59. '************************
  60. '**  合并文件的主函数  **
  61. '************************
  62. Sub JoinMain()
  63. Dim saveFolder, saveFilePath, isOverWrite, timeStart
  64. isOverWrite = False
  65. saveFolder = selectOneFolder()
  66. saveFilePath = inputOneFile(saveFolder, isOverWrite)
  67. timeStart = Timer
  68. '把参数中所有指定的东西都浏览一遍,并将有用信息记录保存在 files 和 folders 对象中
  69. Dim pathspec
  70. For Each pathspec In WScript.Arguments
  71. If fso.FileExists(pathspec)   Then SearchFile   pathspec
  72. If fso.FolderExists(pathspec) Then SearchFolder pathspec
  73. Next
  74. ' 用 fso 创建纯文本的文件头
  75. CreateHead
  76. ' 合并所有文件
  77. JoinFiles saveFilePath, isOverWrite
  78. MsgBox "耗时 " & Timer - timeStart & " 秒,将所有文件和文件夹合并为(你可能看不到扩展名):" & vbCrLf & vbCrLf & " " & saveFilePath, 4160, "完成"
  79. End Sub
  80. '************************
  81. '**  分离文件的主函数  **
  82. '************************
  83. Sub SplitMain()
  84. ' 循环变量,循环变量,下标上限值,文件,字符串,临时数组,开始时间计时器
  85. Dim i, j, n, fs, sb, tempArr, timeStart
  86. ' 处理的文件,初始字节,文件夹信息二维数组,文件信息三维数组,释放路径
  87. Dim filespec, startPos, foldersArr(), filesArr(), saveFolder
  88. filespec = WScript.Arguments(0)
  89. ' 读取文件头包含的信息
  90. Set fs = fso.OpenTextFile(filespec, 1)
  91. sb = fs.ReadLine()
  92. startPos = Replace(sb, CHING, "")
  93. fs.SkipLine:fs.SkipLine:fs.SkipLine
  94. sb = fs.ReadLine()
  95. fs.Close
  96. On Error Resume Next
  97. ' 提取文件夹信息
  98. tempArr = Split(Split(sb, DELIM_FOLDERS_FILES)(0), DELIM_ITEMS)
  99. n = UBound(tempArr)
  100. ReDim foldersArr(n, 1)
  101. For i = 0 To n
  102. For j = 0 To 1
  103. foldersArr(i, j) = Split(tempArr(i), DELIM_PROPERTIES)(j)
  104. Next
  105. Next
  106. ' 提取文件信息
  107. tempArr = Split(Split(sb, DELIM_FOLDERS_FILES)(1), DELIM_ITEMS)
  108. n = UBound(tempArr)
  109. ReDim filesArr(n, 2)
  110. For i = 0 To n
  111. For j = 0 To 2
  112. filesArr(i, j) = Split(tempArr(i), DELIM_PROPERTIES)(j)
  113. Next
  114. Next
  115. If Err.Number <> 0 Then
  116. MsgBox "这个文件不是我搞出来的,或者已损坏!", 4112, "错误"
  117. WScript.Quit
  118. End If
  119. Err.Clear
  120. On Error Goto 0
  121. ' 选择释放路径
  122. saveFolder = selectOneFolder()
  123. timeStart = Timer
  124. ' 创建所有文件夹
  125. MakeFolders saveFolder, foldersArr
  126. ' 释放所有文件
  127. MakeFiles filespec, startPos, saveFolder, filesArr
  128. MsgBox "耗时 " & Timer - timeStart & " 秒,所有文件及文件夹已经成功释放!", 4160, "完成"
  129. End Sub
  130. '*****************************************************************************************************
  131. '* 关于
  132. '*------------
  133. Sub AboutMe()
  134. If MsgBox( "┏━━━━━━━━━━━━━━━━━━━━━━┓" & vbCrLf & _
  135.    "┃         文件、文件夹合并与分离工具         ┃" & vbCrLf & _
  136.    "┃                                            ┃" & vbCrLf & _
  137.    "┃       (P)&(C) 2010    『据说是李先生』     ┃" & vbCrLf & _
  138.    "┃                                            ┃" & vbCrLf & _
  139.    "┃ qinchun36\cn-dos.net   caofackri@gmail.com ┃" & vbCrLf & _
  140.    "┗━━━━━━━━━━━━━━━━━━━━━━┛" & vbCrLf & vbCrLf & _
  141.    "  用法:" & vbCrLf & _
  142.    "    1.  把一些东西拖到我上面" & vbCrLf & _
  143.    "    2.  wscript.exe """ & WScript.ScriptName & """ %*" & vbCrLf & _
  144.    "    3.  选中一个或一堆东西,右键、发送到,选我" & vbCrLf & vbCrLf & _
  145.    "  ※ 把我添加到 右键---发送到 菜单 ?" & vbCrLf, 4100, "关于") = 6 Then AddToSendTo
  146. WScript.Quit
  147. End Sub
  148. '* 把我添加到 右键---发送到 菜单
  149. '*----------------
  150. Sub AddToSendTo()
  151. With CreateObject("WScript.Shell").CreateShortcut( _
  152.      CreateObject("WScript.Shell").SpecialFolders("SendTo") & _
  153.      "\" & SEND_TO_NAME & ".lnk")
  154. .TargetPath   = WScript.ScriptFullName
  155. .IconLocation = SEND_TO_ICON
  156. .Description  = "Created by caofackri@gmail.com"
  157. .Save
  158. End With
  159. End Sub
  160. '* 将一个文件信息记录下来。
  161. '* 相对文件名|属性数值|大小字节数
  162. '*-----------------------
  163. Sub SearchFile(filespec)
  164. Dim f
  165. Set f = fso.GetFile(filespec)
  166. filesCount = filesCount + 1
  167. files.Add f.Path, Mid(filespec, cutPos) & DELIM_PROPERTIES & f.Attributes & DELIM_PROPERTIES & f.Size
  168. End Sub
  169. '* 将一个文件夹及其子文件夹,以及所有子文件的信息记录下来
  170. '* 相对文件名|属性数值
  171. '*--------------------------
  172. Sub SearchFolder(folderspec)
  173. Dim fd, sbfd, f
  174. Set fd = fso.GetFolder(folderspec)
  175. foldersCount = foldersCount + 1
  176. folders.Add fd.Path, Mid(folderspec, cutPos) & DELIM_PROPERTIES & fd.Attributes
  177. For Each f In fd.Files
  178. SearchFile f.Path
  179. Next
  180. For Each sbfd In fd.SubFolders
  181. SearchFolder sbfd.Path
  182. Next
  183. End Sub
  184. '* 将一串文本保存到纯文本文件
  185. '* 草,为什么不直接用 f.Write text
  186. '*--------------------------------
  187. Sub SaveTextToFile(text, filespec)
  188. Dim f, i, l, temp
  189. i = 0
  190. l = Len(text)
  191. temp = text
  192. fso.CreateTextFile filespec, True
  193. Set f = fso.OpenTextFile(filespec, 2)
  194. While i < l
  195. f.Write Left(temp, 1024)
  196. i = i + 1024
  197. temp = Mid(temp, 1025)
  198. WEnd
  199. f.Write temp
  200. f.Close
  201. End Sub
  202. '* 生成最终的文件头信息
  203. '* 第一行共 HEAD_MAX_SIZE_LENGTH 个字节,包含的是这个文件头的总字节数(不足的在前面用 CHING 填充)
  204. '* 第二、三行控制 scf 文件的图标信息,第四行是NULL,
  205. '* 第五行是将要封装到此文件中的所有文件和文件夹信息
  206. '*---------------
  207. Sub CreateHead()
  208. Dim firstLine, key, styleControl, l
  209. firstLine = ""
  210. styleControl = vbCrLf & "[Shell]" & vbCrLf & "IconFile=" & FILE_ICON & vbCrLf
  211. styleControl = styleControl & Chr(1) & Chr(7) & Chr(0) & Chr(3) & Chr(6) & vbCrLf
  212. For Each key In folders
  213. fileHead = fileHead & folders.Item(key) & DELIM_ITEMS
  214. Next
  215. fileHead = fileHead & DELIM_PROPERTIES & DELIM_FOLDERS_FILES
  216. For Each key In files
  217. fileHead = fileHead & files.Item(key) & DELIM_ITEMS
  218. Next
  219. fileHead = fileHead & DELIM_PROPERTIES & DELIM_PROPERTIES & vbCrLf
  220. SaveTextToFile fileHead, tempFile
  221. l = fso.GetFile(tempFile).Size + Len(styleControl)
  222. While l + Len(firstLine) + Len(l + Len(firstLine)) < l + HEAD_MAX_SIZE_LENGTH
  223. firstLine = CHING & firstLine
  224. WEnd
  225. firstLine = firstLine & (l + Len(firstLine) + Len(l + Len(firstLine)))
  226. fileHead = firstLine & styleControl & fileHead
  227. SaveTextToFile fileHead, tempFile
  228. End Sub
  229. '* 向 wst 中追加一个文件的内容
  230. '*----------------------
  231. Sub AddOneFile(filespec)
  232. rst.Type = 1
  233. rst.Open
  234. rst.LoadFromFile filespec
  235. If rst.Size > 0 Then wst.Write rst.Read
  236. rst.Close
  237. End Sub
  238. '* 将 files 中所有文件都以二进制合并到 filespec 中
  239. '* 是否改写现有文件 isOverWrite(True=改写,false=保留)
  240. '-----------------------------------
  241. Sub JoinFiles(filespec, isOverWrite)
  242. Dim isOW, temp
  243. If isOverWrite Then
  244. isOW = 2
  245. Else
  246. isOW = 1
  247. End If
  248. wst.Type = 1
  249. wst.Open
  250. ' 我不知道文本怎么写入二进制流,因此只能保存为文件再操作,还请高人指点
  251. AddOneFile tempFile
  252. fso.DeleteFile tempFile, True
  253. For Each temp In files
  254. AddOneFile temp
  255. Next
  256. wst.SaveToFile filespec, isOW
  257. wst.Close
  258. End Sub
  259. '* 浏览并选择一个文件夹
  260. '*-------------------------
  261. Function selectOneFolder()
  262. Dim app, fd, fdi, temp
  263. Set app = CreateObject("Shell.Application")
  264. On Error Resume Next
  265. Set fd = app.BrowseForFolder(0, "选择一个存储位置:", 0)
  266. Set fdi = fd.Self
  267. temp = fdi.Path
  268. If temp="" Or Not fso.FolderExists(temp) Then
  269. If MsgBox("无法将你的选择识别为文件夹路径, 使用当前文件夹并继续 ?", 4132, "警告") = 7 Then WScript.Quit
  270. temp = Left(destDir, Len(destDir) - 1)
  271. End If
  272. selectOneFolder = temp
  273. End Function
  274. '* 输入一个文件名
  275. '* 返回的文件名是绝对可以用的!
  276. '*-------------------------
  277. Function inputOneFile(saveFolder, isOverWrite)
  278. Dim flag, temp, tempPath
  279. flag = True
  280. While flag
  281. temp = InputBox("输入文件名(不要扩展名):","文件名")
  282. If temp = "" Then
  283. If MsgBox("你确定要取消本次操作吗 ?", 4132, "取消") = 6 Then WScript.Quit
  284. Else
  285. tempPath = saveFolder & "\" & temp & ".scf"
  286. If fso.FileExists(tempPath) Then
  287. If MsgBox("已存在此文件,是否覆盖 ?", 4132, "提示") = 6 Then
  288. isOverWrite = True
  289. fso.DeleteFile tempPath
  290. flag = False
  291. End If
  292. Else
  293. On Error Resume Next
  294. fso.CreateTextFile tempPath
  295. If Err.Number <> 0 Then
  296. MsgBox "不能创建这个文件,请重新输入!", 4112, "警告"
  297. Else
  298. fso.DeleteFile tempPath, True
  299. flag = False
  300. End If
  301. Err.Clear
  302. On Error Goto 0
  303. End If
  304. End If
  305. WEnd
  306. inputOneFile = tempPath
  307. End Function
  308. '* 将数组中记录的信息还原成文件夹
  309. '*--------------------------
  310. Sub MakeFolders(saveFolder, foldersArr)
  311. Dim i, folderPath
  312. For i=0 To UBound(foldersArr)
  313. folderPath = saveFolder & "\" & foldersArr(i, 0)
  314. ' 创建文件夹
  315. If foldersArr(i, 0) <> "" And Not fso.FolderExists(folderPath) Then
  316. fso.CreateFolder folderPath
  317. End If
  318. ' 更改属性
  319. If foldersArr(i, 1) <> "" Then
  320. fso.GetFolder(folderPath).Attributes = foldersArr(i, 1)
  321. End If
  322. Next
  323. End Sub
  324. '* 将数组中记录的信息还原成文件
  325. '*--------------------------
  326. Sub MakeFiles(filespec, startPos, saveFolder, filesArr)
  327. ' 循环编号,临时变量
  328. Dim i, filePath, currentStartPos, isOverWrite
  329. ' 以二进制方式载入要处理的文件
  330. isOverWrite = 1
  331. rst.Type = 1
  332. rst.Open
  333. rst.LoadFromFile filespec
  334. ' 初始化初始位置
  335. currentStartPos = CLng(startPos)
  336. For i = 0 To UBound(filesArr)
  337. ' 如果文件名不为空,这个是由于合并时的技术问题造成
  338. If filesArr(i, 0) <> "" Then
  339. ' 重组目标文件名
  340. filePath = saveFolder & "\" & filesArr(i, 0)
  341. ' 确定是否改写已存在文件
  342. If fso.FileExists(filePath) Then
  343. If isOverWrite = 2 Then
  344. ' 之所以用 fso 删除,是因为 wst.SaveToFile xxx, 2 在某些特殊属性时会出错
  345. fso.DeleteFile filePath
  346. Else
  347. If MsgBox("文件已存在, 我将总是覆盖他们并不再提示, 是否继续 ?", 4132, "询问") = 6 Then
  348. isOverWrite = 2
  349. Else
  350. WScript.Quit
  351. End If
  352. End If
  353. End If
  354. rst.Position = currentStartPos
  355. ' 将开始位置移动到下一个要分离的文件的起始处
  356. currentStartPos = currentStartPos + CLng(filesArr(i, 2))
  357. ' 读取二进制数据并保存到文件
  358. wst.Type = 1
  359. wst.Open
  360. If filesArr(i, 2) > 0 Then wst.Write rst.Read(filesArr(i, 2))
  361. wst.SaveToFile filePath, isOverWrite
  362. wst.Close
  363. ' 更改文件属性
  364. fso.GetFile(filePath).Attributes = CInt(filesArr(i, 1))
  365. End If
  366. Next
  367. rst.Close
  368. End Sub
复制代码





欢迎光临 批处理之家 (http://bbs.bathome.net/) Powered by Discuz! 7.2