Current News Archived News Search News Discussion Forum Old Forum Install Programs More Downloads... Troubleshooting Source Code Format Specs. Misc. Information Non-SF Stuff Links Small banner for links to this site: |
1 Attribute VB_Name = "MpqStuff"
2 Option Explicit
4 Type SHELLEXECUTEINFO
5 cbSize As Long
6 fMask As Long
7 hWnd As Long
8 lpVerb As String
9 lpFile As String
10 lpParameters As String
11 lpDirectory As String
12 nShow As Long
13 hInstApp As Long
15 ' Optional members
16 lpIDList As Long
17 lpClass As String
18 hkeyClass As Long
19 dwHotKey As Long
20 hIcon As Long
21 hProcess As Long
22 End Type
24 Public Declare Function ShellExecute Lib _
25 "Shell32.dll" Alias "ShellExecuteA" _
26 (ByVal hWnd As Long, _
27 ByVal lpOperation As String, _
28 ByVal lpFile As String, _
29 ByVal lpParameters As String, _
30 ByVal lpDirectory As String, _
31 ByVal nShowCmd As Long) As Long
32 Public Declare Function ShellExecuteEx Lib _
33 "Shell32.dll" Alias "ShellExecuteExA" _
34 (sei As SHELLEXECUTEINFO) As Long
35 Public Declare Sub SHChangeNotify Lib _
36 "Shell32.dll" (ByVal wEventId As Long, _
37 ByVal uFlags As Integer, _
38 ByVal dwItem1 As Any, _
39 ByVal dwItem2 As Any)
40 Public Declare Function SendMessageA Lib _
41 "User32.dll" _
42 (ByVal hWnd As Long, _
43 ByVal Msg As Long, _
44 ByVal Wp As Long, _
45 Lp As Any) As Long
46 Declare Function GetLongPathName Lib "Kernel32" Alias "GetLongPathNameA" (ByVal lpszShortPath As String, ByVal lpszLongPath As String, ByVal cchBuffer As Long) As Long
47 Private Declare Sub CopyMemory Lib "Kernel32.dll" _
48 Alias "RtlMoveMemory" ( _
49 ByRef Destination As Any, _
50 ByRef Source As Any, _
51 ByVal Length As Long)
53 Public CD As OPENFILENAME, PathInput As BROWSEINFO
54 Public GlobalFileList() As String, FileList() As String, CX As Single, CY As Single, NewFile As Boolean, LocaleID As Long, ListFile As String, AddFolderName As String, ExtractPathNum As Long, CopyPathNum As Long, GlobalEncrypt As Boolean, DefaultCompress As Long, DefaultCompressID As Long, DefaultCompressLevel As Long, DefaultMaxFiles As Long, DefaultBlockSize As Long
55 Public Const AppKey As String = "HKEY_CURRENT_USER\Software\ShadowFlare\WinMPQ\", SharedAppKey As String = "HKEY_LOCAL_MACHINE\Software\ShadowFlare\WinMPQ\"
56 Public Const MPQ_ERROR_INIT_FAILED As Long = &H85000001 'Unspecified error
57 Public Const MPQ_ERROR_NO_STAREDIT As Long = &H85000002 'Can't find StarEdit.exe
58 Public Const MPQ_ERROR_BAD_STAREDIT As Long = &H85000003 'Bad version of StarEdit.exe. Need SC/BW 1.07
59 Public Const MPQ_ERROR_STAREDIT_RUNNING As Long = &H85000004 'StarEdit.exe is running. Must be closed
60 Public Const SHCNE_ASSOCCHANGED As Long = &H8000000
61 Public Const SHCNF_IDLIST As Long = &H0
62 Public Const WM_SETREDRAW As Long = &HB
63 Public Const WM_PAINT As Long = &HF
64 Const gintMAX_SIZE% = 255
65 Public Const SEE_MASK_CLASSNAME As Long = &H1
66 Sub AboutSFMpq()
67 Dim AboutPage As String, Path As String
68 Path = App.Path
69 If Right(Path, 1) <> "\" Then Path = Path + "\"
70 AboutPage = Path + "sfmpq.dll"
71 If Not FileExists(AboutPage) Then AboutPage = "sfmpq.dll"
72 ShellExecute 0, vbNullString, "res://" + AboutPage + "/about", vbNullString, vbNullString, 1
73 End Sub
74 Sub GetCompressFlags(File As String, ByRef cType As Integer, ByRef dwFlags As Long)
75 Dim bNum As Long, fExt As String
76 dwFlags = MAFA_REPLACE_EXISTING
77 If GlobalEncrypt Then dwFlags = dwFlags Or MAFA_ENCRYPT
78 For bNum = 1 To Len(File)
79 If InStr(bNum, File, ".") > 0 Then
80 bNum = InStr(bNum, File, ".")
81 Else
82 Exit For
83 End If
84 Next bNum
85 If bNum > 1 Then
86 fExt = Mid(File, bNum - 1)
87 Else
88 fExt = File
89 End If
90 If LCase(fExt) = ".bik" Then
91 cType = CInt(GetReg(AppKey + "Compression\.bik", "-2"))
92 dwFlags = dwFlags And (-1& Xor MAFA_ENCRYPT)
93 ElseIf LCase(fExt) = ".smk" Then
94 cType = CInt(GetReg(AppKey + "Compression\.smk", "-2"))
95 dwFlags = dwFlags And (-1& Xor MAFA_ENCRYPT)
96 ElseIf LCase(fExt) = ".mp3" Then
97 cType = CInt(GetReg(AppKey + "Compression\.mp3", "-2"))
98 dwFlags = dwFlags And (-1& Xor MAFA_ENCRYPT)
99 ElseIf LCase(fExt) = ".mpq" Then
100 cType = CInt(GetReg(AppKey + "Compression\.mpq", "-2"))
101 dwFlags = dwFlags And (-1& Xor MAFA_ENCRYPT)
102 ElseIf LCase(fExt) = ".scm" Then
103 cType = CInt(GetReg(AppKey + "Compression\.scm", "-2"))
104 dwFlags = dwFlags And (-1& Xor MAFA_ENCRYPT)
105 ElseIf LCase(fExt) = ".scx" Then
106 cType = CInt(GetReg(AppKey + "Compression\.scx", "-2"))
107 dwFlags = dwFlags And (-1& Xor MAFA_ENCRYPT)
108 ElseIf LCase(fExt) = ".w3m" Then
109 cType = CInt(GetReg(AppKey + "Compression\.w3m", "-2"))
110 dwFlags = dwFlags And (-1& Xor MAFA_ENCRYPT)
111 ElseIf LCase(fExt) = ".w3x" Then
112 cType = CInt(GetReg(AppKey + "Compression\.w3x", "-2"))
113 dwFlags = dwFlags And (-1& Xor MAFA_ENCRYPT)
114 ElseIf LCase(fExt) = ".wav" Then
115 cType = CInt(GetReg(AppKey + "Compression\.wav", "0"))
116 Else
117 cType = CInt(GetReg(AppKey + "Compression\" + fExt, CStr(DefaultCompressID)))
118 End If
119 End Sub
121 Function mOpenMpq(FileName As String) As Long
122 Dim hMPQ As Long
123 mOpenMpq = 0
124 hMPQ = MpqOpenArchiveForUpdateEx(FileName, MOAU_OPEN_EXISTING Or MOAU_MAINTAIN_LISTFILE, DefaultMaxFiles, DefaultBlockSize)
125 If hMPQ = 0 Or hMPQ = INVALID_HANDLE_VALUE Then
126 hMPQ = MpqOpenArchiveForUpdateEx(FileName, MOAU_CREATE_NEW Or MOAU_MAINTAIN_LISTFILE, DefaultMaxFiles, DefaultBlockSize)
127 End If
128 If hMPQ <> 0 And hMPQ <> INVALID_HANDLE_VALUE Then
129 mOpenMpq = hMPQ
130 End If
131 End Function
132 Function PathInputBox(lpFolderDialog As BROWSEINFO, pCaption As String, StartFolder As String) As String
133 lpFolderDialog.Title = pCaption
134 Dim result As Long
135 result = ShowFolder(lpFolderDialog)
136 If result = 0 Then Exit Function
137 PathInputBox = GetPathFromID(result)
138 End Function
139 Function GetLongPath(Path As String) As String
140 Dim strBuf As String, StrLength As Long
141 strBuf = Space$(gintMAX_SIZE)
142 StrLength = GetLongPathName(Path, strBuf, gintMAX_SIZE)
143 strBuf = Left(strBuf, StrLength)
144 If strBuf <> "" Then
145 GetLongPath = strBuf
146 Else
147 GetLongPath = Path
148 End If
149 End Function
150 Sub AddScriptOutput(sOutput As String)
151 SendMessageA ScriptOut.oText.hWnd, WM_SETREDRAW, 0, ByVal 0&
152 ScriptOut.oText = ScriptOut.oText + sOutput
153 SendMessageA ScriptOut.oText.hWnd, WM_SETREDRAW, 1, ByVal 0&
154 ScriptOut.oText.SelStart = Len(ScriptOut.oText)
155 End Sub
156 Function GetFileTitle(FileName As String) As String
157 Dim bNum As Long
158 If InStr(FileName, "\") > 0 Then
159 For bNum = 1 To Len(FileName)
160 If InStr(bNum, FileName, "\") > 0 Then
161 bNum = InStr(bNum, FileName, "\")
162 Else
163 Exit For
164 End If
165 Next bNum
166 GetFileTitle = Mid(FileName, bNum)
167 Else
168 GetFileTitle = FileName
169 End If
170 End Function
171 Function sGetFile(hMPQ As Long, ByVal FileName As String, OutPath As String, ByVal UseFullPath As Long)
172 Dim hFile As Long, buffer() As Byte, fLen As Long, cNum As Long
173 If SFileOpenFileEx(hMPQ, FileName, 0, hFile) Then
174 fLen = SFileGetFileSize(hFile, 0)
175 If fLen > 0 Then
176 ReDim buffer(fLen - 1)
177 Else
178 ReDim buffer(0)
179 End If
180 SFileReadFile hFile, buffer(0), fLen, ByVal 0, ByVal 0
181 SFileCloseFile hFile
182 If UseFullPath = 0 Then FileName = GetFileTitle(FileName)
183 FileName = FullPath(OutPath, FileName)
184 On Error Resume Next
185 For cNum = 1 To Len(FileName)
186 cNum = InStr(cNum, FileName, "\")
187 If cNum > 0 Then
188 MkDir Left(FileName, cNum)
189 Else
190 Exit For
191 End If
192 Next cNum
193 If FileExists(FileName) Then Kill FileName
194 On Error GoTo 0
195 cNum = FreeFile
196 On Error GoTo WriteError
197 Open FileName For Binary As #cNum
198 If fLen > 0 Then Put #cNum, 1, buffer
199 Close #cNum
200 On Error GoTo 0
201 End If
202 Exit Function
203 WriteError:
204 MsgBox "Error writing file. File may be in use.", vbCritical, "WinMPQ"
205 Close #cNum
206 End Function
207 Function sListFiles(MpqName As String, hMPQ As Long, ByVal FileLists As String, ByRef ListedFiles() As FILELISTENTRY) As Boolean
208 Dim NewFileLists As String, nFileLists() As String, ListName As String, cNum As Long, cNum2 As Long, cNum3 As Long, cNum4 As Long, MpqList1 As String, MpqList2 As String, Path As String, ListLen As Long, OldLists() As String, UseOnlyAutoList As Boolean, nHash As Long, nHashEntries As Long
209 sListFiles = False
210 ReDim ListedFiles(0)
211 ListedFiles(0).dwFileExists = 0
212 If GetReg(AppKey + "AutofindFileLists", 0) = 0 Then
213 NewFileLists = FileLists
214 Else
215 UseOnlyAutoList = GetReg(AppKey + "UseOnlyAutofindLists", 1)
216 MpqList2 = GetExtension(MpqName)
217 MpqList1 = GetFileTitle(Left(MpqName, Len(MpqName) - Len(MpqList2))) + ".txt"
218 MpqList2 = GetFileTitle(MpqName) + ".txt"
219 Path = GetLongPath(App.Path)
220 If Right(Path, 1) <> "\" Then Path = Path + "\"
221 If UseOnlyAutoList Then ListLen = Len(FileLists)
222 If FileLists <> "" Then
223 FileLists = FileLists + vbCrLf + Path + App.EXEName + ".exe" + vbCrLf + MpqName
224 Else
225 FileLists = Path + App.EXEName + ".exe" + vbCrLf + MpqName
226 End If
227 ReDim nFileLists(0) As String
228 If UseOnlyAutoList Then ReDim OldLists(0) As String
229 For cNum = 1 To Len(FileLists)
230 cNum2 = InStr(cNum, FileLists, vbCrLf)
231 If cNum2 = 0 Then
232 cNum2 = Len(FileLists) + 1
233 End If
234 If cNum2 - cNum > 0 Then
235 ListName = Mid(FileLists, cNum, cNum2 - cNum)
236 If Not IsDir(ListName) Then
237 If UseOnlyAutoList And cNum < ListLen Then
238 ReDim Preserve OldLists(UBound(OldLists) + 1) As String
239 OldLists(UBound(OldLists)) = GetLongPath(ListName)
240 End If
241 For cNum3 = 1 To Len(ListName)
242 If InStr(cNum3, ListName, "\") Then
243 cNum3 = InStr(cNum3, ListName, "\")
244 If FileExists(Left(ListName, cNum3) + MpqList1) Then
245 ReDim Preserve nFileLists(UBound(nFileLists) + 1) As String
246 nFileLists(UBound(nFileLists)) = GetLongPath(Left(ListName, cNum3) + MpqList1)
247 End If
248 If FileExists(Left(ListName, cNum3) + MpqList2) Then
249 ReDim Preserve nFileLists(UBound(nFileLists) + 1) As String
250 nFileLists(UBound(nFileLists)) = GetLongPath(Left(ListName, cNum3) + MpqList2)
251 End If
252 Else
253 Exit For
254 End If
255 Next cNum3
256 If FileExists(ListName) And ListName <> Path + App.EXEName + ".exe" And ListName <> MpqName Then
257 ReDim Preserve nFileLists(UBound(nFileLists) + 1) As String
258 nFileLists(UBound(nFileLists)) = GetLongPath(ListName)
259 End If
260 Else
261 ListName = DirEx(ListName, MpqList1, 6, True) _
262 + DirEx(ListName, MpqList2, 6, True)
263 For cNum3 = 1 To Len(ListName)
264 cNum4 = InStr(cNum3, ListName, vbCrLf)
265 If cNum4 = 0 Then
266 cNum4 = Len(ListName) + 1
267 End If
268 If cNum4 - cNum3 > 0 Then
269 ReDim Preserve nFileLists(UBound(nFileLists) + 1) As String
270 nFileLists(UBound(nFileLists)) = GetLongPath(Mid(ListName, cNum3, cNum4 - cNum3))
271 End If
272 cNum3 = cNum4 + 1
273 Next cNum3
274 End If
275 End If
276 cNum = cNum2 + 1
277 Next cNum
278 If UseOnlyAutoList Then
279 For cNum = 1 To UBound(nFileLists)
280 For cNum2 = 1 To UBound(OldLists)
281 If LCase(nFileLists(cNum)) <> LCase(OldLists(cNum2)) Then
282 GoTo StartSearch
283 End If
284 Next cNum2
285 Next cNum
286 UseOnlyAutoList = False
287 End If
288 StartSearch:
289 For cNum = 1 To UBound(nFileLists)
290 If nFileLists(cNum) <> "" Then
291 For cNum2 = 1 To UBound(nFileLists)
292 If LCase(nFileLists(cNum)) = LCase(nFileLists(cNum2)) And cNum <> cNum2 Then
293 nFileLists(cNum2) = ""
294 End If
295 Next cNum2
296 End If
297 If UseOnlyAutoList Then
298 If nFileLists(cNum) <> "" Then
299 For cNum2 = 1 To UBound(OldLists)
300 If LCase(nFileLists(cNum)) = LCase(OldLists(cNum2)) And LCase(GetFileTitle(nFileLists(cNum))) <> LCase(MpqList1) And LCase(GetFileTitle(nFileLists(cNum))) <> LCase(MpqList2) Then
301 nFileLists(cNum) = ""
302 Exit For
303 End If
304 Next cNum2
305 End If
306 End If
307 If nFileLists(cNum) <> "" Then
308 NewFileLists = NewFileLists + nFileLists(cNum) + vbCrLf
309 End If
310 Next cNum
311 If Right(NewFileLists, 2) = vbCrLf Then NewFileLists = Left(NewFileLists, Len(NewFileLists) - 2)
312 End If
313 nHashEntries = SFileGetFileInfo(hMPQ, SFILE_INFO_HASH_TABLE_SIZE)
314 If nHashEntries - 1 < 0 Then Exit Function
315 ReDim ListedFiles(nHashEntries - 1)
316 sListFiles = SFileListFiles(hMPQ, NewFileLists, ListedFiles(0), 0)
317 End Function
318 Sub mAddAutoFile(hMPQ As Long, File As String, MpqPath As String)
319 Dim cType As Integer, dwFlags As Long
321 GetCompressFlags File, cType, dwFlags
323 Select Case cType
324 Case -2
325 MpqAddFileToArchiveEx hMPQ, File, MpqPath, dwFlags, 0, 0
326 Case -1
327 MpqAddFileToArchiveEx hMPQ, File, MpqPath, dwFlags Or MAFA_COMPRESS, MAFA_COMPRESS_STANDARD, 0
328 Case -3
329 MpqAddFileToArchiveEx hMPQ, File, MpqPath, dwFlags Or MAFA_COMPRESS, MAFA_COMPRESS_DEFLATE, DefaultCompressLevel
330 Case -4
331 MpqAddFileToArchiveEx hMPQ, File, MpqPath, dwFlags Or MAFA_COMPRESS, MAFA_COMPRESS_BZIP2, 0
332 Case 0, 1, 2
333 MpqAddWaveToArchive hMPQ, File, MpqPath, dwFlags Or MAFA_COMPRESS, cType
334 Case Else
335 If DefaultCompress = MAFA_COMPRESS_DEFLATE Then
336 MpqAddFileToArchiveEx hMPQ, File, MpqPath, dwFlags Or MAFA_COMPRESS, DefaultCompress, DefaultCompressLevel
337 Else
338 MpqAddFileToArchiveEx hMPQ, File, MpqPath, dwFlags Or MAFA_COMPRESS, DefaultCompress, 0
339 End If
340 End Select
341 End Sub
342 Sub mAddAutoFromBuffer(hMPQ As Long, ByRef buffer As Byte, BufSize As Long, MpqPath As String)
343 Dim cType As Integer, dwFlags As Long
345 GetCompressFlags MpqPath, cType, dwFlags
347 Select Case cType
348 Case -2
349 MpqAddFileFromBufferEx hMPQ, buffer, BufSize, MpqPath, dwFlags, 0, 0
350 Case -1
351 MpqAddFileFromBufferEx hMPQ, buffer, BufSize, MpqPath, dwFlags Or MAFA_COMPRESS, MAFA_COMPRESS_STANDARD, 0
352 Case -3
353 MpqAddFileFromBufferEx hMPQ, buffer, BufSize, MpqPath, dwFlags Or MAFA_COMPRESS, MAFA_COMPRESS_DEFLATE, DefaultCompressLevel
354 Case -4
355 MpqAddFileFromBufferEx hMPQ, buffer, BufSize, MpqPath, dwFlags Or MAFA_COMPRESS, MAFA_COMPRESS_BZIP2, 0
356 Case 0, 1, 2
357 MpqAddWaveFromBuffer hMPQ, buffer, BufSize, MpqPath, dwFlags Or MAFA_COMPRESS, cType
358 Case Else
359 If DefaultCompress = MAFA_COMPRESS_DEFLATE Then
360 MpqAddFileFromBufferEx hMPQ, buffer, BufSize, MpqPath, dwFlags Or MAFA_COMPRESS, DefaultCompress, DefaultCompressLevel
361 Else
362 MpqAddFileFromBufferEx hMPQ, buffer, BufSize, MpqPath, dwFlags Or MAFA_COMPRESS, DefaultCompress, 0
363 End If
364 End Select
365 End Sub
367 Function DirEx(ByVal Path As String, Filter As String, Attributes, Recurse As Boolean) As String
368 Dim Files() As String, lNum As Long, Folders() As String
369 If Right(Path, 1) <> "\" And Path <> "" Then Path = Path + "\"
370 ReDim Files(0) As String
371 Files(0) = Dir(Path + Filter, Attributes)
372 If Files(0) <> "" Then
373 Do
374 ReDim Preserve Files(UBound(Files) + 1) As String
375 Files(UBound(Files)) = Dir
376 Loop Until Files(UBound(Files)) = ""
377 ReDim Preserve Files(UBound(Files) - 1) As String
378 End If
379 For lNum = 0 To UBound(Files)
380 If Files(lNum) <> "" Then
381 If IsDir(Path + Files(lNum)) = False And (Attributes And vbDirectory) <> vbDirectory Then
382 DirEx = DirEx + Path + Files(lNum) + vbCrLf
383 ElseIf IsDir(Path + Files(lNum)) = True And (Attributes And vbDirectory) Then
384 DirEx = DirEx + Path + Files(lNum) + vbCrLf
385 End If
386 End If
387 Next lNum
388 If Recurse = True And (InStr(Filter, "?") > 0 Or InStr(Filter, "*") > 0) Then
389 ReDim Folders(0) As String
390 Folders(0) = Dir(Path, vbDirectory)
391 If Folders(0) = "." Or Folders(0) = ".." Then Folders(0) = Dir
392 If Folders(0) = "." Or Folders(0) = ".." Then Folders(0) = Dir
393 If Folders(0) <> "" Then
394 Do
395 ReDim Preserve Folders(UBound(Folders) + 1) As String
396 Folders(UBound(Folders)) = Dir
397 If Folders(UBound(Folders)) = "." Or Folders(UBound(Folders)) = ".." Then
398 ReDim Preserve Folders(UBound(Folders) - 1) As String
399 End If
400 Loop Until Folders(UBound(Folders)) = ""
401 ReDim Preserve Folders(UBound(Folders) - 1) As String
402 End If
403 For lNum = 0 To UBound(Folders)
404 If Folders(lNum) <> "" Then
405 If IsDir(Path + Folders(lNum)) Then
406 DirEx = DirEx + DirEx(Path + Folders(lNum), Filter, Attributes, Recurse)
407 End If
408 End If
409 Next lNum
410 End If
411 End Function
412 Function GetExtension(FileName As String) As String
413 Dim bNum As Long
414 If InStr(FileName, ".") > 0 Then
415 For bNum = 1 To Len(FileName)
416 If InStr(bNum, FileName, ".") > 0 Then
417 bNum = InStr(bNum, FileName, ".")
418 Else
419 Exit For
420 End If
421 Next bNum
422 GetExtension = Mid(FileName, bNum - 1)
423 Else
424 GetExtension = ""
425 End If
426 End Function
427 Function IsDir(DirPath As String) As Boolean
428 On Error GoTo IsNotDir
429 If GetAttr(DirPath) And vbDirectory Then
430 IsDir = True
431 Else
432 IsDir = False
433 End If
434 Exit Function
435 IsNotDir:
436 IsDir = False
437 End Function
438 Function FileExists(FileName As String) As Boolean
439 On Error GoTo NoFile
440 If (GetAttr(FileName) And vbDirectory) <> vbDirectory Then
441 FileExists = True
442 Else
443 FileExists = False
444 End If
445 Exit Function
446 NoFile:
447 FileExists = False
448 End Function
449 Function IsMPQ(MpqFile As String) As Boolean
450 If FindMpqHeader(MpqFile) <> -1 Then
451 IsMPQ = True
452 Else
453 IsMPQ = False
454 End If
455 End Function
456 Sub KillEx(ByVal Path As String, Filter As String, Attributes, Recurse As Boolean)
457 Dim Files() As String, lNum As Long, Folders() As String
458 If Right(Path, 1) <> "\" And Path <> "" Then Path = Path + "\"
459 ReDim Files(0) As String
460 Files(0) = Dir(Path + Filter, Attributes)
461 If Files(0) <> "" Then
462 Do
463 ReDim Preserve Files(UBound(Files) + 1) As String
464 Files(UBound(Files)) = Dir
465 Loop Until Files(UBound(Files)) = ""
466 ReDim Preserve Files(UBound(Files) - 1) As String
467 End If
468 For lNum = 0 To UBound(Files)
469 If Files(lNum) <> "" Then
470 If IsDir(Path + Files(lNum)) = False Then
471 On Error Resume Next
472 Kill Path + Files(lNum)
473 On Error GoTo 0
474 End If
475 End If
476 Next lNum
477 If Recurse = True And (InStr(Filter, "?") > 0 Or InStr(Filter, "*") > 0) Then
478 ReDim Folders(0) As String
479 Folders(0) = Dir(Path, vbDirectory)
480 If Folders(0) = "." Or Folders(0) = ".." Then Folders(0) = Dir
481 If Folders(0) = "." Or Folders(0) = ".." Then Folders(0) = Dir
482 If Folders(0) <> "" Then
483 Do
484 ReDim Preserve Folders(UBound(Folders) + 1) As String
485 Folders(UBound(Folders)) = Dir
486 If Folders(UBound(Folders)) = "." Or Folders(UBound(Folders)) = ".." Then
487 ReDim Preserve Folders(UBound(Folders) - 1) As String
488 End If
489 Loop Until Folders(UBound(Folders)) = ""
490 ReDim Preserve Folders(UBound(Folders) - 1) As String
491 End If
492 For lNum = 0 To UBound(Folders)
493 If Folders(lNum) <> "" Then
494 If IsDir(Path + Folders(lNum)) Then
495 KillEx Path + Folders(lNum), Filter, Attributes, Recurse
496 On Error Resume Next
497 RmDir Path + Folders(lNum)
498 End If
499 On Error GoTo 0
500 End If
501 Next lNum
502 End If
503 End Sub
504 Function FullPath(ByVal BasePath As String, File As String) As String
505 If Right(BasePath, 1) <> "\" Then BasePath = BasePath + "\"
506 If Mid(File, 2, 1) = ":" Or Left(File, 2) = "\\" Then
507 FullPath = File
508 ElseIf Left(File, 1) = "\" Then
509 FullPath = Left(BasePath, 2) + File
510 Else
511 FullPath = BasePath + File
512 End If
513 End Function
514 Function MatchesFilter(FileName As String, ByVal Filters As String) As Boolean
515 Dim bNum As Long, Filter As String
516 If InStr(Filters, ";") Then
517 If Right(Filters, 1) <> ";" Then Filters = Filters + ";"
518 For bNum = 1 To Len(Filters)
519 Filter = Mid(Filters, bNum, InStr(bNum, Filters, ";") - bNum)
520 If Right(Filter, 3) = "*.*" Then Filter = Left(Filter, Len(Filter) - 2)
521 If LCase(FileName) Like LCase(Filter) Then
522 MatchesFilter = True
523 Exit Function
524 End If
525 bNum = InStr(bNum, Filters, ";")
526 Next bNum
527 Else
528 If Right(Filters, 3) = "*.*" Then Filters = Left(Filters, Len(Filters) - 2)
529 If LCase(FileName) Like LCase(Filters) Then MatchesFilter = True
530 End If
531 End Function
532 Function RenameWithFilter(FileName As String, OldFilter As String, NewFilter As String) As String
533 Dim bNum As Long, Filters() As String, NewFileName As String, bNum2 As Long, bNum3 As Long, bNum4 As Long, bNum5 As Long
534 If Right(OldFilter, 3) = "*.*" Then OldFilter = Left(OldFilter, Len(OldFilter) - 2)
535 If Right(NewFilter, 3) = "*.*" Then NewFilter = Left(NewFilter, Len(NewFilter) - 2)
536 ReDim Filters(0) As String
537 bNum4 = 1
538 For bNum = 1 To Len(OldFilter)
539 Select Case Mid(OldFilter, bNum, 1)
540 Case "*"
541 bNum2 = InStr(bNum + 1, OldFilter, "*")
542 bNum3 = InStr(bNum + 1, OldFilter, "?")
543 If bNum2 = 0 And bNum3 = 0 Then
544 bNum2 = Len(OldFilter) + 1
545 ElseIf (bNum3 < bNum2 Or bNum2 = 0) And bNum3 > 0 Then
546 bNum2 = bNum3
547 End If
548 bNum5 = InStr(bNum4, FileName, Mid(OldFilter, bNum + 1, bNum2 - bNum - 1), 1)
549 If bNum = Len(OldFilter) Then
550 bNum5 = Len(FileName) + 1
551 End If
552 If bNum5 = 0 Then
553 RenameWithFilter = FileName
554 Exit Function
555 End If
556 If bNum > 1 Then
557 If Mid(OldFilter, bNum - 1, 1) <> "*" And Mid(OldFilter, bNum - 1, 1) <> "?" Then
558 ReDim Preserve Filters(UBound(Filters) + 1) As String
559 End If
560 Else
561 ReDim Preserve Filters(UBound(Filters) + 1) As String
562 End If
563 Filters(UBound(Filters)) = Filters(UBound(Filters)) + Mid(FileName, bNum4, bNum5 - bNum4)
564 bNum4 = bNum5
565 Case "?"
566 bNum2 = bNum + 1
567 bNum5 = bNum4 + 1
568 If bNum > 1 Then
569 If Mid(OldFilter, bNum - 1, 1) <> "*" And Mid(OldFilter, bNum - 1, 1) <> "?" Then
570 ReDim Preserve Filters(UBound(Filters) + 1) As String
571 End If
572 Else
573 ReDim Preserve Filters(UBound(Filters) + 1) As String
574 End If
575 Filters(UBound(Filters)) = Filters(UBound(Filters)) + Mid(FileName, bNum4, 1)
576 bNum4 = bNum5
577 Case Else
578 bNum4 = bNum4 + 1
579 End Select
580 If bNum4 > Len(FileName) Then
581 If (Right(OldFilter, 1) <> "*" Or bNum + 1 < Len(OldFilter)) And bNum < Len(OldFilter) Then
582 RenameWithFilter = FileName
583 Exit Function
584 Else
585 Exit For
586 End If
587 End If
588 Next bNum
589 NewFileName = NewFilter
590 For bNum = 1 To UBound(Filters)
591 bNum2 = InStr(bNum, NewFileName, "*")
592 bNum3 = InStr(bNum, NewFileName, "?")
593 If bNum2 = 0 And bNum3 = 0 Then
594 bNum2 = Len(NewFileName) + 1
595 ElseIf (bNum3 < bNum2 Or bNum2 = 0) And bNum3 > 0 Then
596 bNum2 = bNum3
597 End If
598 If bNum2 > Len(NewFileName) Then
599 RenameWithFilter = NewFileName
600 Exit Function
601 End If
602 bNum4 = 0
603 For bNum3 = bNum2 To Len(NewFileName)
604 Select Case Mid(NewFileName, bNum3, 1)
605 Case "*"
606 bNum4 = Len(Filters(bNum))
607 bNum3 = bNum3 + 1
608 Exit For
609 Case "?"
610 bNum4 = bNum4 + 1
611 Case Else
612 Exit For
613 End Select
614 Next bNum3
615 NewFileName = Left(NewFileName, bNum2 - 1) + Left(Filters(bNum), bNum4) + Mid(NewFileName, bNum3)
616 Next bNum
617 Do Until InStr(NewFileName, "*") = 0
618 NewFileName = Left(NewFileName, InStr(NewFileName, "*") - 1) + Mid(NewFileName, InStr(NewFileName, "*") + 1)
619 Loop
620 Do Until InStr(NewFileName, "?") = 0
621 NewFileName = Left(NewFileName, InStr(NewFileName, "?") - 1) + Mid(NewFileName, InStr(NewFileName, "?") + 1)
622 Loop
623 RenameWithFilter = NewFileName
624 End Function
625 Function MpqDir(MpqFile As String, Filters As String)
626 Dim Files() As FILELISTENTRY, fNum As Long, szFileList As String, NamePos As Long, CurFileName As String
627 Dim hMPQ As Long
628 If SFileOpenArchive(MpqFile, 0, 0, hMPQ) Then
629 If sListFiles(MpqFile, hMPQ, ListFile, Files) Then
630 SFileCloseArchive hMPQ
631 For fNum = 0 To UBound(Files)
632 If Files(fNum).dwFileExists Then
633 CurFileName = StrConv(Files(fNum).szFileName, vbUnicode)
634 If MatchesFilter(CurFileName, Filters) Then
635 NamePos = InStr(1, szFileList, CurFileName + vbCrLf, 1)
636 If NamePos > 1 Then
637 NamePos = InStr(1, szFileList, vbCrLf + CurFileName + vbCrLf, 1)
638 End If
639 If NamePos > 0 Then _
640 szFileList = szFileList + CurFileName
641 End If
642 End If
643 Next fNum
644 MpqDir = MpqDir + CurFileName + vbCrLf
645 Else
646 SFileCloseArchive hMPQ
647 End If
648 End If
649 End Function
650 Sub RunScript(ScriptName As String)
651 Dim fNum As Long, Script As String, sLine As String, Param() As String, bNum As Long, EndLine As Long, pNum As Long, EndParam As Long, MpqFile As String, OldDefaultMaxFiles As Long, cType As Integer, lNum As Long, OldPath As String, NewPath As String, Rswitch As Boolean, Files As String, fCount As Long, fEndLine As Long, fLine As String, ScriptNewFile As Boolean, CurPath As String, fLine2 As String, fLineTitle As String, hMPQ As Long, hFile As Long, dwFlags
652 If FileExists(ScriptName) = False Then
653 ScriptOut.Show
654 AddScriptOutput "Could not find script " + ScriptName + vbCrLf
655 Exit Sub
656 End If
657 fNum = FreeFile
658 Open ScriptName For Binary As #fNum
659 Script = String(LOF(fNum), Chr(0))
660 Get #fNum, 1, Script
661 Close #fNum
662 OldPath = CurDir
663 If InStr(ScriptName, "\") > 0 Then
664 For bNum = 1 To Len(ScriptName)
665 If InStr(bNum, ScriptName, "\") > 0 Then
666 bNum = InStr(bNum, ScriptName, "\")
667 NewPath = Left(ScriptName, bNum)
668 End If
669 Next bNum
670 If Mid(NewPath, 2, 1) = ":" Then ChDrive Left(NewPath, 1)
671 ChDir NewPath
672 End If
673 CurPath = CurDir
674 If Right(Script, 2) <> vbCrLf Then Script = Script + vbCrLf
675 ScriptOut.Show
676 AddScriptOutput "Script: " + ScriptName + vbCrLf + vbCrLf
677 OldDefaultMaxFiles = DefaultMaxFiles
678 lNum = 1
679 For bNum = 1 To Len(Script)
680 EndLine = InStr(bNum, Script, vbCrLf)
681 sLine = Mid(Script, bNum, EndLine - bNum)
682 If Right(sLine, 1) <> " " Then sLine = sLine + " "
683 If sLine <> "" Then
684 AddScriptOutput "Line " + CStr(lNum) + ": "
685 ReDim Param(0) As String
686 For pNum = 1 To Len(sLine)
687 If Mid(sLine, pNum, 1) = Chr(34) Then
688 pNum = pNum + 1
689 EndParam = InStr(pNum, sLine, Chr(34))
690 Else
691 EndParam = InStr(pNum, sLine, " ")
692 End If
693 If EndParam = 0 Then EndParam = Len(sLine) + 1
694 If pNum <> EndParam Then
695 If Trim(Mid(sLine, pNum, EndParam - pNum)) <> "" Then
696 ReDim Preserve Param(UBound(Param) + 1) As String
697 Param(UBound(Param)) = Trim(Mid(sLine, pNum, EndParam - pNum))
698 End If
699 End If
700 pNum = EndParam
701 Next pNum
702 If UBound(Param) < 3 Then ReDim Preserve Param(3) As String
703 Select Case LCase(Param(1))
704 Case "o", "open"
705 If Param(2) <> "" Then
706 MpqFile = Param(2)
707 If Param(3) <> "" And FileExists(MpqFile) = False Then
708 DefaultMaxFiles = Param(3)
709 End If
710 If FileExists(MpqFile) Then
711 AddScriptOutput "Opened " + MpqFile + vbCrLf
712 Else
713 AddScriptOutput "Created new " + MpqFile + vbCrLf
714 End If
715 NewPath = CurPath
716 Else
717 AddScriptOutput "Required parameter missing" + vbCrLf
718 End If
719 Case "n", "new"
720 If Param(2) <> "" Then
721 MpqFile = Param(2)
722 If Param(3) <> "" Then
723 DefaultMaxFiles = Param(3)
724 End If
725 ScriptNewFile = True
726 AddScriptOutput "Created new " + MpqFile + vbCrLf
727 NewPath = CurPath
728 Else
729 AddScriptOutput "Required parameter missing" + vbCrLf
730 End If
731 Case "c", "close"
732 If MpqFile <> "" Then
733 If LCase(CD.FileName) = LCase(FullPath(NewPath, MpqFile)) Then MpqEx.Timer1.Enabled = True
734 AddScriptOutput "Closed " + MpqFile + vbCrLf
735 MpqFile = ""
736 Else
737 AddScriptOutput "No archive open" + vbCrLf
738 End If
739 Case "p", "pause"
740 AddScriptOutput "Pause not supported" + vbCrLf
741 Case "a", "add"
742 If MpqFile <> "" Then
743 cType = 0
744 Rswitch = False
745 fCount = 0
746 Files = ""
747 fEndLine = 0
748 fLine = ""
749 dwFlags = MAFA_REPLACE_EXISTING
750 If GlobalEncrypt Then dwFlags = dwFlags Or MAFA_ENCRYPT
751 For pNum = 3 To UBound(Param)
752 If LCase(Param(pNum)) = "/wav" Then
753 cType = 2
754 dwFlags = dwFlags Or MAFA_COMPRESS
755 ElseIf LCase(Param(pNum)) = "/c" And cType < 2 Then
756 cType = 1
757 dwFlags = dwFlags Or MAFA_COMPRESS
758 ElseIf LCase(Param(pNum)) = "/auto" And cType < 1 Then
759 cType = -1
760 ElseIf LCase(Param(pNum)) = "/r" Then
761 Rswitch = True
762 End If
763 Next pNum
764 If Left(Param(3), 1) = "/" Or Param(3) = "" Then
765 If InStr(Param(2), "*") <> 0 Or InStr(Param(2), "?") <> 0 Then
766 Param(3) = ""
767 Else
768 Param(3) = Param(2)
769 End If
770 End If
771 If Left(Param(2), 1) <> "/" And Param(2) <> "" Then
772 If InStr(Param(2), "\") > 0 Then
773 For pNum = 1 To Len(Param(2))
774 If InStr(pNum, Param(2), "\") > 0 Then
775 pNum = InStr(pNum, Param(2), "\")
776 Files = Left(Param(2), pNum)
777 End If
778 Next pNum
779 End If
780 If ScriptNewFile = True Then
781 If FileExists(FullPath(NewPath, MpqFile)) Then Kill FullPath(NewPath, MpqFile)
782 ScriptNewFile = False
783 End If
784 Files = DirEx(Files, Mid(Param(2), Len(Files) + 1), 6, Rswitch)
785 hMPQ = mOpenMpq(FullPath(NewPath, MpqFile))
786 If hMPQ = 0 Then
787 AddScriptOutput "Can't create archive " + MpqFile + vbCrLf
788 GoTo CommandError
789 End If
790 For pNum = 1 To Len(Files)
791 fEndLine = InStr(pNum, Files, vbCrLf)
792 fLine = Mid(Files, pNum, fEndLine - pNum)
793 If pNum > 1 Then
794 AddScriptOutput "Line " + CStr(lNum) + ": "
795 End If
796 If cType = 0 Then
797 AddScriptOutput "Adding " + fLine + "..."
798 ElseIf cType = 1 Then
799 AddScriptOutput "Adding compressed " + fLine + "..."
800 ElseIf cType = 2 Then
801 AddScriptOutput "Adding compressed WAV " + fLine + "..."
802 ElseIf cType = -1 Then
803 AddScriptOutput "Adding " + fLine + " (compression auto-select)..."
804 End If
805 If InStr(Param(2), "*") <> 0 Or InStr(Param(2), "?") <> 0 Then
806 If Right(Param(3), 1) <> "\" And Param(3) <> "" Then Param(3) = Param(3) + "\"
807 If cType = 2 Then
808 MpqAddWaveToArchive hMPQ, FullPath(CurPath, fLine), Param(3) + fLine, dwFlags, 0
809 ElseIf cType = -1 Then
810 mAddAutoFile hMPQ, FullPath(CurPath, fLine), Param(3) + fLine
811 ElseIf cType = 1 Then
812 If DefaultCompress = MAFA_COMPRESS_DEFLATE Then
813 MpqAddFileToArchiveEx hMPQ, FullPath(CurPath, fLine), Param(3) + fLine, dwFlags, DefaultCompress, DefaultCompressLevel
814 Else
815 MpqAddFileToArchiveEx hMPQ, FullPath(CurPath, fLine), Param(3) + fLine, dwFlags, DefaultCompress, 0
816 End If
817 Else
818 MpqAddFileToArchiveEx hMPQ, FullPath(CurPath, fLine), Param(3) + fLine, dwFlags, 0, 0
819 End If
820 Else
821 If cType = 2 Then
822 MpqAddWaveToArchive hMPQ, FullPath(CurPath, fLine), Param(3), dwFlags, 0
823 ElseIf cType = -1 Then
824 mAddAutoFile hMPQ, FullPath(CurPath, fLine), Param(3)
825 ElseIf cType = 1 Then
826 If DefaultCompress = MAFA_COMPRESS_DEFLATE Then
827 MpqAddFileToArchiveEx hMPQ, FullPath(CurPath, fLine), Param(3), dwFlags, DefaultCompress, DefaultCompressLevel
828 Else
829 MpqAddFileToArchiveEx hMPQ, FullPath(CurPath, fLine), Param(3), dwFlags, DefaultCompress, 0
830 End If
831 Else
832 MpqAddFileToArchiveEx hMPQ, FullPath(CurPath, fLine), Param(3), dwFlags, 0, 0
833 End If
834 End If
835 AddScriptOutput " Done" + vbCrLf
836 SendMessageA ScriptOut.oText.hWnd, WM_PAINT, 0, &O0
837 fCount = fCount + 1
838 pNum = fEndLine + 1
839 Next pNum
840 MpqCloseUpdatedArchive hMPQ, 0
841 If fCount > 1 Then
842 AddScriptOutput "Line " + CStr(lNum) + ": " + CStr(fCount) + " files of " + Param(2) + " added" + vbCrLf
843 End If
844 Else
845 AddScriptOutput " Required parameter missing" + vbCrLf
846 End If
847 Else
848 AddScriptOutput "No archive open" + vbCrLf
849 End If
850 Case "e", "extract"
851 If MpqFile <> "" Then
852 If InStr(Param(2), "*") = 0 And InStr(Param(2), "?") = 0 Then AddScriptOutput "Extracting " + Param(2) + "..."
853 cType = 0
854 For pNum = 3 To UBound(Param)
855 If LCase(Param(pNum)) = "/fp" Then
856 cType = 1
857 Exit For
858 End If
859 Next pNum
860 If Left(Param(3), 1) = "/" Then Param(3) = ""
861 If Param(3) = "" Then Param(3) = "."
862 If Left(Param(2), 1) <> "/" And Param(2) <> "" Then
863 If InStr(Param(2), "*") <> 0 Or InStr(Param(2), "?") <> 0 Then
864 Files = MpqDir(FullPath(NewPath, MpqFile), Param(2))
865 If SFileOpenArchive(FullPath(NewPath, MpqFile), 0, 0, hMPQ) = 0 Then
866 AddScriptOutput "Can't open archive " + FullPath(NewPath, MpqFile) + vbCrLf
867 GoTo CommandError
868 End If
869 For pNum = 1 To Len(Files)
870 fEndLine = InStr(pNum, Files, vbCrLf)
871 fLine = Mid(Files, pNum, fEndLine - pNum)
872 If pNum > 1 Then
873 AddScriptOutput "Line " + CStr(lNum) + ": "
874 End If
875 AddScriptOutput "Extracting " + fLine + "..."
876 sGetFile hMPQ, fLine, FullPath(CurPath, Param(3)), cType
877 AddScriptOutput " Done" + vbCrLf
879 fCount = fCount + 1
880 pNum = fEndLine + 1
881 Next pNum
882 SFileCloseArchive hMPQ
883 If fCount > 1 Then
884 AddScriptOutput "Line " + CStr(lNum) + ": " + CStr(fCount) + " files of " + Param(2) + " extracted" + vbCrLf
885 End If
886 Else
887 If SFileOpenArchive(FullPath(NewPath, MpqFile), 0, 0, hMPQ) = 0 Then
888 AddScriptOutput "Can't open archive " + FullPath(NewPath, MpqFile) + vbCrLf
889 GoTo CommandError
890 End If
891 sGetFile hMPQ, Param(2), FullPath(CurPath, Param(3)), cType
892 SFileCloseArchive hMPQ
893 AddScriptOutput " Done" + vbCrLf
894 End If
895 Else
896 AddScriptOutput " Required parameter missing" + vbCrLf
897 End If
898 Else
899 AddScriptOutput "No archive open" + vbCrLf
900 End If
901 Case "r", "ren", "rename"
902 If MpqFile <> "" Then
903 If InStr(Param(2), "*") = 0 And InStr(Param(2), "?") = 0 Then AddScriptOutput "Renaming " + Param(2) + " => " + Param(3) + "..."
904 If Param(2) <> "" And Param(3) <> "" Then
905 If InStr(Param(2), "*") <> 0 Or InStr(Param(2), "?") <> 0 Then
906 If InStr(Param(3), "*") <> 0 Or InStr(Param(3), "?") <> 0 Then
907 Files = MpqDir(FullPath(NewPath, MpqFile), Param(2))
908 hMPQ = mOpenMpq(FullPath(NewPath, MpqFile))
909 If hMPQ Then
910 For pNum = 1 To Len(Files)
911 fEndLine = InStr(pNum, Files, vbCrLf)
912 fLine = Mid(Files, pNum, fEndLine - pNum)
913 If pNum > 1 Then
914 AddScriptOutput "Line " + CStr(lNum) + ": "
915 End If
916 fLine2 = RenameWithFilter(fLine, Param(2), Param(3))
917 AddScriptOutput "Renaming " + fLine + " => " + fLine2 + "..."
918 If SFileOpenFileEx(hMPQ, fLine2, 0, hFile) Then
919 SFileCloseFile hFile
920 MpqDeleteFile hMPQ, fLine2
921 MpqRenameFile hMPQ, fLine, fLine2
922 Else
923 MpqRenameFile hMPQ, fLine, fLine2
924 End If
925 AddScriptOutput " Done" + vbCrLf
926 fCount = fCount + 1
927 pNum = fEndLine + 1
928 Next pNum
929 MpqCloseUpdatedArchive hMPQ, 0
930 End If
931 If fCount > 1 Then
932 AddScriptOutput "Line " + CStr(lNum) + ": " + CStr(fCount) + " files of " + Param(2) + " renamed" + vbCrLf
933 End If
934 Else
935 AddScriptOutput "You must use wildcards with new name" + vbCrLf
936 End If
937 Else
938 hMPQ = mOpenMpq(FullPath(NewPath, MpqFile))
939 If hMPQ Then
940 If SFileOpenFileEx(hMPQ, Param(3), 0, hFile) Then
941 SFileCloseFile hFile
942 MpqDeleteFile hMPQ, Param(3)
943 MpqRenameFile hMPQ, Param(2), Param(3)
944 Else
945 MpqRenameFile hMPQ, Param(2), Param(3)
946 End If
947 MpqCloseUpdatedArchive hMPQ, 0
948 End If
949 AddScriptOutput " Done" + vbCrLf
950 End If
951 Else
952 AddScriptOutput " Required parameter missing" + vbCrLf
953 End If
954 Else
955 AddScriptOutput "No archive open" + vbCrLf
956 End If
957 Case "m", "move"
958 If MpqFile <> "" Then
959 For pNum = 1 To Len(Param(2))
960 If InStr(bNum, Param(2), "\") Then
961 bNum = InStr(bNum, Param(2), "\")
962 Else
963 Exit For
964 End If
965 Next pNum
966 fLineTitle = Mid(Param(2), bNum)
967 If Right(Param(3), 1) <> "\" And Param(3) <> "" Then Param(3) = Param(3) + "\"
968 Param(3) = Param(3) + fLineTitle
969 If InStr(Param(2), "*") = 0 And InStr(Param(2), "?") = 0 Then AddScriptOutput "Moving " + Param(2) + " => " + Param(3) + "..."
970 If (Left(Param(2), 1) <> "/" And Param(2) <> "") And (Left(Param(3), 1) <> "/") Then
971 If InStr(Param(2), "*") <> 0 Or InStr(Param(2), "?") <> 0 Then
972 Files = MpqDir(FullPath(NewPath, MpqFile), Param(2))
973 hMPQ = mOpenMpq(FullPath(NewPath, MpqFile))
974 If hMPQ Then
975 For pNum = 1 To Len(Files)
976 fEndLine = InStr(pNum, Files, vbCrLf)
977 fLine = Mid(Files, pNum, fEndLine - pNum)
978 If pNum > 1 Then
979 AddScriptOutput "Line " + CStr(lNum) + ": "
980 End If
981 fLine2 = RenameWithFilter(fLine, Param(2), Param(3))
982 AddScriptOutput "Moving " + fLine + " => " + fLine2 + "..."
983 If SFileOpenFileEx(hMPQ, fLine2, 0, hFile) Then
984 SFileCloseFile hFile
985 MpqDeleteFile hMPQ, fLine2
986 MpqRenameFile hMPQ, fLine, fLine2
987 Else
988 MpqRenameFile hMPQ, fLine, fLine2
989 End If
990 AddScriptOutput " Done" + vbCrLf
991 fCount = fCount + 1
992 pNum = fEndLine + 1
993 Next pNum
994 MpqCloseUpdatedArchive hMPQ, 0
995 End If
996 If fCount > 1 Then
997 AddScriptOutput "Line " + CStr(lNum) + ": " + CStr(fCount) + " files of " + Param(2) + " moved" + vbCrLf
998 End If
999 Else
1000 hMPQ = mOpenMpq(FullPath(NewPath, MpqFile))
1001 If hMPQ Then
1002 If SFileOpenFileEx(hMPQ, Param(3), 0, hFile) Then
1003 SFileCloseFile hFile
1004 MpqDeleteFile hMPQ, Param(3)
1005 MpqRenameFile hMPQ, Param(2), Param(3)
1006 Else
1007 MpqRenameFile hMPQ, Param(2), Param(3)
1008 End If
1009 MpqCloseUpdatedArchive hMPQ, 0
1010 End If
1011 AddScriptOutput " Done" + vbCrLf
1012 End If
1013 Else
1014 AddScriptOutput " Required parameter missing" + vbCrLf
1015 End If
1016 Else
1017 AddScriptOutput "No archive open" + vbCrLf
1018 End If
1019 Case "d", "del", "delete"
1020 If MpqFile <> "" Then
1021 If InStr(Param(2), "*") = 0 And InStr(Param(2), "?") = 0 Then AddScriptOutput "Deleting " + Param(2) + "..."
1022 If Left(Param(2), 1) <> "/" And Param(2) <> "" Then
1023 If InStr(Param(2), "*") <> 0 Or InStr(Param(2), "?") <> 0 Then
1024 Files = MpqDir(FullPath(NewPath, MpqFile), Param(2))
1025 hMPQ = mOpenMpq(FullPath(NewPath, MpqFile))
1026 If hMPQ Then
1027 For pNum = 1 To Len(Files)
1028 fEndLine = InStr(pNum, Files, vbCrLf)
1029 fLine = Mid(Files, pNum, fEndLine - pNum)
1030 If pNum > 1 Then
1031 AddScriptOutput "Line " + CStr(lNum) + ": "
1032 End If
1033 AddScriptOutput "Deleting " + fLine + "..."
1034 MpqDeleteFile hMPQ, fLine
1035 AddScriptOutput " Done" + vbCrLf
1036 fCount = fCount + 1
1037 pNum = fEndLine + 1
1038 Next pNum
1039 MpqCloseUpdatedArchive hMPQ, 0
1040 End If
1041 If fCount > 1 Then
1042 AddScriptOutput "Line " + CStr(lNum) + ": " + CStr(fCount) + " files of " + Param(2) + " deleted" + vbCrLf
1043 End If
1044 Else
1045 hMPQ = mOpenMpq(FullPath(NewPath, MpqFile))
1046 If hMPQ Then
1047 MpqDeleteFile hMPQ, Param(2)
1048 MpqCloseUpdatedArchive hMPQ, 0
1049 End If
1050 AddScriptOutput " Done" + vbCrLf
1051 End If
1052 Else
1053 AddScriptOutput " Required parameter missing" + vbCrLf
1054 End If
1055 Else
1056 AddScriptOutput "No archive open" + vbCrLf
1057 End If
1058 Case "f", "flush", "compact"
1059 If MpqFile <> "" Then
1060 AddScriptOutput "Flushing " + MpqFile + "..."
1061 hMPQ = mOpenMpq(FullPath(NewPath, MpqFile))
1062 If hMPQ Then
1063 MpqCompactArchive hMPQ
1064 MpqCloseUpdatedArchive hMPQ, 0
1065 End If
1066 AddScriptOutput " Done" + vbCrLf
1067 Else
1068 AddScriptOutput "No archive open" + vbCrLf
1069 End If
1070 Case "l", "list"
1071 If MpqFile <> "" Then
1072 If Param(2) <> "" Then
1073 AddScriptOutput "Creating list..."
1074 If (InStr(Param(2), "*") <> 0 Or InStr(Param(2), "?") <> 0) And Param(3) <> "" Then
1075 Files = MpqDir(FullPath(NewPath, MpqFile), Param(2))
1076 Param(2) = Param(3)
1077 Else
1078 Files = MpqDir(FullPath(NewPath, MpqFile), "*")
1079 End If
1080 fNum = FreeFile
1081 Open FullPath(CurPath, Param(2)) For Binary As #fNum
1082 Put #fNum, 1, Files
1083 Close #fNum
1084 AddScriptOutput " Done" + vbCrLf
1085 Else
1086 AddScriptOutput " Required parameter missing" + vbCrLf
1087 End If
1088 Else
1089 AddScriptOutput "No archive open" + vbCrLf
1090 End If
1091 Case "s", "script"
1092 AddScriptOutput "Running script " + Param(2) + "..." + vbCrLf + vbCrLf
1093 If Param(2) <> "" Then
1094 RunScript FullPath(CurPath, Param(2))
1095 Else
1096 AddScriptOutput " Required parameter missing" + vbCrLf
1097 End If
1098 AddScriptOutput vbCrLf + "Continuing with previous script..." + vbCrLf
1099 Case "x", "exit", "quit"
1100 Unload MpqEx
1101 Case Else
1102 If Left(Param(1), 1) <> ";" Then
1103 If LCase(Param(1)) = "cd" Or LCase(Param(1)) = "chdir" Then
1104 On Error Resume Next
1105 ChDir Param(2)
1106 On Error GoTo 0
1107 CurPath = CurDir
1108 AddScriptOutput "Current directory is " + CurPath + vbCrLf
1109 ElseIf Left(LCase(Param(1)), 3) = "cd." Or Left(LCase(Param(1)), 3) = "cd\" Then
1110 On Error Resume Next
1111 ChDir Mid(Param(1), 3)
1112 On Error GoTo 0
1113 CurPath = CurDir
1114 AddScriptOutput "Current directory is " + CurPath + vbCrLf
1115 ElseIf Left(LCase(Param(1)), 6) = "chdir." Or Left(LCase(Param(1)), 6) = "chdir\" Then
1116 On Error Resume Next
1117 ChDir Mid(Param(1), 6)
1118 On Error GoTo 0
1119 CurPath = CurDir
1120 AddScriptOutput "Current directory is " + CurPath + vbCrLf
1121 ElseIf Mid(Param(1), 2, 1) = ":" And (Len(Param(1)) = 2 Or Right(Param(1), 1) = "\") Then
1122 On Error Resume Next
1123 ChDrive Left(Param(1), 2)
1124 On Error GoTo 0
1125 CurPath = CurDir
1126 AddScriptOutput "Current directory is " + CurPath + vbCrLf
1127 Else
1128 AddScriptOutput "Running command " + sLine + "..."
1129 Shell "command.com /c " + sLine, 1
1130 AddScriptOutput " Done" + vbCrLf
1131 End If
1132 Else
1133 AddScriptOutput "Comment " + sLine + vbCrLf
1134 End If
1135 End Select
1136 End If
1137 CommandError:
1138 lNum = lNum + 1
1139 bNum = EndLine + 1
1140 Next bNum
1141 DefaultMaxFiles = OldDefaultMaxFiles
1142 If Mid(OldPath, 2, 1) = ":" Then ChDrive Left(OldPath, 1)
1143 ChDir OldPath
1144 End Sub
1145 Function FindMpqHeader(MpqFile As String) As Long
1146 If FileExists(MpqFile) = False Then
1147 FindMpqHeader = -1
1148 Exit Function
1149 End If
1150 Dim hFile
1151 hFile = FreeFile
1152 Open MpqFile For Binary As #hFile
1153 Dim FileLen As Long
1154 FileLen = LOF(hFile)
1155 Dim pbuf As String
1156 pbuf = String(32, Chr(0))
1157 Dim i As Long
1158 For i = 0 To FileLen - 1 Step 512
1159 Get #hFile, 1 + i, pbuf
1160 If Left(pbuf, 4) = "MPQ" + Chr(26) Or Left(pbuf, 4) = "BN3" + Chr(26) Then
1161 ' Storm no longer does this, so this shouldn't either
1162 'FileLen = FileLen - i
1163 'If JBytes(pbuf, 9, 4) = FileLen
1164 ' FileMpqHeader = i
1165 ' Close #hFile
1166 ' Exit Function
1167 'Else
1168 ' FileLen = FileLen + i
1169 'End If
1170 FindMpqHeader = i
1171 Close #hFile
1172 Exit Function
1173 End If
1174 Next i
1175 FindMpqHeader = -1
1176 Close #hFile
1177 End Function
1178 Function GetNumMpqFiles(MpqFile As String) As Long
1179 Dim fNum As Long, Text As String, MpqHeader As Long
1180 fNum = FreeFile
1181 Text = String(4, Chr(0))
1182 MpqHeader = FindMpqHeader(MpqFile)
1183 If MpqHeader > -1 Then
1184 Open MpqFile For Binary As #fNum
1185 Get #fNum, MpqHeader + 29, GetNumMpqFiles
1186 Close #fNum
1187 End If
1188 End Function
|