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