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: |
fe9f43dc439cb0eb517c302810ec97df8748e22b
1 VERSION 4.00
2 Begin VB.Form MpqEx
3 Caption = "WinMPQ"
4 ClientHeight = 3510
5 ClientLeft = 1245
6 ClientTop = 1785
7 ClientWidth = 6690
8 Height = 4200
9 Icon = "listing.frx":0000
10 Left = 1185
11 LinkTopic = "Form1"
12 ScaleHeight = 3510
13 ScaleWidth = 6690
14 Top = 1155
15 Width = 6810
16 Begin VB.Timer Timer1
17 Enabled = 0 'False
18 Interval = 5000
19 Left = 6120
20 Top = 2160
21 End
22 Begin VB.TextBox txtCommand
23 BackColor = &H8000000F&
24 Height = 285
25 Left = 1440
26 TabIndex = 1
27 Top = 2880
28 Width = 4695
29 End
30 Begin VB.CommandButton cmdGo
31 Caption = "Go"
32 Height = 285
33 Left = 6120
34 TabIndex = 2
35 Top = 2880
36 Width = 495
37 End
38 Begin VB.ComboBox mFilter
39 Height = 315
40 ItemData = "listing.frx":27A2
41 Left = 5220
42 List = "listing.frx":27A9
43 Sorted = -1 'True
44 TabIndex = 3
45 Text = "*"
46 Top = 30
47 Width = 675
48 End
49 Begin MSComctlLib.Toolbar Toolbar
50 Align = 1 'Align Top
51 Height = 345
52 Left = 0
53 TabIndex = 5
54 Top = 0
55 Width = 6690
56 _ExtentX = 11800
57 _ExtentY = 609
58 ButtonWidth = 1535
59 ButtonHeight = 556
60 Wrappable = 0 'False
61 Appearance = 1
62 Style = 1
63 ImageList = "ImageList1"
64 _Version = 393216
65 BeginProperty Buttons {66833FE8-8583-11D1-B16A-00C0F0283628}
66 NumButtons = 8
67 BeginProperty Button1 {66833FEA-8583-11D1-B16A-00C0F0283628}
68 Caption = "New"
69 Key = "New"
70 Description = "Create a new archive"
71 ToolTipText = "Create a new archive"
72 ImageIndex = 1
73 EndProperty
74 BeginProperty Button2 {66833FEA-8583-11D1-B16A-00C0F0283628}
75 Caption = "Open"
76 Key = "Open"
77 Description = "Open an existing archive"
78 ToolTipText = "Open an existing archive"
79 EndProperty
80 BeginProperty Button3 {66833FEA-8583-11D1-B16A-00C0F0283628}
81 Enabled = 0 'False
82 Caption = "Add"
83 Key = "Add"
84 Description = "Add files to the archive"
85 ToolTipText = "Add files to the archive"
86 EndProperty
87 BeginProperty Button4 {66833FEA-8583-11D1-B16A-00C0F0283628}
88 Enabled = 0 'False
89 Caption = "Add Folder"
90 Key = "Add Folder"
91 Description = "Add files from a folder and its subfolders"
92 ToolTipText = "Add files from a folder and its subfolders"
93 EndProperty
94 BeginProperty Button5 {66833FEA-8583-11D1-B16A-00C0F0283628}
95 Enabled = 0 'False
96 Caption = "Extract"
97 Key = "Extract"
98 Description = "Extract files from the archive"
99 ToolTipText = "Extract files from the archive"
100 EndProperty
101 BeginProperty Button6 {66833FEA-8583-11D1-B16A-00C0F0283628}
102 Enabled = 0 'False
103 Caption = "Compact"
104 Key = "Compact"
105 Description = "Clear deleted files from the archive"
106 ToolTipText = "Clear deleted files from the archive"
107 EndProperty
108 BeginProperty Button7 {66833FEA-8583-11D1-B16A-00C0F0283628}
109 Enabled = 0 'False
110 Key = "filterspace"
111 Style = 4
112 Object.Width = 675
113 EndProperty
114 BeginProperty Button8 {66833FEA-8583-11D1-B16A-00C0F0283628}
115 Enabled = 0 'False
116 Caption = "List"
117 Key = "List"
118 EndProperty
119 EndProperty
120 End
121 Begin VB.Label Label1
122 AutoSize = -1 'True
123 Caption = " MPQ2k &Command "
124 Height = 195
125 Left = 0
126 TabIndex = 6
127 Top = 2880
128 Width = 1425
129 End
130 Begin MSComctlLib.ImageList ImageList1
131 Left = 6120
132 Top = 1560
133 _ExtentX = 1005
134 _ExtentY = 1005
135 BackColor = -2147483643
136 ImageWidth = 1
137 ImageHeight = 1
138 MaskColor = 12632256
139 _Version = 393216
140 BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628}
141 NumListImages = 1
142 BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628}
143 Picture = "listing.frx":27B0
144 Key = ""
145 EndProperty
146 EndProperty
147 End
148 Begin MSComctlLib.StatusBar StatBar
149 Align = 2 'Align Bottom
150 Height = 300
151 Left = 0
152 TabIndex = 4
153 Top = 3210
154 Width = 6690
155 _ExtentX = 11800
156 _ExtentY = 529
157 _Version = 393216
158 BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628}
159 NumPanels = 2
160 BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628}
161 AutoSize = 1
162 Object.Width = 5664
163 MinWidth = 2
164 Key = "FileInfo"
165 EndProperty
166 BeginProperty Panel2 {8E3867AB-8586-11D1-B16A-00C0F0283628}
167 AutoSize = 1
168 Object.Width = 5664
169 MinWidth = 2
170 Key = "MpqInfo"
171 EndProperty
172 EndProperty
173 End
174 Begin MSComctlLib.ListView List
175 Height = 2295
176 Left = 0
177 TabIndex = 0
178 Top = 360
179 Width = 6015
180 _ExtentX = 10610
181 _ExtentY = 4048
182 View = 3
183 Arrange = 2
184 Sorted = -1 'True
185 MultiSelect = -1 'True
186 LabelWrap = -1 'True
187 HideSelection = -1 'True
188 OLEDragMode = 1
189 OLEDropMode = 1
190 AllowReorder = -1 'True
191 _Version = 393217
192 ForeColor = -2147483640
193 BackColor = -2147483643
194 BorderStyle = 1
195 Appearance = 1
196 BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
197 Name = "MS Sans Serif"
198 Size = 8.25
199 Charset = 0
200 Weight = 400
201 Underline = 0 'False
202 Italic = 0 'False
203 Strikethrough = 0 'False
204 EndProperty
205 OLEDragMode = 1
206 OLEDropMode = 1
207 NumItems = 5
208 BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628}
209 Key = "N"
210 Text = "Name"
211 Object.Width = 5080
212 EndProperty
213 BeginProperty ColumnHeader(2) {BDD1F052-858B-11D1-B16A-00C0F0283628}
214 Alignment = 1
215 SubItemIndex = 1
216 Key = "S"
217 Text = "Size"
218 Object.Width = 1905
219 EndProperty
220 BeginProperty ColumnHeader(3) {BDD1F052-858B-11D1-B16A-00C0F0283628}
221 Alignment = 1
222 SubItemIndex = 2
223 Key = "R"
224 Text = "Ratio"
225 Object.Width = 1129
226 EndProperty
227 BeginProperty ColumnHeader(4) {BDD1F052-858B-11D1-B16A-00C0F0283628}
228 Alignment = 1
229 SubItemIndex = 3
230 Key = "PK"
231 Text = "Packed"
232 Object.Width = 1905
233 EndProperty
234 BeginProperty ColumnHeader(5) {BDD1F052-858B-11D1-B16A-00C0F0283628}
235 SubItemIndex = 4
236 Key = "A"
237 Text = "Attributes"
238 Object.Width = 1129
239 EndProperty
240 End
241 Begin MPQCONTROLLib.MpqControl Mpq
242 Left = 6120
243 Top = 600
244 _Version = 65542
245 _ExtentX = 873
246 _ExtentY = 873
247 _StockProps = 0
248 TitleHidden = -1 'True
249 End
250 Begin VB.Menu mnuFile
251 Caption = "&File"
252 Begin VB.Menu mnuFNew
253 Caption = "&New..."
254 Shortcut = ^N
255 End
256 Begin VB.Menu mnuFOpen
257 Caption = "&Open..."
258 Shortcut = ^O
259 End
260 Begin VB.Menu mnuFReopen
261 Caption = "&Reopen Mpq"
262 Shortcut = {F5}
263 End
264 Begin VB.Menu mnuFScript
265 Caption = "Run Mo'PaQ 2000 &Script..."
266 Shortcut = ^S
267 End
268 Begin VB.Menu mnuFSep
269 Caption = "-"
270 End
271 Begin VB.Menu mnuFExit
272 Caption = "E&xit"
273 End
274 Begin VB.Menu mnuFRecent
275 Caption = "-"
276 Index = 0
277 Visible = 0 'False
278 End
279 End
280 Begin VB.Menu mnuMpq
281 Caption = "&Mpq"
282 Enabled = 0 'False
283 Begin VB.Menu mnuMAdd
284 Caption = "&Add..."
285 Shortcut = ^A
286 End
287 Begin VB.Menu mnuMAddFolder
288 Caption = "Add &Folder..."
289 Shortcut = ^F
290 End
291 Begin VB.Menu mnuMCompression
292 Caption = "&Compression"
293 Begin VB.Menu mnuMCAuto
294 Caption = "Auto-Select"
295 Checked = -1 'True
296 Shortcut = {F4}
297 End
298 Begin VB.Menu mnuMCSep
299 Caption = "-"
300 End
301 Begin VB.Menu mnuMCNone
302 Caption = "&None"
303 Shortcut = {F2}
304 End
305 Begin VB.Menu mnuMCStandard
306 Caption = "&Standard"
307 Shortcut = {F3}
308 End
309 Begin VB.Menu mnuMCAudio
310 Caption = "&Audio"
311 Begin VB.Menu mnuMCALowest
312 Caption = "&Lowest (Best quality)"
313 Shortcut = {F6}
314 End
315 Begin VB.Menu mnuMCAMedium
316 Caption = "&Medium"
317 Shortcut = {F7}
318 End
319 Begin VB.Menu mnuMCAHighest
320 Caption = "&Highest (Least space)"
321 Shortcut = {F8}
322 End
323 End
324 End
325 Begin VB.Menu mnuMExtract
326 Caption = "&Extract"
327 Shortcut = ^E
328 End
329 Begin VB.Menu mnuMDelete
330 Caption = "&Delete Del or"
331 Shortcut = ^D
332 End
333 Begin VB.Menu mnuMRename
334 Caption = "Rena&me"
335 Shortcut = ^R
336 End
337 Begin VB.Menu mnuMCompact
338 Caption = "Com&pact"
339 Shortcut = ^P
340 End
341 Begin VB.Menu mnuMSaveList
342 Caption = "Save File &List..."
343 Shortcut = ^L
344 End
345 End
346 Begin VB.Menu mnuTools
347 Caption = "&Tools"
348 Begin VB.Menu mnuTItem
349 Caption = "(Empty)"
350 Enabled = 0 'False
351 Index = 0
352 End
353 Begin VB.Menu mnuTSep
354 Caption = "-"
355 End
356 Begin VB.Menu mnuTAdd
357 Caption = "&Add/Remove..."
358 End
359 End
360 Begin VB.Menu mnuOptions
361 Caption = "&Options..."
362 End
363 Begin VB.Menu mnuHelp
364 Caption = "&Help"
365 Begin VB.Menu mnuHReadme
366 Caption = "View &Readme..."
367 Shortcut = {F1}
368 End
369 Begin VB.Menu mnuHSep
370 Caption = "-"
371 End
372 Begin VB.Menu mnuHAbout
373 Caption = "&About..."
374 End
375 End
376 Begin VB.Menu mnuPopup
377 Caption = "Popup Menu"
378 Visible = 0 'False
379 Begin VB.Menu mnuPItem
380 Caption = "&Open"
381 Index = 0
382 End
383 Begin VB.Menu mnuPSep
384 Caption = "-"
385 End
386 Begin VB.Menu mnuPExtract
387 Caption = "&Extract"
388 End
389 Begin VB.Menu mnuPDelete
390 Caption = "&Delete"
391 End
392 Begin VB.Menu mnuPRename
393 Caption = "Rena&me"
394 End
395 End
396 End
397 Attribute VB_Name = "MpqEx"
398 Attribute VB_Creatable = False
399 Attribute VB_Exposed = False
400 Option Explicit
402 Dim txtCommandHasFocus As Boolean
403 Dim OpenFiles() As String, OpenFileDates() As Date, MpqDate As Date
404 Sub AddRecentFile(rFileName As String)
405 Dim bNum As Long, fNum As Long
406 NewKey AppKey + "Recent\"
407 For bNum = 1 To 8
408 If LCase(GetReg(AppKey + "Recent\File" + CStr(bNum))) = LCase(rFileName) Then
409 For fNum = bNum To 7
410 If Not IsEmpty(GetReg(AppKey + "Recent\File" + CStr(fNum + 1))) Then
411 SetReg AppKey + "Recent\File" + CStr(fNum), GetReg(AppKey + "Recent\File" + CStr(fNum + 1))
412 Else
413 Exit For
414 End If
415 Next fNum
416 SetReg AppKey + "Recent\File" + CStr(fNum), rFileName
417 Exit For
418 End If
419 Next bNum
420 If fNum = 0 Then
421 For bNum = 1 To 8
422 If IsEmpty(GetReg(AppKey + "Recent\File" + CStr(bNum))) Then
423 SetReg AppKey + "Recent\File" + CStr(bNum), rFileName
424 Exit For
425 ElseIf bNum = 8 Then
426 For fNum = 1 To 7
427 SetReg AppKey + "Recent\File" + CStr(fNum), GetReg(AppKey + "Recent\File" + CStr(fNum + 1))
428 Next fNum
429 SetReg AppKey + "Recent\File" + CStr(bNum), rFileName
430 End If
431 Next bNum
432 End If
433 BuildRecentFileList
434 End Sub
435 Sub BuildPopup(FileName As String, Shift As Integer)
436 Dim aNum As Long, aItem As String, aName As String, bNum As Long, PItem As Menu, dItem As String
437 mnuPopup.Tag = 0
438 For Each PItem In mnuPItem
439 If PItem.Index <> 0 Then Unload PItem
440 Next PItem
441 If InStr(FileName, ".") = 0 Then
442 GoSub AddUnknown
443 Else
444 For bNum = 1 To Len(FileName)
445 If InStr(bNum, FileName, ".") > 0 Then
446 bNum = InStr(bNum, FileName, ".")
447 Else
448 Exit For
449 End If
450 Next bNum
451 aName = Mid(FileName, bNum - 1)
452 aName = GetReg("HKEY_CLASSES_ROOT\" + aName + "\")
453 If aName = "" Then
454 GoSub AddUnknown
455 Exit Sub
456 End If
457 dItem = GetReg("HKEY_CLASSES_ROOT\" + aName + "\shell\", "open")
458 dItem = GetReg(SharedAppKey + "FileDefaultActions\" + aName, dItem)
459 If dItem <> "" And Not IsEmpty(GetReg("HKEY_CLASSES_ROOT\" + aName + "\shell\" + dItem + "\command\")) Then
460 If LCase(dItem) = "openas" And IsEmpty(GetReg("HKEY_CLASSES_ROOT\" + aName + "\shell\" + dItem + "\")) Then
461 mnuPItem(0).Caption = "Op&en with..."
462 Else
463 mnuPItem(0).Caption = GetReg("HKEY_CLASSES_ROOT\" + aName + "\shell\" + dItem + "\", "&" + UCase(Left(dItem, 1)) + Mid(dItem, 2))
464 End If
465 mnuPItem(0).Tag = dItem
466 mnuPopup.Tag = 1
467 aNum = 0
468 bNum = 1
469 Else
470 aItem = EnumKey("HKEY_CLASSES_ROOT\" + aName + "\shell\", 0)
471 If aItem = "" Then
472 GoSub AddUnknown
473 Exit Sub
474 End If
475 If Not IsEmpty(GetReg("HKEY_CLASSES_ROOT\" + aName + "\shell\" + aItem + "\command\")) Then
476 If LCase(aItem) = "openas" And IsEmpty(GetReg("HKEY_CLASSES_ROOT\" + aName + "\shell\" + aItem + "\")) Then
477 mnuPItem(0).Caption = "Op&en with..."
478 Else
479 mnuPItem(0).Caption = GetReg("HKEY_CLASSES_ROOT\" + aName + "\shell\" + aItem + "\", "&" + UCase(Left(aItem, 1)) + Mid(aItem, 2))
480 End If
481 mnuPItem(0).Tag = aItem
482 mnuPopup.Tag = 1
483 aNum = 1
484 bNum = 1
485 Else
486 aNum = 1
487 bNum = 0
488 End If
489 End If
490 Do
491 aItem = EnumKey("HKEY_CLASSES_ROOT\" + aName + "\shell\", aNum)
492 If aItem <> "" Then
493 If LCase(aItem) <> LCase(dItem) And Not IsEmpty(GetReg("HKEY_CLASSES_ROOT\" + aName + "\shell\" + aItem + "\command\")) Then
494 On Error Resume Next
495 Load mnuPItem(bNum)
496 On Error GoTo 0
497 If LCase(aItem) = "openas" And IsEmpty(GetReg("HKEY_CLASSES_ROOT\" + aName + "\shell\" + aItem + "\")) Then
498 mnuPItem(bNum).Caption = "Op&en with..."
499 Else
500 mnuPItem(bNum).Caption = GetReg("HKEY_CLASSES_ROOT\" + aName + "\shell\" + aItem + "\", "&" + UCase(Left(aItem, 1)) + Mid(aItem, 2))
501 End If
502 mnuPItem(bNum).Tag = aItem
503 mnuPopup.Tag = mnuPopup.Tag + 1
504 bNum = bNum + 1
505 End If
506 aNum = aNum + 1
507 End If
508 Loop Until aItem = ""
509 If Shift And vbShiftMask Then GoSub AddUnknown
510 End If
511 Exit Sub
512 AddUnknown:
513 aNum = 0
514 bNum = mnuPopup.Tag
515 dItem = ""
516 If bNum = 0 Then
517 dItem = GetReg("HKEY_CLASSES_ROOT\Unknown\shell\", "open")
518 dItem = GetReg(SharedAppKey + "FileDefaultActions\Unknown", dItem)
519 If dItem <> "" And Not IsEmpty(GetReg("HKEY_CLASSES_ROOT\Unknown\shell\" + dItem + "\command\")) Then
520 If LCase(dItem) = "openas" And IsEmpty(GetReg("HKEY_CLASSES_ROOT\Unknown\shell\" + dItem + "\")) Then
521 mnuPItem(bNum).Caption = "Op&en with..."
522 Else
523 mnuPItem(bNum).Caption = GetReg("HKEY_CLASSES_ROOT\Unknown\shell\" + dItem + "\", "&" + UCase(Left(dItem, 1)) + Mid(dItem, 2))
524 End If
525 mnuPItem(bNum).Tag = dItem
526 bNum = bNum + 1
527 End If
528 End If
529 Do
530 aItem = EnumKey("HKEY_CLASSES_ROOT\Unknown\shell\", aNum)
531 If aItem <> "" Then
532 If LCase(aItem) <> LCase(dItem) And Not IsEmpty(GetReg("HKEY_CLASSES_ROOT\Unknown\shell\" + aItem + "\command\")) Then
533 On Error Resume Next
534 Load mnuPItem(bNum)
535 On Error GoTo 0
536 If LCase(aItem) = "openas" And IsEmpty(GetReg("HKEY_CLASSES_ROOT\Unknown\shell\" + aItem + "\")) Then
537 mnuPItem(bNum).Caption = "Op&en with..."
538 Else
539 mnuPItem(bNum).Caption = GetReg("HKEY_CLASSES_ROOT\Unknown\shell\" + aItem + "\", "&" + UCase(Left(aItem, 1)) + Mid(aItem, 2))
540 End If
541 mnuPItem(bNum).Tag = aItem
542 bNum = bNum + 1
543 End If
544 aNum = aNum + 1
545 End If
546 Loop Until aItem = ""
547 Return
548 End Sub
549 Sub DelRecentFile(rFileName As String)
550 Dim bNum As Long, fNum As Long
551 For bNum = 1 To 8
552 If LCase(GetReg(AppKey + "Recent\File" + CStr(bNum))) = LCase(rFileName) Then
553 For fNum = bNum To 7
554 SetReg AppKey + "Recent\File" + CStr(fNum), GetReg(AppKey + "Recent\File" + CStr(fNum + 1))
555 Next fNum
556 DelReg AppKey + "Recent\File" + CStr(8)
557 Exit For
558 End If
559 Next bNum
560 BuildRecentFileList
561 End Sub
562 Sub AddToListing(AddedFile As String)
563 Dim lIndex As Long, L1 As String, L2 As String, L3 As String, L4 As String, L5 As String, fSize As Long, cSize As Long, fFlags As Long
564 If Mpq.FileExists(CD.FileName, AddedFile) Then
565 L1 = AddedFile
566 fSize = Mpq.FileSize(CD.FileName, AddedFile)
567 cSize = Mpq.GetFileInfo(CD.FileName, AddedFile, 6)
568 If fSize / 1024 > 0 And fSize / 1024 < 1 Then
569 L2 = "<1KB"
570 ElseIf fSize = 0 Then
571 L2 = "0KB"
572 Else
573 L2 = CStr(Int(fSize / 1024)) + "KB"
574 End If
575 If cSize / 1024 > 0 And cSize / 1024 < 1 Then
576 L4 = "<1KB"
577 ElseIf cSize = 0 Then
578 L4 = "0KB"
579 Else
580 L4 = CStr(Int(cSize / 1024)) + "KB"
581 End If
582 If fSize <> 0 Then
583 L3 = CStr(Int((1 - cSize / fSize) * 100)) + "%"
584 Else
585 L3 = "0%"
586 End If
587 fFlags = Mpq.GetFileInfo(CD.FileName, AddedFile, 7)
588 If (fFlags And &H200) Or (fFlags And &H100) Then L5 = "C" Else L5 = "-"
589 If fFlags And &H10000 Then L5 = L5 + "E" Else L5 = L5 + "-"
590 If fFlags And &H20000 Then L5 = L5 + "X" Else L5 = L5 + "-"
591 On Error Resume Next
592 lIndex = List.ListItems.Add(, L1, L1).Index
593 On Error GoTo 0
594 If lIndex = 0 Then
595 lIndex = List.ListItems.Item(L1).Index
596 List.ListItems.Item(L1).ListSubItems.Clear
597 End If
598 List.ListItems.Item(lIndex).Tag = L1
599 List.ListItems.Item(lIndex).ListSubItems.Add(, , L2).Tag = fSize
600 If fSize <> 0 Then
601 List.ListItems.Item(lIndex).ListSubItems.Add(, , L3).Tag = Int((1 - cSize / fSize) * 100)
602 Else
603 List.ListItems.Item(lIndex).ListSubItems.Add(, , L3).Tag = 0
604 End If
605 List.ListItems.Item(lIndex).ListSubItems.Add(, , L4).Tag = cSize
606 List.ListItems.Item(lIndex).ListSubItems.Add(, , L5).Tag = L5
607 End If
608 End Sub
609 Sub MpqAddToListing(hMPQ As Long, AddedFile As String)
610 Dim lIndex As Long, L1 As String, L2 As String, L3 As String, L4 As String, L5 As String, fSize As Long, cSize As Long, fFlags As Long, hFile As Long
611 If Mpq.SFileOpenFileEx(hMPQ, AddedFile, 0, hFile) Then
612 L1 = AddedFile
613 fSize = Mpq.SFileGetFileSize(hFile, 0)
614 cSize = Mpq.SFileGetFileInfo(hFile, 6)
615 If fSize / 1024 > 0 And fSize / 1024 < 1 Then
616 L2 = "<1KB"
617 ElseIf fSize = 0 Then
618 L2 = "0KB"
619 Else
620 L2 = CStr(Int(fSize / 1024)) + "KB"
621 End If
622 If cSize / 1024 > 0 And cSize / 1024 < 1 Then
623 L4 = "<1KB"
624 ElseIf cSize = 0 Then
625 L4 = "0KB"
626 Else
627 L4 = CStr(Int(cSize / 1024)) + "KB"
628 End If
629 If fSize <> 0 Then
630 L3 = CStr(Int((1 - cSize / fSize) * 100)) + "%"
631 Else
632 L3 = "0%"
633 End If
634 fFlags = Mpq.SFileGetFileInfo(hFile, 7)
635 If (fFlags And &H200) Or (fFlags And &H100) Then L5 = "C" Else L5 = "-"
636 If fFlags And &H10000 Then L5 = L5 + "E" Else L5 = L5 + "-"
637 If fFlags And &H20000 Then L5 = L5 + "X" Else L5 = L5 + "-"
638 On Error Resume Next
639 lIndex = List.ListItems.Add(, L1, L1).Index
640 On Error GoTo 0
641 If lIndex = 0 Then
642 lIndex = List.ListItems.Item(L1).Index
643 List.ListItems.Item(L1).ListSubItems.Clear
644 End If
645 List.ListItems.Item(lIndex).Tag = L1
646 List.ListItems.Item(lIndex).ListSubItems.Add(, , L2).Tag = fSize
647 If fSize <> 0 Then
648 List.ListItems.Item(lIndex).ListSubItems.Add(, , L3).Tag = Int((1 - cSize / fSize) * 100)
649 Else
650 List.ListItems.Item(lIndex).ListSubItems.Add(, , L3).Tag = 0
651 End If
652 List.ListItems.Item(lIndex).ListSubItems.Add(, , L4).Tag = cSize
653 List.ListItems.Item(lIndex).ListSubItems.Add(, , L5).Tag = L5
654 Mpq.SFileCloseFile hFile
655 End If
656 End Sub
657 Sub RemoveFromListing(RemovedFile As String)
658 Dim FileCount As Long
659 On Error GoTo FileRemoved
660 Do
661 List.ListItems.Remove RemovedFile
662 FileCount = FileCount + 1
663 Loop
664 FileRemoved:
665 If FileCount = 0 Then
666 For FileCount = 1 To List.ListItems.Count
667 If LCase(RemovedFile) = LCase(List.ListItems.Item(FileCount).Key) Then
668 List.ListItems.Remove FileCount
669 Exit Sub
670 End If
671 Next FileCount
672 End If
673 End Sub
674 Sub RenameInListing(OldName As String, NewName As String)
675 Dim lIndex As Long
676 If LCase(OldName) <> LCase(NewName) Then RemoveFromListing NewName
677 On Error GoTo RenameError
678 lIndex = List.ListItems.Item(OldName).Index
679 List.ListItems.Item(lIndex).Text = NewName
680 List.ListItems.Item(lIndex).Tag = NewName
681 On Error Resume Next
682 List.ListItems.Item(lIndex).Key = NewName
683 On Error GoTo 0
684 Exit Sub
685 RenameError:
686 For lIndex = 1 To List.ListItems.Count
687 If LCase(OldName) = LCase(List.ListItems.Item(lIndex).Key) Then
688 List.ListItems.Item(lIndex).Text = NewName
689 List.ListItems.Item(lIndex).Tag = NewName
690 On Error Resume Next
691 List.ListItems.Item(lIndex).Key = NewName
692 On Error GoTo 0
693 Exit Sub
694 End If
695 Next lIndex
696 End Sub
697 Sub ExecuteFile(FileName As String, Index As Integer)
698 Dim Param As String, bNum As Long, bNum2 As Long, EnvName As String
699 If Index < mnuPopup.Tag Then
700 ShellExecute hWnd, mnuPItem(Index).Tag, FileName, vbNullString, vbNullString, 1
701 Else
702 Param = GetReg("HKEY_CLASSES_ROOT\Unknown\shell\" + mnuPItem(Index).Tag + "\command\")
703 Do
704 If InStr(Param, "%1") = 0 Then
705 Param = Param + " " + FileName
706 Else
707 bNum = InStr(Param, "%1")
708 Param = Left(Param, bNum - 1) + FileName + Mid(Param, bNum + 2)
709 End If
710 Loop While InStr(Param, "%1")
711 bNum = 1
712 Do While bNum <= Len(Param)
713 If InStr(bNum, Param, "%") Then
714 bNum = InStr(bNum, Param, "%")
715 If InStr(bNum + 1, Param, "%") Then
716 bNum2 = InStr(bNum + 1, Param, "%")
717 EnvName = Mid(Param, bNum + 1, bNum2 - bNum - 1)
718 If Environ(EnvName) <> "" Then
719 Param = Left(Param, bNum - 1) + Environ(EnvName) + Mid(Param, bNum2 + 1)
720 End If
721 End If
722 End If
723 bNum = bNum + 1
724 Loop
725 On Error GoTo NoProgram
726 Shell Param, 1
727 On Error GoTo 0
728 End If
729 Exit Sub
730 NoProgram:
731 If Err.Number = 53 Then MsgBox "No program is assigned for this action.", , "WinMPQ"
732 End Sub
733 Sub RunMpq2kCommand(CmdLine As String)
734 Dim sLine As String, pNum As Long, Param() As String, EndParam As Long, CurPath As String, cType As Integer, Rswitch As Boolean, fCount As Long, Files As String, fEndLine As Long, fLine As String, bNum As Long, OldFileName As String, fNum As Long, cNum As Long, FileFilter As String, TItem As Menu, fLine2 As String, fLineTitle As String, hMPQ As Long, FileShortNames() As String
735 CurPath = CurDir
736 If Right(CurPath, 1) <> "\" Then CurPath = CurPath + "\"
737 sLine = CmdLine
738 If Right(sLine, 1) <> " " Then sLine = sLine + " "
739 If sLine <> "" Then
740 ReDim Param(0) As String
741 For pNum = 1 To Len(sLine)
742 If Mid(sLine, pNum, 1) = Chr(34) Then
743 pNum = pNum + 1
744 EndParam = InStr(pNum, sLine, Chr(34))
745 Else
746 EndParam = InStr(pNum, sLine, " ")
747 End If
748 If EndParam = 0 Then EndParam = Len(sLine) + 1
749 If pNum <> EndParam Then
750 If Trim(Mid(sLine, pNum, EndParam - pNum)) <> "" Then
751 ReDim Preserve Param(UBound(Param) + 1) As String
752 Param(UBound(Param)) = Trim(Mid(sLine, pNum, EndParam - pNum))
753 End If
754 End If
755 pNum = EndParam
756 Next pNum
757 If UBound(Param) < 3 Then ReDim Preserve Param(3) As String
758 Select Case LCase(Param(1))
759 Case "?", "h", "help"
760 mnuHReadme_Click
761 Case "o", "open"
762 OldFileName = CD.FileName
763 If Param(2) <> "" Then
764 CD.FileName = FullPath(CurPath, Param(2))
765 End If
766 If Param(3) <> "" And FileExists(CD.FileName) = False And CD.FileName <> "" Then
767 Mpq.DefaultMaxFiles = Param(3)
768 End If
769 If FileExists(CD.FileName) Then
770 OpenMpq
771 If CD.FileName = "" Then
772 CD.FileName = OldFileName
773 StatBar.SimpleText = "The file does not contain an MPQ archive."
774 Else
775 StatBar.SimpleText = "Opened " + CD.FileName
776 AddRecentFile CD.FileName
777 End If
778 ElseIf FileExists(CD.FileName) = False And CD.FileName <> "" Then
779 ReDim FileList(0) As String
780 List.ListItems.Clear
781 ShowSelected
782 ShowTotal
783 NewFile = True
784 ReDim OpenFiles(0) As String, OpenFileDates(0) As Date
785 mnuMpq.Enabled = True
786 For Each TItem In mnuTItem
787 TItem.Enabled = True
788 Next TItem
789 Toolbar.Buttons.Item("Add").Enabled = True
790 Toolbar.Buttons.Item("Add Folder").Enabled = True
791 Toolbar.Buttons.Item("Extract").Enabled = True
792 Toolbar.Buttons.Item("Compact").Enabled = True
793 Toolbar.Buttons.Item("List").Enabled = True
794 If InStr(CD.FileName, "\") > 0 Then
795 For bNum = 1 To Len(CD.FileName)
796 If InStr(bNum, CD.FileName, "\") > 0 Then
797 bNum = InStr(bNum, CD.FileName, "\")
798 Else
799 Exit For
800 End If
801 Next bNum
802 End If
803 Caption = "WinMPQ - " + Mid(CD.FileName, bNum)
804 StatBar.SimpleText = "Created new " + CD.FileName
805 AddRecentFile CD.FileName
806 ElseIf CD.FileName = "" Then
807 StatBar.SimpleText = "Required parameter missing"
808 End If
809 Case "n", "new"
810 If Param(2) <> "" Then
811 CD.FileName = FullPath(CurPath, Param(2))
812 If Param(3) <> "" Then
813 Mpq.DefaultMaxFiles = Param(3)
814 End If
815 If CD.FileName <> "" Then
816 ReDim FileList(0) As String
817 List.ListItems.Clear
818 ShowSelected
819 ShowTotal
820 NewFile = True
821 ReDim OpenFiles(0) As String, OpenFileDates(0) As Date
822 mnuMpq.Enabled = True
823 For Each TItem In mnuTItem
824 TItem.Enabled = True
825 Next TItem
826 Toolbar.Buttons.Item("Add").Enabled = True
827 Toolbar.Buttons.Item("Add Folder").Enabled = True
828 Toolbar.Buttons.Item("Extract").Enabled = True
829 Toolbar.Buttons.Item("Compact").Enabled = True
830 Toolbar.Buttons.Item("List").Enabled = True
831 If InStr(CD.FileName, "\") > 0 Then
832 For bNum = 1 To Len(CD.FileName)
833 If InStr(bNum, CD.FileName, "\") > 0 Then
834 bNum = InStr(bNum, CD.FileName, "\")
835 Else
836 Exit For
837 End If
838 Next bNum
839 End If
840 Caption = "WinMPQ - " + Mid(CD.FileName, bNum)
841 StatBar.SimpleText = "Created new " + CD.FileName
842 AddRecentFile CD.FileName
843 End If
844 Else
845 StatBar.SimpleText = "Required parameter missing"
846 End If
847 Case "c", "close"
848 StatBar.SimpleText = "Close is for scripts only"
849 Case "p", "pause"
850 StatBar.SimpleText = "Pause not supported"
851 Case "a", "add"
852 If CD.FileName <> "" Then
853 ReDim FileShortNames(0) As String
854 cType = 0
855 Rswitch = False
856 fCount = 0
857 Files = ""
858 fEndLine = 0
859 fLine = ""
860 For pNum = 3 To UBound(Param)
861 If LCase(Param(pNum)) = "/wav" Then
862 cType = 2
863 ElseIf LCase(Param(pNum)) = "/c" And cType < 2 Then
864 cType = 1
865 ElseIf LCase(Param(pNum)) = "/auto" And cType < 1 Then
866 cType = -1
867 ElseIf LCase(Param(pNum)) = "/r" Then
868 Rswitch = True
869 End If
870 Next pNum
871 If Left(Param(3), 1) = "/" Or Param(3) = "" Then
872 If InStr(Param(2), "*") <> 0 Or InStr(Param(2), "?") <> 0 Then
873 Param(3) = ""
874 Else
875 Param(3) = Param(2)
876 End If
877 End If
878 If Left(Param(2), 1) <> "/" And Param(2) <> "" Then
879 If InStr(Param(2), "\") > 0 Then
880 For pNum = 1 To Len(Param(2))
881 If InStr(pNum, Param(2), "\") > 0 Then
882 pNum = InStr(pNum, Param(2), "\")
883 Files = Left(Param(2), pNum)
884 End If
885 Next pNum
886 End If
887 MousePointer = 11
888 If NewFile = True Then
889 If FileExists(CD.FileName) Then Kill CD.FileName
890 NewFile = False
891 End If
892 Files = DirEx(Files, Mid(Param(2), Len(Files) + 1), 6, Rswitch)
893 List.Sorted = False
894 FileFilter = mFilter
895 hMPQ = Mpq.mOpenMpq(CD.FileName)
896 If hMPQ = 0 Then
897 StatBar.SimpleText = "Can't create archive " + CD.FileName
898 Exit Sub
899 End If
900 For pNum = 1 To Len(Files)
901 fEndLine = InStr(pNum, Files, vbCrLf)
902 fLine = Mid(Files, pNum, fEndLine - pNum)
903 If cType = 0 Then
904 StatBar.SimpleText = "Adding " + fLine + "..."
905 ElseIf cType = 1 Then
906 StatBar.SimpleText = "Adding compressed " + fLine + "..."
907 ElseIf cType = 2 Then
908 StatBar.SimpleText = "Adding compressed WAV " + fLine + "..."
909 ElseIf cType = -1 Then
910 StatBar.SimpleText = "Adding " + fLine + " (compression auto-select)..."
911 End If
912 If InStr(Param(2), "*") <> 0 Or InStr(Param(2), "?") <> 0 Then
913 If Right(Param(3), 1) <> "\" And Param(3) <> "" Then Param(3) = Param(3) + "\"
914 If cType = 2 Then
915 Mpq.mAddWavFile hMPQ, FullPath(CurPath, fLine), Param(3) + fLine, 0
916 ElseIf cType = -1 Then
917 mAddAutoFile hMPQ, FullPath(CurPath, fLine), Param(3) + fLine
918 ElseIf cType = 1 Then
919 Mpq.mAddFile hMPQ, FullPath(CurPath, fLine), Param(3) + fLine, 1
920 Else
921 Mpq.mAddFile hMPQ, FullPath(CurPath, fLine), Param(3) + fLine, 0
922 End If
923 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
924 mFilter.AddItem "*" + GetExtension(Param(3) + fLine)
925 For cNum = 1 To mFilter.ListCount - 1
926 If LCase(mFilter.List(cNum)) = LCase(mFilter.List(cNum - 1)) Then
927 mFilter.RemoveItem cNum
928 Exit For
929 End If
930 Next cNum
931 If MatchesFilter(Param(3) + fLine, FileFilter) Then
932 ReDim Preserve FileShortNames(UBound(FileShortNames) + 1) As String
933 FileShortNames(UBound(FileShortNames)) = Param(3) + fLine
934 End If
935 Else
936 If cType = 2 Then
937 Mpq.mAddWavFile hMPQ, FullPath(CurPath, fLine), Param(3), 0
938 ElseIf cType = -1 Then
939 mAddAutoFile hMPQ, FullPath(CurPath, fLine), Param(3)
940 ElseIf cType = 1 Then
941 Mpq.mAddFile hMPQ, FullPath(CurPath, fLine), Param(3), 1
942 Else
943 Mpq.mAddFile hMPQ, FullPath(CurPath, fLine), Param(3), 0
944 End If
945 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
946 mFilter.AddItem "*" + GetExtension(Param(3))
947 For cNum = 1 To mFilter.ListCount - 1
948 If LCase(mFilter.List(cNum)) = LCase(mFilter.List(cNum - 1)) Then
949 mFilter.RemoveItem cNum
950 Exit For
951 End If
952 Next cNum
953 If MatchesFilter(Param(3), FileFilter) Then
954 ReDim Preserve FileShortNames(UBound(FileShortNames) + 1) As String
955 FileShortNames(UBound(FileShortNames)) = Param(3)
956 End If
957 End If
958 StatBar.SimpleText = StatBar.SimpleText + " Done"
959 fCount = fCount + 1
960 pNum = fEndLine + 1
961 Next pNum
962 Mpq.mCloseMpq hMPQ
963 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
964 If UBound(FileShortNames) > 1 Then
965 If Mpq.SFileOpenArchive(CD.FileName, 0, 0, hMPQ) Then
966 StatBar.SimpleText = "Adding files to listing... 0% complete"
967 For pNum = 1 To UBound(FileShortNames)
968 If MatchesFilter(FileShortNames(pNum), FileFilter) Then
969 MpqAddToListing hMPQ, FileShortNames(pNum)
970 End If
971 On Error Resume Next
972 StatBar.SimpleText = "Adding files to listing... " + CStr(Int((pNum / UBound(FileShortNames)) * 100)) + "% complete"
973 On Error GoTo 0
974 Next pNum
975 Mpq.SFileCloseArchive hMPQ
976 End If
977 ElseIf UBound(FileShortNames) = 1 Then
978 AddToListing FileShortNames(1)
979 End If
980 MousePointer = 0
981 If MatchesFilter("(listfile)", FileFilter) Then
982 AddToListing "(listfile)"
983 End If
984 mFilter = FileFilter
985 List.Sorted = True
986 RemoveDuplicates
987 ShowTotal
988 If fCount > 1 Then
989 StatBar.SimpleText = CStr(fCount) + " files of " + Param(2) + " added"
990 End If
991 Else
992 StatBar.SimpleText = "Required parameter missing"
993 End If
994 Else
995 StatBar.SimpleText = "No archive open"
996 End If
997 Case "e", "extract"
998 If CD.FileName <> "" Then
999 If InStr(Param(2), "*") = 0 And InStr(Param(2), "?") = 0 Then StatBar.SimpleText = "Extracting " + Param(2) + "..."
1000 cType = 0
1001 For pNum = 3 To UBound(Param)
1002 If LCase(Param(pNum)) = "/fp" Then
1003 cType = 1
1004 Exit For
1005 End If
1006 Next pNum
1007 If Left(Param(3), 1) = "/" Then Param(3) = ""
1008 If Param(3) = "" Then Param(3) = "."
1009 If Left(Param(2), 1) <> "/" And Param(2) <> "" Then
1010 MousePointer = 11
1011 If InStr(Param(2), "*") <> 0 Or InStr(Param(2), "?") <> 0 Then
1012 Files = MpqDir(CD.FileName, Param(2))
1013 If Mpq.SFileOpenArchive(CD.FileName, 0, 0, hMPQ) = 0 Then
1014 StatBar.SimpleText = "Can't open archive " + CD.FileName
1015 Exit Sub
1016 End If
1017 For pNum = 1 To Len(Files)
1018 fEndLine = InStr(pNum, Files, vbCrLf)
1019 fLine = Mid(Files, pNum, fEndLine - pNum)
1020 StatBar.SimpleText = "Extracting " + fLine + "..."
1021 Mpq.sGetFile hMPQ, fLine, FullPath(CurPath, Param(3)), cType
1022 StatBar.SimpleText = StatBar.SimpleText + " Done"
1023 fCount = fCount + 1
1024 pNum = fEndLine + 1
1025 Next pNum
1026 Mpq.SFileCloseArchive hMPQ
1027 If fCount > 1 Then
1028 StatBar.SimpleText = CStr(fCount) + " files of " + Param(2) + " extracted"
1029 End If
1030 Else
1031 Mpq.GetFile CD.FileName, Param(2), FullPath(CurPath, Param(3)), cType
1032 StatBar.SimpleText = StatBar.SimpleText + " Done"
1033 End If
1034 MousePointer = 0
1035 Else
1036 StatBar.SimpleText = "Required parameter missing"
1037 End If
1038 Else
1039 StatBar.SimpleText = "No archive open"
1040 End If
1041 Case "r", "ren", "rename"
1042 If CD.FileName <> "" Then
1043 If InStr(Param(2), "*") = 0 And InStr(Param(2), "?") = 0 Then StatBar.SimpleText = "Renaming " + Param(2) + " => " + Param(3) + "..."
1044 If Param(2) <> "" And Param(3) <> "" Then
1045 If InStr(Param(2), "*") <> 0 Or InStr(Param(2), "?") <> 0 Then
1046 If InStr(Param(3), "*") <> 0 Or InStr(Param(3), "?") <> 0 Then
1047 Files = MpqDir(CD.FileName, Param(2))
1048 For pNum = 1 To Len(Files)
1049 fEndLine = InStr(pNum, Files, vbCrLf)
1050 fLine = Mid(Files, pNum, fEndLine - pNum)
1051 fLine2 = RenameWithFilter(fLine, Param(2), Param(3))
1052 StatBar.SimpleText = "Renaming " + fLine + " => " + fLine2 + "..."
1053 If Mpq.FileExists(CD.FileName, fLine2) Then
1054 Mpq.DelFile CD.FileName, fLine2
1055 Mpq.RenFile CD.FileName, fLine, fLine2
1056 Else
1057 Mpq.RenFile CD.FileName, fLine, fLine2
1058 End If
1059 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
1060 RenameInListing fLine, fLine2
1061 StatBar.SimpleText = StatBar.SimpleText + " Done"
1062 fCount = fCount + 1
1063 pNum = fEndLine + 1
1064 Next pNum
1065 If fCount > 1 Then
1066 StatBar.SimpleText = CStr(fCount) + " files of " + Param(2) + " renamed"
1067 End If
1068 Else
1069 StatBar.SimpleText = "You must use wildcards with new name"
1070 End If
1071 Else
1072 If Mpq.FileExists(CD.FileName, Param(3)) Then
1073 Mpq.DelFile CD.FileName, Param(3)
1074 Mpq.RenFile CD.FileName, Param(2), Param(3)
1075 Else
1076 Mpq.RenFile CD.FileName, Param(2), Param(3)
1077 End If
1078 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
1079 RenameInListing Param(2), Param(3)
1080 StatBar.SimpleText = StatBar.SimpleText + " Done"
1081 End If
1082 Else
1083 StatBar.SimpleText = "Required parameter missing"
1084 End If
1085 Else
1086 StatBar.SimpleText = "No archive open"
1087 End If
1088 Case "m", "move"
1089 If CD.FileName <> "" Then
1090 For pNum = 1 To Len(Param(2))
1091 If InStr(pNum, Param(2), "\") Then
1092 pNum = InStr(pNum, Param(2), "\")
1093 Else
1094 Exit For
1095 End If
1096 Next pNum
1097 fLineTitle = Mid(Param(2), pNum)
1098 If Right(Param(3), 1) <> "\" And Param(3) <> "" Then Param(3) = Param(3) + "\"
1099 Param(3) = Param(3) + fLineTitle
1100 If InStr(Param(2), "*") = 0 And InStr(Param(2), "?") = 0 Then StatBar.SimpleText = "Moving " + Param(2) + " => " + Param(3) + "..."
1101 If (Left(Param(2), 1) <> "/" And Param(2) <> "") And (Left(Param(3), 1) <> "/") Then
1102 If InStr(Param(2), "*") <> 0 Or InStr(Param(2), "?") <> 0 Then
1103 Files = MpqDir(CD.FileName, Param(2))
1104 For pNum = 1 To Len(Files)
1105 fEndLine = InStr(pNum, Files, vbCrLf)
1106 fLine = Mid(Files, pNum, fEndLine - pNum)
1107 fLine2 = RenameWithFilter(fLine, Param(2), Param(3))
1108 StatBar.SimpleText = "Moving " + fLine + " => " + fLine2 + "..."
1109 If Mpq.FileExists(CD.FileName, fLine2) Then
1110 Mpq.DelFile CD.FileName, fLine2
1111 Mpq.RenFile CD.FileName, fLine, fLine2
1112 Else
1113 Mpq.RenFile CD.FileName, fLine, fLine2
1114 End If
1115 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
1116 RenameInListing fLine, fLine2
1117 StatBar.SimpleText = StatBar.SimpleText + " Done"
1118 fCount = fCount + 1
1119 pNum = fEndLine + 1
1120 Next pNum
1121 If fCount > 1 Then
1122 StatBar.SimpleText = CStr(fCount) + " files of " + Param(2) + " moved"
1123 End If
1124 Else
1125 If Mpq.FileExists(CD.FileName, Param(3)) Then
1126 Mpq.DelFile CD.FileName, Param(3)
1127 Mpq.RenFile CD.FileName, Param(2), Param(3)
1128 Else
1129 Mpq.RenFile CD.FileName, Param(2), Param(3)
1130 End If
1131 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
1132 RenameInListing Param(2), Param(3)
1133 StatBar.SimpleText = StatBar.SimpleText + " Done"
1134 End If
1135 Else
1136 StatBar.SimpleText = "Required parameter missing"
1137 End If
1138 Else
1139 StatBar.SimpleText = "No archive open"
1140 End If
1141 Case "d", "del", "delete"
1142 If CD.FileName <> "" Then
1143 If InStr(Param(2), "*") = 0 And InStr(Param(2), "?") = 0 Then StatBar.SimpleText = "Deleting " + Param(2) + "..."
1144 If Left(Param(2), 1) <> "/" And Param(2) <> "" Then
1145 If InStr(Param(2), "*") <> 0 Or InStr(Param(2), "?") <> 0 Then
1146 Files = MpqDir(CD.FileName, Param(2))
1147 For pNum = 1 To Len(Files)
1148 fEndLine = InStr(pNum, Files, vbCrLf)
1149 fLine = Mid(Files, pNum, fEndLine - pNum)
1150 StatBar.SimpleText = "Deleting " + fLine + "..."
1151 Mpq.DelFile CD.FileName, fLine
1152 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
1153 RemoveFromListing fLine
1154 StatBar.SimpleText = StatBar.SimpleText + " Done"
1155 fCount = fCount + 1
1156 pNum = fEndLine + 1
1157 Next pNum
1158 If fCount > 1 Then
1159 StatBar.SimpleText = CStr(fCount) + " files of " + Param(2) + " deleted"
1160 End If
1161 Else
1162 Mpq.DelFile CD.FileName, Param(2)
1163 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
1164 RemoveFromListing Param(2)
1165 StatBar.SimpleText = StatBar.SimpleText + " Done"
1166 End If
1167 Else
1168 StatBar.SimpleText = "Required parameter missing"
1169 End If
1170 Else
1171 StatBar.SimpleText = "No archive open"
1172 End If
1173 Case "f", "flush", "compact"
1174 If CD.FileName <> "" Then
1175 MousePointer = 11
1176 StatBar.SimpleText = "Flushing " + CD.FileName + "..."
1177 Mpq.CompactMpq CD.FileName
1178 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
1179 StatBar.SimpleText = StatBar.SimpleText + " Done"
1180 MousePointer = 0
1181 OpenMpq
1182 Else
1183 StatBar.SimpleText = "No archive open"
1184 End If
1185 Case "l", "list"
1186 If CD.FileName <> "" Then
1187 If Param(2) <> "" Then
1188 StatBar.SimpleText = "Creating list..."
1189 MousePointer = 11
1190 If (InStr(Param(2), "*") <> 0 Or InStr(Param(2), "?") <> 0) And Param(3) <> "" Then
1191 Files = MpqDir(CD.FileName, Param(2))
1192 Param(2) = Param(3)
1193 Else
1194 Files = ListFiles(CD.FileName, ListFile)
1195 End If
1196 fNum = FreeFile
1197 Open FullPath(CurPath, Param(2)) For Binary As #fNum
1198 Put #fNum, 1, Files
1199 Close #fNum
1200 StatBar.SimpleText = StatBar.SimpleText + " Done"
1201 MousePointer = 0
1202 Else
1203 StatBar.SimpleText = "Required parameter missing"
1204 End If
1205 Else
1206 StatBar.SimpleText = "No archive open"
1207 End If
1208 Case "s", "script"
1209 StatBar.SimpleText = "Running script " + Param(2) + "..."
1210 If Param(2) <> "" Then
1211 MousePointer = 11
1212 RunScript FullPath(CurPath, Param(2))
1213 MousePointer = 0
1214 StatBar.SimpleText = StatBar.SimpleText + " Done"
1215 Else
1216 StatBar.SimpleText = "Required parameter missing"
1217 End If
1218 Case "x", "exit", "quit"
1219 Unload Me
1220 Case Else
1221 If Left(Param(1), 1) <> ";" Then
1222 If LCase(Param(1)) = "cd" Or LCase(Param(1)) = "chdir" Then
1223 On Error Resume Next
1224 ChDir Param(2)
1225 On Error GoTo 0
1226 txtCommand_GotFocus
1227 ElseIf Left(LCase(Param(1)), 3) = "cd." Or Left(LCase(Param(1)), 3) = "cd\" Then
1228 On Error Resume Next
1229 ChDir Mid(Param(1), 3)
1230 On Error GoTo 0
1231 txtCommand_GotFocus
1232 ElseIf Left(LCase(Param(1)), 6) = "chdir." Or Left(LCase(Param(1)), 6) = "chdir\" Then
1233 On Error Resume Next
1234 ChDir Mid(Param(1), 6)
1235 On Error GoTo 0
1236 txtCommand_GotFocus
1237 ElseIf Mid(Param(1), 2, 1) = ":" And (Len(Param(1)) = 2 Or Right(Param(1), 1) = "\") Then
1238 On Error Resume Next
1239 ChDrive Left(Param(1), 2)
1240 On Error GoTo 0
1241 txtCommand_GotFocus
1242 Else
1243 Shell "command.com /k " + sLine, 1
1244 End If
1245 End If
1246 End Select
1247 End If
1248 End Sub
1249 Sub BuildRecentFileList()
1250 Dim rNum As Long, rNum2 As Long, RecentFile As String, FirstSep As Long, LastSep As Long, RItem As Menu
1251 For Each RItem In mnuFRecent
1252 If RItem.Index <> 0 Then Unload RItem
1253 Next RItem
1254 rNum2 = 1
1255 For rNum = 8 To 1 Step -1
1256 RecentFile = GetReg(AppKey + "Recent\File" + CStr(rNum))
1257 If FileExists(RecentFile) Then
1258 mnuFRecent(0).Visible = True
1259 On Error Resume Next
1260 Load mnuFRecent(rNum2)
1261 On Error GoTo 0
1262 mnuFRecent(rNum2).Tag = RecentFile
1263 If TextWidth(RecentFile) > TextWidth("________________________________") Then
1264 FirstSep = InStr(RecentFile, "\")
1265 If FirstSep > 0 Then
1266 For LastSep = FirstSep + 1 To Len(RecentFile)
1267 If InStr(LastSep, RecentFile, "\") > 0 Then
1268 LastSep = InStr(LastSep, RecentFile, "\")
1269 Else
1270 Exit For
1271 End If
1272 Next LastSep
1273 RecentFile = Left(RecentFile, FirstSep) + "..." + Mid(RecentFile, LastSep - 1)
1274 End If
1275 End If
1276 mnuFRecent(rNum2).Caption = "&" + CStr(rNum2) + " " + RecentFile
1277 rNum2 = rNum2 + 1
1278 End If
1279 If rNum2 > 4 Then Exit For
1280 Next rNum
1281 End Sub
1282 Sub BuildToolsList()
1283 Dim tNum As Long, ToolName As String, ToolCommand, TItem As Menu
1284 For Each TItem In mnuTItem
1285 If TItem.Index <> 0 Then Unload TItem
1286 Next TItem
1287 mnuTItem(0).Caption = "(Empty)"
1288 mnuTItem(0).Tag = ""
1289 Do
1290 ToolName = GetReg(AppKey + "Tools\Name" + CStr(tNum))
1291 ToolCommand = GetReg(AppKey + "Tools\Command" + CStr(tNum))
1292 If ToolName = "" Then ToolName = ToolCommand
1293 If ToolName <> "" Then
1294 On Error Resume Next
1295 Load mnuTItem(tNum)
1296 On Error GoTo 0
1297 mnuTItem(tNum).Tag = ToolCommand
1298 If InStr(ToolName, "&") = 0 And tNum < 9 Then
1299 mnuTItem(tNum).Caption = "&" + CStr(tNum + 1) + " " + ToolName
1300 ElseIf InStr(ToolName, "&") = 0 And tNum = 9 Then
1301 mnuTItem(tNum).Caption = "&0 " + ToolName
1302 Else
1303 mnuTItem(tNum).Caption = ToolName
1304 End If
1305 End If
1306 tNum = tNum + 1
1307 Loop Until ToolName = ""
1308 End Sub
1309 Sub OpenMpq()
1310 Dim Path, FileCont As String, bNum As Long, FileLine As String, nFiles As Long, LoadExtraInfo As Integer, MpqFileName As String, FileFilter As String, TItem As Menu, hMPQ As Long, hFile As Long
1311 On Error Resume Next
1312 If FileExists(CD.FileName) And FileLen(CD.FileName) = 0 Then
1313 ReDim FileList(0) As String
1314 List.ListItems.Clear
1315 ShowSelected
1316 ShowTotal
1317 NewFile = True
1318 On Error GoTo 0
1319 GoTo FileOpened
1320 End If
1321 On Error GoTo 0
1322 If IsMPQ(CD.FileName) = False Then
1323 CD.FileName = ""
1324 MsgBox "This file does not contain an MPQ archive.", vbExclamation, "WinMPQ"
1325 Exit Sub
1326 End If
1327 If Mpq.SFileOpenArchive(CD.FileName, 0, 0, hMPQ) = 0 Then
1328 CD.FileName = ""
1329 MsgBox "The MPQ archive could not be opened.", vbExclamation, "WinMPQ"
1330 Exit Sub
1331 End If
1332 StatBar.Style = 1
1333 StatBar.SimpleText = "Loading list..."
1334 MousePointer = 11
1335 Path = App.Path: If Right(Path, 1) <> "\" Then Path = Path + "\"
1336 ReDim FileList(0) As String
1337 #If InternalListing Then
1338 FileList(0) = "(listfile)"
1339 If Mpq.FileExists(CD.FileName, "(listfile)") Then
1340 FileCont = Mpq.GetFileEx(CD.FileName, "(listfile)", 0, -1)
1341 #Else
1342 FileCont = sListFiles(CD.FileName, hMPQ, ListFile)
1343 #End If
1344 For bNum = 1 To Len(FileCont)
1345 If InStr(bNum, FileCont, vbCrLf) > 0 Then
1346 ReDim Preserve FileList(UBound(FileList) + 1) As String
1347 FileList(UBound(FileList)) = Mid(FileCont, bNum, InStr(bNum, FileCont, vbCrLf) - bNum)
1348 bNum = InStr(bNum, FileCont, vbCrLf) + 1
1349 Else
1350 ReDim Preserve FileList(UBound(FileList) + 1) As String
1351 FileList(UBound(FileList)) = Mid(FileCont, bNum)
1352 Exit For
1353 End If
1354 Next bNum
1355 #If InternalListing Then
1356 End If
1357 nFiles = UBound(FileList)
1358 ReDim Preserve FileList(UBound(FileList) + UBound(GlobalFileList)) As String
1359 For bNum = nFiles + 1 To UBound(FileList)
1360 FileList(bNum) = GlobalFileList(bNum - nFiles)
1361 Next bNum
1362 #End If
1363 Dim fNum As Long, lIndex As Long, L1 As String, L2 As String, L3 As String, L4 As String, L5 As String, fSize As Long, cSize As Long, fFlags As Long
1364 SendMessageA List.hWnd, WM_SETREDRAW, 0, ByVal 0&
1365 List.ListItems.Clear
1366 List.Sorted = False
1367 LoadExtraInfo = GetReg(AppKey + "LoadExtraInfo", 1)
1368 FileFilter = mFilter
1369 StatBar.SimpleText = "Building list... 0% complete"
1370 For fNum = 1 To UBound(FileList)
1371 #If InternalListing Then
1372 If Mpq.FileExists(CD.FileName, FileList(fNum)) Then
1373 #End If
1374 MpqFileName = FileList(fNum)
1375 mFilter.AddItem "*" + GetExtension(MpqFileName)
1376 For bNum = 1 To mFilter.ListCount - 1
1377 If LCase(mFilter.List(bNum)) = LCase(mFilter.List(bNum - 1)) Then
1378 mFilter.RemoveItem bNum
1379 Exit For
1380 End If
1381 Next bNum
1382 If MatchesFilter(MpqFileName, FileFilter) Then
1383 L1 = FileList(fNum)
1384 If LoadExtraInfo > 0 And FileList(fNum) <> "" Then
1385 If Mpq.SFileOpenFileEx(hMPQ, FileList(fNum), 0, hFile) <> 0 Then
1386 fSize = Mpq.SFileGetFileSize(hFile, 0)
1387 cSize = Mpq.SFileGetFileInfo(hFile, 6)
1388 If fSize / 1024 > 0 And fSize / 1024 < 1 Then
1389 L2 = "<1KB"
1390 ElseIf fSize = 0 Then
1391 L2 = "0KB"
1392 Else
1393 L2 = CStr(Int(fSize / 1024)) + "KB"
1394 End If
1395 If cSize / 1024 > 0 And cSize / 1024 < 1 Then
1396 L4 = "<1KB"
1397 ElseIf cSize = 0 Then
1398 L4 = "0KB"
1399 Else
1400 L4 = CStr(Int(cSize / 1024)) + "KB"
1401 End If
1402 If fSize <> 0 Then
1403 L3 = CStr(Int((1 - cSize / fSize) * 100)) + "%"
1404 Else
1405 L3 = "0%"
1406 End If
1407 fFlags = Mpq.SFileGetFileInfo(hFile, 7)
1408 If (fFlags And &H200) Or (fFlags And &H100) Then L5 = "C" Else L5 = "-"
1409 If fFlags And &H10000 Then L5 = L5 + "E" Else L5 = L5 + "-"
1410 If fFlags And &H20000 Then L5 = L5 + "X" Else L5 = L5 + "-"
1411 Mpq.SFileCloseFile hFile
1412 End If
1413 End If
1414 lIndex = 0
1415 On Error Resume Next
1416 lIndex = List.ListItems.Add(, L1, L1).Index
1417 On Error GoTo 0
1418 If lIndex = 0 Then
1419 lIndex = List.ListItems.Item(L1).Index
1420 List.ListItems.Item(L1).ListSubItems.Clear
1421 End If
1422 List.ListItems.Item(lIndex).Tag = L1
1423 List.ListItems.Item(lIndex).ListSubItems.Add(, , L2).Tag = fSize
1424 If LoadExtraInfo > 0 Then
1425 If fSize <> 0 Then
1426 List.ListItems.Item(lIndex).ListSubItems.Add(, , L3).Tag = Int((1 - cSize / fSize) * 100)
1427 Else
1428 List.ListItems.Item(lIndex).ListSubItems.Add(, , L3).Tag = 0
1429 End If
1430 List.ListItems.Item(lIndex).ListSubItems.Add(, , L4).Tag = cSize
1431 List.ListItems.Item(lIndex).ListSubItems.Add(, , L5).Tag = L5
1432 End If
1433 End If
1434 #If InternalListing Then
1435 End If
1436 #End If
1437 On Error Resume Next
1438 StatBar.SimpleText = "Building list... " + CStr(Int((fNum / UBound(FileList)) * 100)) + "% complete"
1439 On Error GoTo 0
1440 Next fNum
1441 Mpq.SFileCloseArchive hMPQ
1442 List.Sorted = True
1443 #If InternalListing Then
1444 RemoveDuplicates
1445 #End If
1446 On Error Resume Next
1447 List.SelectedItem.Selected = False
1448 On Error GoTo 0
1449 SendMessageA List.hWnd, WM_SETREDRAW, 1, ByVal 0&
1450 ShowSelected
1451 ShowTotal
1452 NewFile = False
1453 mFilter = FileFilter
1454 FileOpened:
1455 ReDim OpenFiles(0) As String, OpenFileDates(0) As Date
1456 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
1457 mnuMpq.Enabled = True
1458 For Each TItem In mnuTItem
1459 TItem.Enabled = True
1460 Next TItem
1461 Toolbar.Buttons.Item("Add").Enabled = True
1462 Toolbar.Buttons.Item("Add Folder").Enabled = True
1463 Toolbar.Buttons.Item("Extract").Enabled = True
1464 Toolbar.Buttons.Item("Compact").Enabled = True
1465 Toolbar.Buttons.Item("List").Enabled = True
1466 StatBar.Style = 0
1467 StatBar.SimpleText = ""
1468 If InStr(CD.FileName, "\") > 0 Then
1469 For bNum = 1 To Len(CD.FileName)
1470 If InStr(bNum, CD.FileName, "\") > 0 Then
1471 bNum = InStr(bNum, CD.FileName, "\")
1472 Else
1473 Exit For
1474 End If
1475 Next bNum
1476 End If
1477 Caption = "WinMPQ - " + Mid(CD.FileName, bNum)
1478 AddRecentFile CD.FileName
1479 MousePointer = 0
1480 End Sub
1481 Sub RemoveDuplicates()
1482 Dim fNum As Long
1483 fNum = 1
1484 Do While fNum <= List.ListItems.Count - 1
1485 If LCase(List.ListItems.Item(fNum).Tag) = LCase(List.ListItems.Item(fNum + 1).Tag) Then
1486 List.ListItems.Remove (fNum)
1487 fNum = fNum - 1
1488 End If
1489 fNum = fNum + 1
1490 Loop
1491 End Sub
1492 Sub ShowSelected()
1493 Dim fNum As Long, nSelect As Long, sSize As Long, fSize As Long, L2 As String
1494 On Error GoTo NotSelected
1495 List.SelectedItem.Tag = List.SelectedItem.Tag
1496 On Error GoTo 0
1497 For fNum = 1 To List.ListItems.Count
1498 If List.ListItems.Item(fNum).Selected Then
1499 nSelect = nSelect + 1
1500 If List.ListItems.Item(fNum).ListSubItems(1).Text <> "" Then
1501 sSize = sSize + List.ListItems.Item(fNum).ListSubItems(1).Tag
1502 Else
1503 fSize = Mpq.FileSize(CD.FileName, List.ListItems.Item(fNum).Tag)
1504 If fSize / 1024 > 0 And fSize / 1024 < 1 Then
1505 L2 = "<1KB"
1506 ElseIf fSize = 0 Then
1507 L2 = "0KB"
1508 Else
1509 L2 = CStr(Int(fSize / 1024)) + "KB"
1510 End If
1511 List.ListItems.Item(fNum).ListSubItems(1).Text = L2
1512 List.ListItems.Item(fNum).ListSubItems(1).Tag = fSize
1513 sSize = sSize + List.ListItems.Item(fNum).ListSubItems(1).Tag
1514 End If
1515 End If
1516 Next fNum
1517 If sSize / 1024 > 0 And sSize / 1024 < 1 Then
1518 StatBar.Panels.Item(1).Text = "Selected " + CStr(nSelect) + " files, <1KB"
1519 ElseIf sSize = 0 Then
1520 StatBar.Panels.Item(1).Text = "Selected " + CStr(nSelect) + " files, 0KB"
1521 Else
1522 StatBar.Panels.Item(1).Text = "Selected " + CStr(nSelect) + " files, " + CStr(Int(sSize / 1024)) + "KB"
1523 End If
1524 Exit Sub
1525 NotSelected:
1526 StatBar.Panels.Item(1).Text = "Selected 0 files, 0KB"
1527 End Sub
1528 Sub ShowTotal()
1529 Dim fNum As Long, nFiles As Long, tSize As Long
1530 For fNum = 1 To List.ListItems.Count
1531 nFiles = nFiles + 1
1532 If List.ListItems.Item(fNum).ListSubItems(1).Text <> "" Then
1533 tSize = tSize + List.ListItems.Item(fNum).ListSubItems(1).Tag
1534 End If
1535 Next fNum
1536 If tSize / 1024 > 0 And tSize / 1024 < 1 Then
1537 StatBar.Panels.Item(2).Text = "Total " + CStr(nFiles) + "/" + CStr(GetNumMpqFiles(CD.FileName)) + " files, <1KB"
1538 Else
1539 StatBar.Panels.Item(2).Text = "Total " + CStr(nFiles) + "/" + CStr(GetNumMpqFiles(CD.FileName)) + " files, " + CStr(Int(tSize / 1024)) + "KB"
1540 End If
1541 End Sub
1542 Private Sub cmdGo_Click()
1543 StatBar.Style = 1
1544 RunMpq2kCommand txtCommand
1545 txtCommand = ""
1546 If StatBar.SimpleText = "" Then txtCommand_GotFocus
1547 End Sub
1548 Private Sub Form_Load()
1549 Dim FileName As String, bNum As Long, CurPath As String, CurPath2 As String, CurPathType As Integer, sLine As String, Param() As String, pNum As Long, EndParam As Long, ParamCutout As String, OldStartPath As String, NewStartPath As String, ErrorText As String
1550 FixIcon hWnd, 1
1551 InitFileDialog CD
1552 CD.hwndOwner = hWnd
1553 CD.DefaultExt = "mpq"
1554 CD.MaxFileSize = 5120
1555 InitFolderDialog PathInput
1556 PathInput.hwndOwner = hWnd
1557 PathInput.Flags = BIF_RETURNONLYFSDIRS
1558 ReDim OpenFiles(0) As String, OpenFileDates(0) As Date
1559 Dim Path
1560 Path = App.Path: If Right(Path, 1) <> "\" Then Path = Path + "\"
1561 ChDir App.Path
1562 If Mpq.MpqInitialize = False Then
1563 ErrorText = "Mpq Control did not initialize properly!" + vbCrLf + "Reason: "
1564 Select Case Mpq.LastError
1565 Case MPQ_ERROR_NO_STAREDIT
1566 ErrorText = ErrorText + "Can't find StarEdit.exe"
1567 Case MPQ_ERROR_BAD_STAREDIT
1568 ErrorText = ErrorText + "Wrong version of StarEdit.exe. Need SC/BW 1.07"
1569 Case MPQ_ERROR_STAREDIT_RUNNING
1570 ErrorText = ErrorText + "StarEdit.exe is running. It must be closed before running this"
1571 Case Else
1572 ErrorText = ErrorText + "Unknown"
1573 End Select
1574 MsgBox ErrorText
1575 End
1576 End If
1577 ExtractPathNum = -1
1578 CopyPathNum = -1
1579 OldStartPath = CurDir
1580 CurPath = GetReg(AppKey + "StartupPath", CurDir)
1581 CurPathType = GetReg(AppKey + "StartupPathType", 0)
1582 If CurPathType < 0 Then CurPathType = 0
1583 If CurPathType > 2 Then CurPathType = 2
1584 If CurPathType = 1 Then
1585 CurPath = App.Path
1586 End If
1587 CurPath2 = CurPath
1588 If Right(CurPath2, 1) <> "\" Then CurPath2 = CurPath2 + "\"
1589 If IsDir(CurPath2) Then
1590 If Mid(CurPath, 2, 1) = ":" Then ChDrive Left(CurPath, 1)
1591 ChDir CurPath
1592 End If
1593 NewStartPath = CurDir
1594 On Error Resume Next
1595 Height = GetReg(AppKey + "Status\WindowHeight", Height)
1596 Left = GetReg(AppKey + "Status\WindowLeft", Left)
1597 Top = GetReg(AppKey + "Status\WindowTop", Top)
1598 Width = GetReg(AppKey + "Status\WindowWidth", Width)
1599 If GetReg(AppKey + "Status\WindowState", WindowState) = 2 Then WindowState = 2 Else WindowState = 0
1600 ListFile = GetReg(AppKey + "ListFile", Path + "mpq_data.txt")
1601 Mpq.DefaultMaxFiles = GetReg(AppKey + "DefaultMaxFiles", 1024)
1602 LocaleID = GetReg(AppKey + "LocaleID", 0)
1603 BuildRecentFileList
1604 BuildToolsList
1605 On Error GoTo 0
1606 Mpq.SetLocale LocaleID
1607 ReDim GlobalFileList(0) As String
1608 #If InternalListing Then
1609 If FileExists(ListFile) Then
1610 Open ListFile For Input As #1
1611 Do While Not EOF(1)
1612 ReDim Preserve GlobalFileList(UBound(GlobalFileList) + 1) As String
1613 Line Input #1, GlobalFileList(UBound(GlobalFileList))
1614 Loop
1615 Close #1
1616 End If
1617 #End If
1618 FileName = Trim(Command)
1619 If Left(FileName, 1) = Chr(34) Then FileName = Mid(FileName, 2)
1620 If Right(FileName, 1) = Chr(34) Then FileName = Left(FileName, Len(FileName) - 1)
1621 FileName = Trim(FileName)
1622 If FileExists(FileName) Then
1623 CD.FileName = FileName
1624 Show
1625 OpenMpq
1626 Exit Sub
1627 End If
1628 ReDim FileList(0) As String
1629 If Right(CurPath, 1) <> "\" Then CurPath = CurPath + "\"
1630 sLine = Command
1631 If Right(sLine, 1) <> " " Then sLine = sLine + " "
1632 If sLine <> "" Then
1633 ReDim Param(0) As String
1634 For pNum = 1 To Len(sLine)
1635 If Mid(sLine, pNum, 1) = Chr(34) Then
1636 pNum = pNum + 1
1637 EndParam = InStr(pNum, sLine, Chr(34))
1638 If UBound(Param) = 1 Then ParamCutout = Mid(sLine, pNum - 1, (EndParam + 1) - (pNum - 1))
1639 Else
1640 EndParam = InStr(pNum, sLine, " ")
1641 If UBound(Param) = 1 Then ParamCutout = Mid(sLine, pNum, EndParam - pNum)
1642 End If
1643 If EndParam = 0 Then EndParam = Len(sLine) + 1
1644 If pNum <> EndParam Then
1645 If Trim(Mid(sLine, pNum, EndParam - pNum)) <> "" Then
1646 ReDim Preserve Param(UBound(Param) + 1) As String
1647 Param(UBound(Param)) = Trim(Mid(sLine, pNum, EndParam - pNum))
1648 End If
1649 End If
1650 pNum = EndParam
1651 Next pNum
1652 If UBound(Param) < 3 Then ReDim Preserve Param(3) As String
1653 Select Case LCase(Param(1))
1654 Case "o", "open", "n", "new"
1655 Show
1656 If Mid(OldStartPath, 2, 1) = ":" Then ChDrive Left(OldStartPath, 1)
1657 ChDir OldStartPath
1658 RunMpq2kCommand sLine
1659 Case "a", "add", "e", "extract", "r", "ren", "rename", "m", "move", "d", "del", "delete", "f", "flush", "compact", "l", "list"
1660 If Mid(OldStartPath, 2, 1) = ":" Then ChDrive Left(OldStartPath, 1)
1661 ChDir OldStartPath
1662 CD.FileName = FullPath(CurDir, Param(2))
1663 sLine = Left(sLine, InStr(sLine, ParamCutout) - 1) + Mid(sLine, InStr(sLine, ParamCutout) + Len(ParamCutout))
1664 RunMpq2kCommand sLine
1665 If Mid(NewStartPath, 2, 1) = ":" Then ChDrive Left(NewStartPath, 1)
1666 ChDir NewStartPath
1667 Unload Me
1668 Case "s", "script"
1669 Show
1670 If Mid(OldStartPath, 2, 1) = ":" Then ChDrive Left(OldStartPath, 1)
1671 ChDir OldStartPath
1672 RunMpq2kCommand sLine
1673 If Mid(NewStartPath, 2, 1) = ":" Then ChDrive Left(NewStartPath, 1)
1674 ChDir NewStartPath
1675 End Select
1676 End If
1677 End Sub
1680 Private Sub Form_Resize()
1681 On Error Resume Next
1682 If WindowState <> 1 Then
1683 List.Top = Toolbar.Height
1684 List.Width = ScaleWidth
1685 List.Height = ScaleHeight - List.Top - StatBar.Height - txtCommand.Height
1686 Label1.Top = List.Top + List.Height + (txtCommand.Height - Label1.Height) / 2
1687 txtCommand.Top = List.Top + List.Height
1688 txtCommand.Left = Label1.Width
1689 txtCommand.Width = ScaleWidth - cmdGo.Width - Label1.Width
1690 cmdGo.Top = txtCommand.Top
1691 cmdGo.Left = txtCommand.Left + txtCommand.Width
1692 mFilter.Width = ScaleWidth - mFilter.Left - Toolbar.Buttons.Item("List").Width
1693 Toolbar.Buttons.Item("filterspace").Width = mFilter.Width
1694 End If
1695 End Sub
1696 Private Sub Form_Unload(Cancel As Integer)
1697 Dim Path As String
1698 Path = App.Path
1699 If Right(Path, 1) <> "\" Then Path = Path + "\"
1700 On Error Resume Next
1701 If ExtractPathNum > -1 Then
1702 KillEx Path + "Temp_extract\" + CStr(ExtractPathNum) + "\", "*", 6, True
1703 RmDir Path + "Temp_extract\" + CStr(ExtractPathNum) + "\"
1704 End If
1705 If DirEx(Path + "Temp_extract\", "*", 6, True) = "" Or App.PrevInstance = False Then
1706 KillEx Path + "Temp_extract\", "*", 6, True
1707 RmDir Path + "Temp_extract\"
1708 End If
1709 If CopyPathNum > -1 Then
1710 KillEx Path + "Temp_copy\" + CStr(CopyPathNum) + "\", "*", 6, True
1711 RmDir Path + "Temp_copy\" + CStr(CopyPathNum) + "\"
1712 End If
1713 If DirEx(Path + "Temp_copy\", "*", 6, True) = "" Or App.PrevInstance = False Then
1714 KillEx Path + "Temp_copy\", "*", 6, True
1715 RmDir Path + "Temp_copy\"
1716 End If
1717 If GetReg(AppKey + "SaveWindowStatus", 1) > 0 Then
1718 NewKey AppKey
1719 NewKey AppKey + "Status\"
1720 If WindowState = 1 Then WindowState = 0
1721 SetReg AppKey + "Status\WindowState", WindowState, REG_DWORD
1722 WindowState = 0
1723 SetReg AppKey + "Status\WindowHeight", Height, REG_DWORD
1724 SetReg AppKey + "Status\WindowLeft", Left, REG_DWORD
1725 SetReg AppKey + "Status\WindowTop", Top, REG_DWORD
1726 SetReg AppKey + "Status\WindowWidth", Width, REG_DWORD
1727 End If
1728 If GetReg(AppKey + "StartupPathType", 0) <= 0 Then
1729 SetReg AppKey + "StartupPath", CurDir
1730 End If
1731 End
1732 End Sub
1733 Private Sub Label1_Click()
1734 txtCommand.SetFocus
1735 End Sub
1736 Private Sub List_AfterLabelEdit(Cancel As Integer, NewString As String)
1737 Dim Result As Long
1738 If List.SelectedItem.Text <> NewString Then
1739 If GetReg(AppKey + "ShowConfirmation", 1) = 0 Then
1740 Result = vbYes
1741 Else
1742 Result = MsgBox("Rename file?", vbYesNo Or vbQuestion Or vbDefaultButton2, "WinMPQ")
1743 End If
1744 If Result = vbYes Then
1745 List.SelectedItem.Tag = NewString
1746 If Mpq.FileExists(CD.FileName, NewString) Then
1747 Mpq.DelFile CD.FileName, NewString
1748 Mpq.RenFile CD.FileName, List.SelectedItem.Text, NewString
1749 RemoveDuplicates
1750 Else
1751 Mpq.RenFile CD.FileName, List.SelectedItem.Text, NewString
1752 End If
1753 On Error Resume Next
1754 List.SelectedItem.Key = NewString
1755 On Error GoTo 0
1756 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
1757 Else
1758 Cancel = True
1759 End If
1760 End If
1761 ShowSelected
1762 End Sub
1763 Private Sub List_Click()
1764 On Error GoTo NotSelected
1765 List.SelectedItem.Tag = List.SelectedItem.Tag
1766 On Error GoTo NotClick
1767 List.HitTest(CX, CY).Tag = List.HitTest(CX, CY).Tag
1768 On Error GoTo 0
1769 ShowSelected
1770 Exit Sub
1771 NotClick:
1772 List.SelectedItem.Selected = False
1773 NotSelected:
1774 ShowSelected
1775 End Sub
1776 Private Sub List_ColumnClick(ByVal ColumnHeader As ColumnHeader)
1777 If List.SortKey = ColumnHeader.Index - 1 Then
1778 If List.SortOrder = 0 Then
1779 List.SortOrder = 1
1780 Else
1781 List.SortOrder = 0
1782 End If
1783 Else
1784 List.SortOrder = 0
1785 List.SortKey = ColumnHeader.Index - 1
1786 End If
1787 End Sub
1788 Private Sub List_DblClick()
1789 Dim fNum As Long, Path As String, fName As String, fName2 As String, bNum As Long, AlreadyInList As Boolean, hMPQ As Long
1790 On Error GoTo NotSelected
1791 List.SelectedItem.Tag = List.SelectedItem.Tag
1792 On Error GoTo NotClick
1793 List.HitTest(CX, CY).Tag = List.HitTest(CX, CY).Tag
1794 On Error GoTo 0
1795 Path = App.Path
1796 If Right(Path, 1) <> "\" Then Path = Path + "\"
1797 Path = Path + "Temp_extract\"
1798 If ExtractPathNum = -1 Then
1799 fNum = 0
1800 Do
1801 If DirEx(Path + CStr(fNum), "*", 6, True) = "" Then Exit Do
1802 fNum = fNum + 1
1803 Loop
1804 ExtractPathNum = fNum
1805 End If
1806 Path = Path + CStr(ExtractPathNum) + "\"
1807 If Mpq.SFileOpenArchive(CD.FileName, 0, 0, hMPQ) = 0 Then Exit Sub
1808 For fNum = 1 To List.ListItems.Count
1809 If List.ListItems.Item(fNum).Selected Then
1810 StatBar.Style = 1
1811 StatBar.SimpleText = "Extracting " + List.ListItems.Item(fNum).Tag + "..."
1812 MousePointer = 11
1813 Mpq.sGetFile hMPQ, List.ListItems.Item(fNum).Tag, Path, True
1814 If GetReg(AppKey + "CheckModDateTime", 1) > 0 Then
1815 For bNum = 1 To UBound(OpenFiles)
1816 If LCase(OpenFiles(bNum)) = LCase(List.ListItems.Item(fNum).Tag) Then
1817 AlreadyInList = True
1818 If FileExists(FullPath(Path, List.ListItems.Item(fNum).Tag)) Then OpenFileDates(bNum) = FileDateTime(FullPath(Path, List.ListItems.Item(fNum).Tag))
1819 Exit For
1820 End If
1821 Next bNum
1822 If AlreadyInList = False Then
1823 ReDim Preserve OpenFiles(UBound(OpenFiles) + 1) As String, OpenFileDates(UBound(OpenFileDates) + 1) As Date
1824 OpenFiles(UBound(OpenFiles)) = List.ListItems.Item(fNum).Tag
1825 If FileExists(FullPath(Path, List.ListItems.Item(fNum).Tag)) Then OpenFileDates(UBound(OpenFileDates)) = FileDateTime(FullPath(Path, List.ListItems.Item(fNum).Tag))
1826 End If
1827 End If
1828 StatBar.Style = 1
1829 StatBar.SimpleText = "Opening " + List.ListItems.Item(fNum).Tag + "..."
1830 fName = List.ListItems.Item(fNum).Tag
1831 BuildPopup Path + fName, 0
1832 ExecuteFile Path + fName, 0
1833 If GetReg(AppKey + "CheckModDateTime", 1) > 0 Then Timer1.Enabled = True
1834 End If
1835 Next fNum
1836 Mpq.SFileCloseArchive hMPQ
1837 StatBar.Style = 0
1838 StatBar.SimpleText = ""
1839 MousePointer = 0
1840 Exit Sub
1841 NotClick:
1842 List.SelectedItem.Selected = False
1843 NotSelected:
1844 End Sub
1845 Private Sub List_KeyPress(KeyAscii As Integer)
1846 If KeyAscii = 13 Then List_DblClick
1847 End Sub
1848 Private Sub List_KeyUp(KeyCode As Integer, Shift As Integer)
1849 If KeyCode = vbKeyDelete Then
1850 mnuMDelete_Click
1851 ElseIf KeyCode = 93 Or ((Shift And vbShiftMask) And KeyCode = vbKeyF10) Then
1852 On Error GoTo NotSelected
1853 List.SelectedItem.Tag = List.SelectedItem.Tag
1854 On Error GoTo 0
1855 If List.SelectedItem.Selected = True Then
1856 BuildPopup List.SelectedItem.Tag, Shift
1857 PopupMenu mnuPopup, vbPopupMenuRightButton, List.Left + List.SelectedItem.Left + 12 * Screen.TwipsPerPixelX, List.Top + List.SelectedItem.Top + 16 * Screen.TwipsPerPixelY, mnuPItem(0)
1858 End If
1859 End If
1860 NotSelected:
1861 End Sub
1862 Private Sub List_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
1863 CX = x
1864 CY = y
1865 If Button And vbRightButton Then
1866 On Error GoTo NotSelected
1867 List.SelectedItem.Tag = List.SelectedItem.Tag
1868 On Error GoTo NotClick
1869 List.HitTest(CX, CY).Tag = List.HitTest(CX, CY).Tag
1870 On Error GoTo 0
1871 BuildPopup List.SelectedItem.Tag, Shift
1872 PopupMenu mnuPopup, vbPopupMenuRightButton, , , mnuPItem(0)
1873 End If
1874 NotClick:
1875 NotSelected:
1876 End Sub
1877 Private Sub List_OLECompleteDrag(Effect As Long)
1878 List.Tag = ""
1879 End Sub
1880 Private Sub List_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
1881 Dim Files() As String, ShortFiles() As String, bNum As Long, fNum As Long, Path As String, FolderFiles As String, Path2 As String, cNum As Long, FileFilter As String
1882 Dim lIndex As Long, L1 As String, L2 As String, L3 As String, L4 As String, L5 As String, fSize As Long, cSize As Long, fFlags As Long, hMPQ As Long
1883 If Data.GetFormat(ccCFFiles) <> True Then Exit Sub
1884 For fNum = 1 To Data.Files.Count
1885 Path = Data.Files.Item(fNum)
1886 If Right(Path, 1) <> "\" Then Path = Path + "\"
1887 If IsDir(Path) Then
1888 Path = Path + "*"
1889 Data.Files.Remove fNum
1890 Data.Files.Add Path, fNum
1891 End If
1892 Next fNum
1893 Path = Data.Files.Item(1)
1894 For bNum = 1 To Len(Path)
1895 If InStr(bNum, Path, "\") > 0 Then
1896 For fNum = 1 To Data.Files.Count
1897 If Left(Data.Files.Item(fNum), InStr(bNum, Path, "\")) <> Left(Path, InStr(bNum, Path, "\")) Then GoTo PathFound
1898 Next fNum
1899 bNum = InStr(bNum, Path, "\")
1900 Else
1901 Exit For
1902 End If
1903 Next bNum
1904 PathFound:
1905 Path = Left(Path, bNum - 1)
1906 ReDim Files(0) As String
1907 Files(0) = Path
1908 If Right(Path, 1) <> "\" Then Path = Path + "\"
1909 ReDim Preserve Files(Data.Files.Count) As String
1910 For bNum = 1 To Data.Files.Count
1911 Files(bNum) = Mid(Data.Files.Item(bNum), 1 + Len(Path))
1912 For fNum = 1 To Len(Files(bNum))
1913 If InStr(fNum, Files(bNum), "\") > 0 Then
1914 fNum = InStr(fNum, Files(bNum), "\")
1915 Else
1916 Exit For
1917 End If
1918 Next fNum
1919 FolderFiles = FolderFiles + DirEx(Path + Left(Files(bNum), fNum - 1), Mid(Files(bNum), fNum), 6, True)
1920 Next bNum
1921 If FolderFiles = "" Then Exit Sub
1922 ReDim Preserve Files(0) As String
1923 For bNum = 1 To Len(FolderFiles)
1924 ReDim Preserve Files(UBound(Files) + 1) As String
1925 If InStr(bNum, FolderFiles, vbCrLf) > 0 Then
1926 Files(UBound(Files)) = Mid(FolderFiles, bNum + Len(Path), InStr(bNum, FolderFiles, vbCrLf) - bNum - Len(Path))
1927 bNum = InStr(bNum, FolderFiles, vbCrLf) + 1
1928 Else
1929 Files(UBound(Files)) = Mid(FolderFiles, bNum + Len(Path))
1930 Exit For
1931 End If
1932 Next bNum
1933 FoldName.Show 1
1934 If UBound(Files) > 1 Then
1935 ReDim ShortFiles(UBound(Files)) As String
1936 For bNum = 0 To UBound(Files)
1937 ShortFiles(bNum) = AddFolderName + Files(bNum)
1938 Next bNum
1939 If Right(Files(0), 1) <> "\" Then Files(0) = Files(0) + "\"
1940 For bNum = 1 To UBound(Files)
1941 Files(bNum) = FullPath(Files(0), Files(bNum))
1942 Next bNum
1943 Else
1944 For bNum = 1 To Len(Files(1))
1945 If InStr(bNum, Files(1), "\") > 0 Then
1946 bNum = InStr(bNum, Files(1), "\")
1947 Else
1948 Exit For
1949 End If
1950 Next bNum
1951 ReDim ShortFiles(UBound(Files)) As String
1952 ShortFiles(1) = AddFolderName + Mid(Files(1), bNum)
1953 Files(1) = FullPath(Files(0), Files(1))
1954 End If
1955 If NewFile = True Then
1956 If FileExists(CD.FileName) Then Kill CD.FileName
1957 NewFile = False
1958 End If
1959 List.Sorted = False
1960 FileFilter = mFilter
1961 hMPQ = Mpq.mOpenMpq(CD.FileName)
1962 If hMPQ = 0 Then
1963 StatBar.SimpleText = "Can't create archive " + CD.FileName
1964 Exit Sub
1965 End If
1966 For bNum = 1 To UBound(Files)
1967 StatBar.Style = 1
1968 StatBar.SimpleText = "Adding " + Files(bNum) + "..."
1969 MousePointer = 11
1970 If mnuMCNone.Checked Then
1971 Mpq.mAddFile hMPQ, Files(bNum), ShortFiles(bNum), 0
1972 ElseIf mnuMCStandard.Checked Then
1973 Mpq.mAddFile hMPQ, Files(bNum), ShortFiles(bNum), 1
1974 ElseIf mnuMCAMedium.Checked Then
1975 Mpq.mAddWavFile hMPQ, Files(bNum), ShortFiles(bNum), 0
1976 ElseIf mnuMCAHighest.Checked Then
1977 Mpq.mAddWavFile hMPQ, Files(bNum), ShortFiles(bNum), 1
1978 ElseIf mnuMCALowest.Checked Then
1979 Mpq.mAddWavFile hMPQ, Files(bNum), ShortFiles(bNum), 2
1980 ElseIf mnuMCAuto.Checked Then
1981 mAddAutoFile hMPQ, Files(bNum), ShortFiles(bNum)
1982 End If
1983 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
1984 mFilter.AddItem "*" + GetExtension(ShortFiles(bNum))
1985 For cNum = 1 To mFilter.ListCount - 1
1986 If LCase(mFilter.List(cNum)) = LCase(mFilter.List(cNum - 1)) Then
1987 mFilter.RemoveItem cNum
1988 Exit For
1989 End If
1990 Next cNum
1991 Next bNum
1992 Mpq.mCloseMpq hMPQ
1993 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
1994 If Mpq.SFileOpenArchive(CD.FileName, 0, 0, hMPQ) Then
1995 StatBar.SimpleText = "Adding files to listing... 0% complete"
1996 For bNum = 1 To UBound(Files)
1997 If MatchesFilter(ShortFiles(bNum), FileFilter) Then
1998 MpqAddToListing hMPQ, ShortFiles(bNum)
1999 End If
2000 On Error Resume Next
2001 StatBar.SimpleText = "Adding files to listing... " + CStr(Int((bNum / UBound(Files)) * 100)) + "% complete"
2002 On Error GoTo 0
2003 Next bNum
2004 Mpq.SFileCloseArchive hMPQ
2005 End If
2006 StatBar.Style = 0
2007 StatBar.SimpleText = ""
2008 MousePointer = 0
2009 If MatchesFilter("(listfile)", FileFilter) Then
2010 AddToListing "(listfile)"
2011 End If
2012 mFilter = FileFilter
2013 List.Sorted = True
2014 RemoveDuplicates
2015 ShowTotal
2016 Cancel:
2017 End Sub
2018 Private Sub List_OLEDragOver(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single, State As Integer)
2019 If CD.FileName = "" Or Data.GetFormat(ccCFFiles) <> True Or List.Tag = "WinMPQ" Then
2020 Effect = ccOLEDropEffectNone
2021 Else
2022 Effect = ccOLEDropEffectCopy
2023 End If
2024 End Sub
2025 Private Sub List_OLESetData(Data As MSComctlLib.DataObject, DataFormat As Integer)
2026 Dim fNum As Long, Path As String, fCount As Long, FirstFile As String, hMPQ As Long
2027 Path = App.Path
2028 If Right(Path, 1) <> "\" Then Path = Path + "\"
2029 Path = Path + "Temp_copy\"
2030 If CopyPathNum = -1 Then
2031 fNum = 0
2032 Do
2033 If DirEx(Path + CStr(fNum), "*", 6, True) = "" Then Exit Do
2034 fNum = fNum + 1
2035 Loop
2036 CopyPathNum = fNum
2037 End If
2038 Path = Path + CStr(CopyPathNum) + "\"
2039 KillEx Path, "*", 6, True
2040 fCount = 0
2041 If Mpq.SFileOpenArchive(CD.FileName, 0, 0, hMPQ) = 0 Then Exit Sub
2042 For fNum = 1 To List.ListItems.Count
2043 If List.ListItems.Item(fNum).Selected Then
2044 StatBar.Style = 1
2045 StatBar.SimpleText = "Extracting " + List.ListItems.Item(fNum).Tag + "..."
2046 MousePointer = 11
2047 Mpq.sGetFile hMPQ, List.ListItems.Item(fNum).Tag, Path, True
2048 If GetReg(AppKey + "UseDragDropWildcards", 1) = 0 Then
2049 Data.Files.Add Path + List.ListItems.Item(fNum).Tag
2050 End If
2051 fCount = fCount + 1
2052 If fCount = 1 Then FirstFile = Path + List.ListItems.Item(fNum).Tag
2053 End If
2054 Next fNum
2055 Mpq.SFileCloseArchive hMPQ
2056 StatBar.Style = 0
2057 StatBar.SimpleText = ""
2058 MousePointer = 0
2059 If GetReg(AppKey + "UseDragDropWildcards", 1) <> 0 And fCount > 1 Then
2060 Data.Files.Add Path + "*"
2061 ElseIf fCount = 1 Then
2062 Data.Files.Add FirstFile
2063 End If
2064 End Sub
2065 Private Sub List_OLEStartDrag(Data As MSComctlLib.DataObject, AllowedEffects As Long)
2066 Data.SetData , ccCFFiles
2067 AllowedEffects = ccOLEDropEffectCopy
2068 List.Tag = "WinMPQ"
2069 End Sub
2070 Private Sub mFilter_KeyPress(KeyAscii As Integer)
2071 If KeyAscii = 13 And Toolbar.Buttons.Item("List").Enabled Then
2072 If NewFile = False Then OpenMpq
2073 End If
2074 End Sub
2075 Private Sub mnuFExit_Click()
2076 Unload Me
2077 End Sub
2078 Private Sub mnuFile_Click()
2079 If FileExists(CD.FileName) Then mnuFReopen.Enabled = True Else mnuFReopen.Enabled = False
2080 End Sub
2082 Private Sub mnuFRecent_Click(Index As Integer)
2083 Dim OldFileName As String
2084 OldFileName = CD.FileName
2085 CD.FileName = mnuFRecent(Index).Tag
2086 If FileExists(CD.FileName) = False Then
2087 CD.FileName = OldFileName
2088 MsgBox "The file " + Chr(34) + mnuFRecent(Index).Tag + Chr(34) + " does not exist.", vbExclamation, "WinMPQ"
2089 DelRecentFile mnuFRecent(Index).Tag
2090 Exit Sub
2091 End If
2092 OpenMpq
2093 If CD.FileName = "" Then
2094 CD.FileName = OldFileName
2095 DelRecentFile mnuFRecent(Index).Tag
2096 End If
2097 End Sub
2098 Private Sub mnuFReopen_Click()
2099 OpenMpq
2100 End Sub
2102 Private Sub mnuFScript_Click()
2103 Dim OldFileName As String, OldPath As String
2104 CD.Flags = &H1000 Or &H4 Or &H2
2105 CD.Filter = "All Files (*.*)|*.*"
2106 OldFileName = CD.FileName
2107 OldPath = CurDir
2108 If ShowOpen(CD) = False Then GoTo Cancel
2109 StatBar.Style = 1
2110 StatBar.SimpleText = "Running script " + CD.FileName + "..."
2111 MousePointer = 11
2112 RunScript CD.FileName
2113 StatBar.Style = 0
2114 StatBar.SimpleText = ""
2115 MousePointer = 0
2116 CD.FileName = OldFileName
2117 Cancel:
2118 If Mid(OldPath, 2, 1) = ":" Then ChDrive Left(OldPath, 1)
2119 ChDir OldPath
2120 End Sub
2121 Private Sub mnuHAbout_Click()
2122 About.Show 1
2123 End Sub
2124 Private Sub mnuHReadme_Click()
2125 Dim Path As String
2126 Path = App.Path
2127 If Right(Path, 1) <> "\" Then Path = Path + "\"
2128 If FileExists(Path + "WinMPQ.rtf") Then
2129 ShellExecute hWnd, vbNullString, Path + "WinMPQ.rtf", vbNullString, vbNullString, 1
2130 Else
2131 MsgBox "Could not find WinMPQ.rtf!", vbCritical, "WinMPQ"
2132 End If
2133 End Sub
2134 Private Sub mnuMAdd_Click()
2135 Dim Files() As String, ShortFiles() As String, bNum As Long, OldFileName As String, fNum As Long, cNum As Long, FileFilter As String
2136 Dim lIndex As Long, L1 As String, L2 As String, L3 As String, L4 As String, L5 As String, fSize As Long, cSize As Long, fFlags As Long, hMPQ As Long
2137 CD.Flags = OFN_EXPLORER Or &H1000 Or &H200 Or &H4 Or &H2
2138 CD.Filter = "All Files (*.*)|*.*"
2139 OldFileName = CD.FileName
2140 If ShowOpen(CD) = False Then GoTo Cancel
2141 ReDim Files(0) As String
2142 bNum = 1
2143 If InStr(1, CD.FileName, Chr(0)) > 0 Then
2144 Files(0) = Mid(CD.FileName, 1, InStr(1, CD.FileName, Chr(0)) - 1)
2145 bNum = InStr(1, CD.FileName, Chr(0)) + 1
2146 Else
2147 Files(0) = Mid(CD.FileName, 1)
2148 End If
2149 For bNum = bNum To Len(CD.FileName)
2150 ReDim Preserve Files(UBound(Files) + 1) As String
2151 If InStr(bNum, CD.FileName, Chr(0)) > 0 Then
2152 Files(UBound(Files)) = Mid(CD.FileName, bNum, InStr(bNum, CD.FileName, Chr(0)) - bNum)
2153 bNum = InStr(bNum, CD.FileName, Chr(0))
2154 Else
2155 Files(UBound(Files)) = Mid(CD.FileName, bNum)
2156 Exit For
2157 End If
2158 Next bNum
2159 CD.FileName = OldFileName
2160 FoldName.Show 1
2161 If UBound(Files) > 1 Then
2162 ReDim ShortFiles(UBound(Files)) As String
2163 For bNum = 0 To UBound(Files)
2164 ShortFiles(bNum) = AddFolderName + Files(bNum)
2165 Next bNum
2166 If Right(Files(0), 1) <> "\" Then Files(0) = Files(0) + "\"
2167 For bNum = 1 To UBound(Files)
2168 Files(bNum) = FullPath(Files(0), Files(bNum))
2169 Next bNum
2170 Else
2171 For bNum = 1 To Len(Files(1))
2172 If InStr(bNum, Files(1), "\") > 0 Then
2173 bNum = InStr(bNum, Files(1), "\")
2174 Else
2175 Exit For
2176 End If
2177 Next bNum
2178 ReDim ShortFiles(UBound(Files)) As String
2179 ShortFiles(1) = AddFolderName + Mid(Files(1), bNum)
2180 Files(1) = FullPath(Files(0), Files(1))
2181 End If
2182 If NewFile = True Then
2183 If FileExists(CD.FileName) Then Kill CD.FileName
2184 NewFile = False
2185 End If
2186 List.Sorted = False
2187 FileFilter = mFilter
2188 hMPQ = Mpq.mOpenMpq(CD.FileName)
2189 If hMPQ = 0 Then
2190 StatBar.SimpleText = "Can't create archive " + CD.FileName
2191 Exit Sub
2192 End If
2193 For bNum = 1 To UBound(Files)
2194 StatBar.Style = 1
2195 StatBar.SimpleText = "Adding " + Files(bNum) + "..."
2196 MousePointer = 11
2197 If mnuMCNone.Checked Then
2198 Mpq.mAddFile hMPQ, Files(bNum), ShortFiles(bNum), 0
2199 ElseIf mnuMCStandard.Checked Then
2200 Mpq.mAddFile hMPQ, Files(bNum), ShortFiles(bNum), 1
2201 ElseIf mnuMCAMedium.Checked Then
2202 Mpq.mAddWavFile hMPQ, Files(bNum), ShortFiles(bNum), 0
2203 ElseIf mnuMCAHighest.Checked Then
2204 Mpq.mAddWavFile hMPQ, Files(bNum), ShortFiles(bNum), 1
2205 ElseIf mnuMCALowest.Checked Then
2206 Mpq.mAddWavFile hMPQ, Files(bNum), ShortFiles(bNum), 2
2207 ElseIf mnuMCAuto.Checked Then
2208 mAddAutoFile hMPQ, Files(bNum), ShortFiles(bNum)
2209 End If
2210 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
2211 mFilter.AddItem "*" + GetExtension(ShortFiles(bNum))
2212 For cNum = 1 To mFilter.ListCount - 1
2213 If LCase(mFilter.List(cNum)) = LCase(mFilter.List(cNum - 1)) Then
2214 mFilter.RemoveItem cNum
2215 Exit For
2216 End If
2217 Next cNum
2218 Next bNum
2219 Mpq.mCloseMpq hMPQ
2220 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
2221 If Mpq.SFileOpenArchive(CD.FileName, 0, 0, hMPQ) Then
2222 StatBar.SimpleText = "Adding files to listing... 0% complete"
2223 For bNum = 1 To UBound(Files)
2224 If MatchesFilter(ShortFiles(bNum), FileFilter) Then
2225 MpqAddToListing hMPQ, ShortFiles(bNum)
2226 End If
2227 On Error Resume Next
2228 StatBar.SimpleText = "Adding files to listing... " + CStr(Int((bNum / UBound(Files)) * 100)) + "% complete"
2229 On Error GoTo 0
2230 Next bNum
2231 Mpq.SFileCloseArchive hMPQ
2232 End If
2233 StatBar.Style = 0
2234 StatBar.SimpleText = ""
2235 MousePointer = 0
2236 If MatchesFilter("(listfile)", FileFilter) Then
2237 AddToListing "(listfile)"
2238 End If
2239 mFilter = FileFilter
2240 List.Sorted = True
2241 RemoveDuplicates
2242 ShowTotal
2243 Cancel:
2244 End Sub
2245 Private Sub mnuMAddFolder_Click()
2246 Dim Files() As String, ShortFiles() As String, bNum As Long, fNum As Long, Path As String, FolderFiles As String, cNum As Long, FileFilter As String, hMPQ As Long
2247 Dim lIndex As Long, L1 As String, L2 As String, L3 As String, L4 As String, L5 As String, fSize As Long, cSize As Long, fFlags As Long
2248 Path = PathInputBox(PathInput, "Folder to add files from...", CurDir)
2249 If Path = "" Then GoTo Cancel
2250 FolderFiles = DirEx(Path, "*", 6, True)
2251 If FolderFiles = "" Then Exit Sub
2252 ReDim Files(0) As String
2253 Files(0) = Path
2254 If Right(Path, 1) <> "\" Then Path = Path + "\"
2255 For bNum = 1 To Len(FolderFiles)
2256 ReDim Preserve Files(UBound(Files) + 1) As String
2257 If InStr(bNum, FolderFiles, vbCrLf) > 0 Then
2258 Files(UBound(Files)) = Mid(FolderFiles, bNum + Len(Path), InStr(bNum, FolderFiles, vbCrLf) - bNum - Len(Path))
2259 bNum = InStr(bNum, FolderFiles, vbCrLf) + 1
2260 Else
2261 Files(UBound(Files)) = Mid(FolderFiles, bNum + Len(Path))
2262 Exit For
2263 End If
2264 Next bNum
2265 FoldName.Show 1
2266 If UBound(Files) > 1 Then
2267 ReDim ShortFiles(UBound(Files)) As String
2268 For bNum = 0 To UBound(Files)
2269 ShortFiles(bNum) = AddFolderName + Files(bNum)
2270 Next bNum
2271 If Right(Files(0), 1) <> "\" Then Files(0) = Files(0) + "\"
2272 For bNum = 1 To UBound(Files)
2273 Files(bNum) = FullPath(Files(0), Files(bNum))
2274 Next bNum
2275 Else
2276 For bNum = 1 To Len(Files(1))
2277 If InStr(bNum, Files(1), "\") > 0 Then
2278 bNum = InStr(bNum, Files(1), "\")
2279 Else
2280 Exit For
2281 End If
2282 Next bNum
2283 ReDim ShortFiles(UBound(Files)) As String
2284 ShortFiles(1) = AddFolderName + Mid(Files(1), bNum)
2285 Files(1) = FullPath(Files(0), Files(1))
2286 End If
2287 If NewFile = True Then
2288 If FileExists(CD.FileName) Then Kill CD.FileName
2289 NewFile = False
2290 End If
2291 List.Sorted = False
2292 FileFilter = mFilter
2293 hMPQ = Mpq.mOpenMpq(CD.FileName)
2294 If hMPQ = 0 Then
2295 StatBar.SimpleText = "Can't create archive " + CD.FileName
2296 Exit Sub
2297 End If
2298 For bNum = 1 To UBound(Files)
2299 StatBar.Style = 1
2300 StatBar.SimpleText = "Adding " + Files(bNum) + "..."
2301 MousePointer = 11
2302 If mnuMCNone.Checked Then
2303 Mpq.mAddFile hMPQ, Files(bNum), ShortFiles(bNum), 0
2304 ElseIf mnuMCStandard.Checked Then
2305 Mpq.mAddFile hMPQ, Files(bNum), ShortFiles(bNum), 1
2306 ElseIf mnuMCAMedium.Checked Then
2307 Mpq.mAddWavFile hMPQ, Files(bNum), ShortFiles(bNum), 0
2308 ElseIf mnuMCAHighest.Checked Then
2309 Mpq.mAddWavFile hMPQ, Files(bNum), ShortFiles(bNum), 1
2310 ElseIf mnuMCALowest.Checked Then
2311 Mpq.mAddWavFile hMPQ, Files(bNum), ShortFiles(bNum), 2
2312 ElseIf mnuMCAuto.Checked Then
2313 mAddAutoFile hMPQ, Files(bNum), ShortFiles(bNum)
2314 End If
2315 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
2316 mFilter.AddItem "*" + GetExtension(ShortFiles(bNum))
2317 For cNum = 1 To mFilter.ListCount - 1
2318 If LCase(mFilter.List(cNum)) = LCase(mFilter.List(cNum - 1)) Then
2319 mFilter.RemoveItem cNum
2320 Exit For
2321 End If
2322 Next cNum
2323 Next bNum
2324 Mpq.mCloseMpq hMPQ
2325 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
2326 If Mpq.SFileOpenArchive(CD.FileName, 0, 0, hMPQ) Then
2327 StatBar.SimpleText = "Adding files to listing... 0% complete"
2328 For bNum = 1 To UBound(Files)
2329 If MatchesFilter(ShortFiles(bNum), FileFilter) Then
2330 MpqAddToListing hMPQ, ShortFiles(bNum)
2331 End If
2332 On Error Resume Next
2333 StatBar.SimpleText = "Adding files to listing... " + CStr(Int((bNum / UBound(Files)) * 100)) + "% complete"
2334 On Error GoTo 0
2335 Next bNum
2336 Mpq.SFileCloseArchive hMPQ
2337 End If
2338 StatBar.Style = 0
2339 StatBar.SimpleText = ""
2340 MousePointer = 0
2341 If MatchesFilter("(listfile)", FileFilter) Then
2342 AddToListing "(listfile)"
2343 End If
2344 mFilter = FileFilter
2345 List.Sorted = True
2346 RemoveDuplicates
2347 ShowTotal
2348 Cancel:
2349 End Sub
2350 Private Sub mnuMCAHighest_Click()
2351 mnuMCNone.Checked = False
2352 mnuMCStandard.Checked = False
2353 mnuMCALowest.Checked = False
2354 mnuMCAMedium.Checked = False
2355 mnuMCAHighest.Checked = True
2356 mnuMCAuto.Checked = False
2357 End Sub
2358 Private Sub mnuMCALowest_Click()
2359 mnuMCNone.Checked = False
2360 mnuMCStandard.Checked = False
2361 mnuMCALowest.Checked = True
2362 mnuMCAMedium.Checked = False
2363 mnuMCAHighest.Checked = False
2364 mnuMCAuto.Checked = False
2365 End Sub
2368 Private Sub mnuMCAMedium_Click()
2369 mnuMCNone.Checked = False
2370 mnuMCStandard.Checked = False
2371 mnuMCALowest.Checked = False
2372 mnuMCAMedium.Checked = True
2373 mnuMCAHighest.Checked = False
2374 mnuMCAuto.Checked = False
2375 End Sub
2377 Private Sub mnuMCAuto_Click()
2378 mnuMCNone.Checked = False
2379 mnuMCStandard.Checked = False
2380 mnuMCALowest.Checked = False
2381 mnuMCAMedium.Checked = False
2382 mnuMCAHighest.Checked = False
2383 mnuMCAuto.Checked = True
2384 End Sub
2386 Private Sub mnuMCNone_Click()
2387 mnuMCNone.Checked = True
2388 mnuMCStandard.Checked = False
2389 mnuMCALowest.Checked = False
2390 mnuMCAMedium.Checked = False
2391 mnuMCAHighest.Checked = False
2392 mnuMCAuto.Checked = False
2393 End Sub
2395 Private Sub mnuMCompact_Click()
2396 Dim fNum As Long, Result As Long
2397 If GetReg(AppKey + "ShowConfirmation", 1) = 0 Then
2398 Result = vbYes
2399 Else
2400 Result = MsgBox("Uncompressed files with an 'X' in the attributes column and are not" + vbCrLf + "listed in (listfile) may be corrupted or deleted by the compacting process." + vbCrLf + "(Note: These files are fairly rare) Continue with compact?", vbYesNo Or vbQuestion Or vbDefaultButton2, "WinMPQ")
2401 End If
2402 If Result = vbYes Then
2403 StatBar.Style = 1
2404 StatBar.SimpleText = "Compacting " + CD.FileName + "..."
2405 MousePointer = 11
2406 Mpq.CompactMpq CD.FileName
2407 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
2408 StatBar.Style = 0
2409 StatBar.SimpleText = ""
2410 MousePointer = 0
2411 OpenMpq
2412 End If
2413 End Sub
2414 Private Sub mnuMCStandard_Click()
2415 mnuMCNone.Checked = False
2416 mnuMCStandard.Checked = True
2417 mnuMCALowest.Checked = False
2418 mnuMCAMedium.Checked = False
2419 mnuMCAHighest.Checked = False
2420 End Sub
2421 Private Sub mnuMDelete_Click()
2422 Dim fNum As Long, Result As Long
2423 On Error GoTo NotSelected
2424 List.SelectedItem.Tag = List.SelectedItem.Tag
2425 On Error GoTo 0
2426 For fNum = 1 To List.ListItems.Count
2427 If List.ListItems.Item(fNum).Selected Then
2428 GoTo FileSelected
2429 End If
2430 Next fNum
2431 GoTo NotSelected
2432 FileSelected:
2433 If GetReg(AppKey + "ShowConfirmation", 1) = 0 Then
2434 Result = vbYes
2435 Else
2436 Result = MsgBox("Delete file(s)?", vbYesNo Or vbQuestion Or vbDefaultButton2, "WinMPQ")
2437 End If
2438 If Result = vbYes Then
2439 fNum = 1
2440 Do While fNum <= List.ListItems.Count
2441 If List.ListItems.Item(fNum).Selected Then
2442 StatBar.Style = 1
2443 StatBar.SimpleText = "Deleting " + List.ListItems.Item(fNum).Tag + "..."
2444 MousePointer = 11
2445 Mpq.DelFile CD.FileName, List.ListItems.Item(fNum).Tag
2446 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
2447 List.ListItems.Remove (fNum)
2448 fNum = fNum - 1
2449 End If
2450 fNum = fNum + 1
2451 Loop
2452 End If
2453 StatBar.Style = 0
2454 StatBar.SimpleText = ""
2455 MousePointer = 0
2456 ShowSelected
2457 ShowTotal
2458 Exit Sub
2459 NotSelected:
2460 MsgBox "No files are selected.", , "WinMPQ"
2461 End Sub
2462 Private Sub mnuMExtract_Click()
2463 Dim fNum As Long, Path As String, Result As Long, hMPQ As Long
2464 On Error GoTo NotSelected
2465 List.SelectedItem.Tag = List.SelectedItem.Tag
2466 On Error GoTo 0
2467 For fNum = 1 To List.ListItems.Count
2468 If List.ListItems.Item(fNum).Selected Then
2469 GoTo FileSelected
2470 End If
2471 Next fNum
2472 GoTo NotSelected
2473 FileSelected:
2474 Path = PathInputBox(PathInput, "Extract file(s) to...", CurDir)
2475 If Path = "" Then Exit Sub
2476 If Right(Path, 1) <> "\" Then Path = Path + "\"
2477 If Mpq.SFileOpenArchive(CD.FileName, 0, 0, hMPQ) = 0 Then Exit Sub
2478 For fNum = 1 To List.ListItems.Count
2479 If List.ListItems.Item(fNum).Selected Then
2480 StatBar.Style = 1
2481 StatBar.SimpleText = "Extracting " + List.ListItems.Item(fNum).Tag + "..."
2482 MousePointer = 11
2483 Mpq.sGetFile hMPQ, List.ListItems.Item(fNum).Tag, Path, True
2484 End If
2485 Next fNum
2486 Mpq.SFileCloseArchive hMPQ
2487 StatBar.Style = 0
2488 StatBar.SimpleText = ""
2489 MousePointer = 0
2490 Exit Sub
2491 NotSelected:
2492 If GetReg(AppKey + "ShowConfirmation", 1) = 0 Then
2493 Result = vbYes
2494 Else
2495 Result = MsgBox("No files are selected." + vbCrLf + "Extract all listed files?", vbYesNo Or vbQuestion Or vbDefaultButton2, "WinMPQ")
2496 End If
2497 If Result = vbYes Then
2498 Path = PathInputBox(PathInput, "Extract file(s) to...", CurDir)
2499 If Path = "" Then Exit Sub
2500 If Right(Path, 1) <> "\" Then Path = Path + "\"
2501 If Mpq.SFileOpenArchive(CD.FileName, 0, 0, hMPQ) = 0 Then Exit Sub
2502 For fNum = 1 To List.ListItems.Count
2503 StatBar.Style = 1
2504 StatBar.SimpleText = "Extracting " + List.ListItems.Item(fNum).Tag + "..."
2505 MousePointer = 11
2506 Mpq.sGetFile hMPQ, List.ListItems.Item(fNum).Tag, Path, True
2507 Next fNum
2508 Mpq.SFileCloseArchive hMPQ
2509 StatBar.Style = 0
2510 StatBar.SimpleText = ""
2511 MousePointer = 0
2512 End If
2513 End Sub
2514 Private Sub mnuFNew_Click()
2515 Dim TItem As Menu
2516 CD.Flags = &H1000 Or &H4 Or &H2
2517 CD.DefaultExt = "mpq"
2518 CD.Filter = "Mpq Archives (*.mpq;*.exe;*.snp;*.scm;*.scx;*.w3m)|*.mpq;*.exe;*.snp;*.scm;*.scx;*.w3m|All Files (*.*)|*.*"
2519 If ShowSave(CD) = False Then GoTo Cancel
2520 ReDim FileList(0) As String
2521 List.ListItems.Clear
2522 ShowSelected
2523 ShowTotal
2524 NewFile = True
2525 ReDim OpenFiles(0) As String, OpenFileDates(0) As Date
2526 mnuMpq.Enabled = True
2527 For Each TItem In mnuTItem
2528 TItem.Enabled = True
2529 Next TItem
2530 Toolbar.Buttons.Item("Add").Enabled = True
2531 Toolbar.Buttons.Item("Add Folder").Enabled = True
2532 Toolbar.Buttons.Item("Extract").Enabled = True
2533 Toolbar.Buttons.Item("Compact").Enabled = True
2534 Toolbar.Buttons.Item("List").Enabled = True
2535 Caption = "WinMPQ - " + CD.FileTitle
2536 AddRecentFile CD.FileName
2537 Cancel:
2538 End Sub
2539 Private Sub mnuFOpen_Click()
2540 Dim OldFileName As String
2541 CD.Flags = &H1000 Or &H4 Or &H2
2542 CD.Filter = "Mpq Archives (*.mpq;*.exe;*.snp;*.scm;*.scx;*.w3m)|*.mpq;*.exe;*.snp;*.scm;*.scx;*.w3m|All Files (*.*)|*.*"
2543 OldFileName = CD.FileName
2544 If ShowOpen(CD) = False Then GoTo Cancel
2545 OpenMpq
2546 If CD.FileName = "" Then CD.FileName = OldFileName
2547 Cancel:
2548 End Sub
2549 Private Sub mnuMRename_Click()
2550 List.StartLabelEdit
2551 End Sub
2552 Private Sub mnuMSaveList_Click()
2553 Dim fNum As Long, fList As String, OldFileName As String
2554 CD.Flags = &H1000 Or &H4 Or &H2
2555 CD.DefaultExt = "txt"
2556 CD.Filter = "Text File (*.txt)|*.txt|All Files (*.*)|*.*"
2557 OldFileName = CD.FileName
2558 CD.FileName = CD.FileName + ".txt"
2559 If ShowSave(CD) = False Then GoTo Cancel
2560 StatBar.Style = 1
2561 StatBar.SimpleText = "Creating list..."
2562 MousePointer = 11
2563 For fNum = 1 To List.ListItems.Count
2564 fList = fList + List.ListItems.Item(fNum).Tag + vbCrLf
2565 Next fNum
2566 fNum = FreeFile
2567 Open CD.FileName For Binary As #fNum
2568 Put #fNum, 1, fList
2569 Close #fNum
2570 Cancel:
2571 CD.FileName = OldFileName
2572 StatBar.Style = 0
2573 StatBar.SimpleText = ""
2574 MousePointer = 0
2575 End Sub
2576 Private Sub mnuOptions_Click()
2577 Options.Show 1
2578 End Sub
2579 Private Sub mnuPDelete_Click()
2580 mnuMDelete_Click
2581 End Sub
2582 Private Sub mnuPExtract_Click()
2583 mnuMExtract_Click
2584 End Sub
2585 Private Sub mnuPItem_Click(Index As Integer)
2586 Dim fNum As Long, Path As String, fName As String, fName2 As String, bNum As Long, AlreadyInList As Boolean, hMPQ As Long
2587 Path = App.Path
2588 If Right(Path, 1) <> "\" Then Path = Path + "\"
2589 Path = Path + "Temp_extract\"
2590 If ExtractPathNum = -1 Then
2591 fNum = 0
2592 Do
2593 If DirEx(Path + CStr(fNum), "*", 6, True) = "" Then Exit Do
2594 fNum = fNum + 1
2595 Loop
2596 ExtractPathNum = fNum
2597 End If
2598 Path = Path + CStr(ExtractPathNum) + "\"
2599 If Mpq.SFileOpenArchive(CD.FileName, 0, 0, hMPQ) = 0 Then Exit Sub
2600 For fNum = 1 To List.ListItems.Count
2601 If List.ListItems.Item(fNum).Selected Then
2602 StatBar.Style = 1
2603 StatBar.SimpleText = "Extracting " + List.ListItems.Item(fNum).Tag + "..."
2604 MousePointer = 11
2605 Mpq.sGetFile hMPQ, List.ListItems.Item(fNum).Tag, Path, True
2606 If GetReg(AppKey + "CheckModDateTime", 1) > 0 Then
2607 For bNum = 1 To UBound(OpenFiles)
2608 If LCase(OpenFiles(bNum)) = LCase(List.ListItems.Item(fNum).Tag) Then
2609 AlreadyInList = True
2610 If FileExists(FullPath(Path, List.ListItems.Item(fNum).Tag)) Then OpenFileDates(bNum) = FileDateTime(FullPath(Path, List.ListItems.Item(fNum).Tag))
2611 Exit For
2612 End If
2613 Next bNum
2614 If AlreadyInList = False Then
2615 ReDim Preserve OpenFiles(UBound(OpenFiles) + 1) As String, OpenFileDates(UBound(OpenFileDates) + 1) As Date
2616 OpenFiles(UBound(OpenFiles)) = List.ListItems.Item(fNum).Tag
2617 If FileExists(FullPath(Path, List.ListItems.Item(fNum).Tag)) Then OpenFileDates(UBound(OpenFileDates)) = FileDateTime(FullPath(Path, List.ListItems.Item(fNum).Tag))
2618 End If
2619 End If
2620 StatBar.Style = 1
2621 StatBar.SimpleText = "Opening " + List.ListItems.Item(fNum).Tag + "..."
2622 fName = List.ListItems.Item(fNum).Tag
2623 ExecuteFile Path + fName, Index
2624 If GetReg(AppKey + "CheckModDateTime", 1) > 0 Then Timer1.Enabled = True
2625 End If
2626 Next fNum
2627 Mpq.SFileCloseArchive hMPQ
2628 StatBar.Style = 0
2629 StatBar.SimpleText = ""
2630 MousePointer = 0
2631 End Sub
2632 Private Sub mnuPRename_Click()
2633 mnuMRename_Click
2634 End Sub
2636 Private Sub mnuTAdd_Click()
2637 ToolList.Show 1
2638 BuildToolsList
2639 End Sub
2640 Private Sub mnuTItem_Click(Index As Integer)
2641 Dim Param As String, bNum As Long, FileName As String, Path As String, fNum As Long, AlreadyInList As Boolean, UseFile As Boolean, NewParam As String, FileNameList As String, hMPQ As Long
2642 Param = mnuTItem(Index).Tag
2643 On Error GoTo NoProgram
2644 If Param = "" Then Err.Raise 53
2645 On Error GoTo 0
2646 Do
2647 If InStr(1, Param, "%mpq", 1) Then
2648 bNum = InStr(1, Param, "%mpq", 1)
2649 Param = Left(Param, bNum - 1) + CD.FileName + Mid(Param, bNum + 4)
2650 End If
2651 Loop While InStr(1, Param, "%mpq", 1)
2652 NewParam = Param
2653 On Error GoTo NotSelected
2654 List.SelectedItem.Tag = List.SelectedItem.Tag
2655 On Error GoTo 0
2656 If List.SelectedItem.Selected Then FileName = List.SelectedItem.Tag
2657 NotSelected:
2658 If FileName <> "" And (InStr(Param, "%1") Or (InStr(Param, "%1") = 0 And InStr(1, mnuTItem(Index).Tag, "%mpq", 1) = 0)) Then
2659 Path = App.Path
2660 If Right(Path, 1) <> "\" Then Path = Path + "\"
2661 Path = Path + "Temp_extract\"
2662 If ExtractPathNum = -1 Then
2663 fNum = 0
2664 Do
2665 If DirEx(Path + CStr(fNum), "*", 6, True) = "" Then Exit Do
2666 fNum = fNum + 1
2667 Loop
2668 ExtractPathNum = fNum
2669 End If
2670 Path = Path + CStr(ExtractPathNum) + "\"
2671 If Mpq.SFileOpenArchive(CD.FileName, 0, 0, hMPQ) = 0 Then Exit Sub
2672 For fNum = 1 To List.ListItems.Count
2673 If List.ListItems.Item(fNum).Selected Then
2674 StatBar.Style = 1
2675 StatBar.SimpleText = "Extracting " + List.ListItems.Item(fNum).Tag + "..."
2676 MousePointer = 11
2677 Mpq.sGetFile hMPQ, List.ListItems.Item(fNum).Tag, Path, True
2678 If GetReg(AppKey + "CheckModDateTime", 1) > 0 Then
2679 For bNum = 1 To UBound(OpenFiles)
2680 If LCase(OpenFiles(bNum)) = LCase(List.ListItems.Item(fNum).Tag) Then
2681 AlreadyInList = True
2682 If FileExists(FullPath(Path, List.ListItems.Item(fNum).Tag)) Then OpenFileDates(bNum) = FileDateTime(FullPath(Path, List.ListItems.Item(fNum).Tag))
2683 Exit For
2684 End If
2685 Next bNum
2686 If AlreadyInList = False Then
2687 ReDim Preserve OpenFiles(UBound(OpenFiles) + 1) As String, OpenFileDates(UBound(OpenFileDates) + 1) As Date
2688 OpenFiles(UBound(OpenFiles)) = List.ListItems.Item(fNum).Tag
2689 If FileExists(FullPath(Path, List.ListItems.Item(fNum).Tag)) Then OpenFileDates(UBound(OpenFileDates)) = FileDateTime(FullPath(Path, List.ListItems.Item(fNum).Tag))
2690 End If
2691 End If
2692 StatBar.Style = 1
2693 StatBar.SimpleText = "Opening " + List.ListItems.Item(fNum).Tag + "..."
2694 FileName = FullPath(Path, List.ListItems.Item(fNum).Tag)
2695 UseFile = True
2696 Param = NewParam
2697 Do
2698 If InStr(Param, "%1") = 0 And InStr(1, mnuTItem(Index).Tag, "%mpq", 1) = 0 Then
2699 If FileName <> "" Then
2700 Param = Param + " " + FileName
2701 End If
2702 ElseIf InStr(Param, Chr(34) + "%1" + Chr(34)) Then
2703 bNum = InStr(Param, Chr(34) + "%1" + Chr(34))
2704 If FileName <> "" Then
2705 Param = Left(Param, bNum - 1) + Chr(34) + FileName + Chr(34) + Mid(Param, bNum + 4)
2706 Else
2707 Param = Left(Param, bNum - 1) + Mid(Param, bNum + 4)
2708 End If
2709 ElseIf InStr(Param, "%1") Then
2710 bNum = InStr(Param, "%1")
2711 If FileName <> "" Then
2712 Param = Left(Param, bNum - 1) + FileName + Mid(Param, bNum + 2)
2713 Else
2714 Param = Left(Param, bNum - 1) + Mid(Param, bNum + 2)
2715 End If
2716 End If
2717 Loop While InStr(Param, "%1")
2718 On Error GoTo NoProgram
2719 Shell Param, 1
2720 On Error GoTo 0
2721 If GetReg(AppKey + "CheckModDateTime", 1) > 0 Then Timer1.Enabled = True
2722 End If
2723 Next fNum
2724 Mpq.SFileCloseArchive hMPQ
2725 ElseIf InStr(1, mnuTItem(Index).Tag, "%mpq", 1) Then
2726 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
2727 On Error GoTo NoProgram
2728 Shell Param, 1
2729 On Error GoTo 0
2730 Timer1.Enabled = True
2731 Else
2732 MsgBox "No files are selected.", , "WinMPQ"
2733 End If
2734 If FileName <> "" Then
2735 StatBar.Style = 0
2736 StatBar.SimpleText = ""
2737 MousePointer = 0
2738 End If
2739 Exit Sub
2740 NoProgram:
2741 If Err.Number = 53 Then MsgBox "No program is assigned for this action.", , "WinMPQ"
2742 End Sub
2743 Private Sub Timer1_Timer()
2744 Dim fNum As Long, Path As String, Result As Long, bNum As Long
2745 If Screen.ActiveForm.Name <> "MpqEx" Then Exit Sub
2746 Path = App.Path
2747 If Right(Path, 1) <> "\" Then Path = Path + "\"
2748 Path = Path + "Temp_extract\"
2749 Path = Path + CStr(ExtractPathNum) + "\"
2750 For fNum = 1 To UBound(OpenFiles)
2751 If FileExists(FullPath(Path, OpenFiles(fNum))) Then
2752 If FileDateTime(FullPath(Path, OpenFiles(fNum))) > OpenFileDates(fNum) Then
2753 If GetReg(AppKey + "ShowConfirmation", 1) = 0 Then
2754 Result = vbYes
2755 Else
2756 Result = MsgBox("File " + OpenFiles(fNum) + " has been changed since it was extracted." + vbCrLf + vbCrLf + "Update archive with this file?", vbYesNo Or vbInformation, "WinMPQ")
2757 End If
2758 OpenFileDates(fNum) = FileDateTime(FullPath(Path, OpenFiles(fNum)))
2759 If Result = vbYes Then
2760 List.Sorted = False
2761 StatBar.Style = 1
2762 StatBar.SimpleText = "Adding " + OpenFiles(fNum) + "..."
2763 MousePointer = 11
2764 If mnuMCNone.Checked Then
2765 Mpq.AddFile CD.FileName, FullPath(Path, OpenFiles(fNum)), OpenFiles(fNum), 0
2766 ElseIf mnuMCStandard.Checked Then
2767 Mpq.AddFile CD.FileName, FullPath(Path, OpenFiles(fNum)), OpenFiles(fNum), 1
2768 ElseIf mnuMCAMedium.Checked Then
2769 Mpq.AddWavFile CD.FileName, FullPath(Path, OpenFiles(fNum)), OpenFiles(fNum), 0
2770 ElseIf mnuMCAHighest.Checked Then
2771 Mpq.AddWavFile CD.FileName, FullPath(Path, OpenFiles(fNum)), OpenFiles(fNum), 1
2772 ElseIf mnuMCALowest.Checked Then
2773 Mpq.AddWavFile CD.FileName, FullPath(Path, OpenFiles(fNum)), OpenFiles(fNum), 2
2774 ElseIf mnuMCAuto.Checked Then
2775 AddAutoFile CD.FileName, FullPath(Path, OpenFiles(fNum)), OpenFiles(fNum)
2776 End If
2777 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
2778 AddToListing OpenFiles(fNum)
2779 StatBar.Style = 0
2780 StatBar.SimpleText = ""
2781 MousePointer = 0
2782 List.Sorted = True
2783 RemoveDuplicates
2784 ShowTotal
2785 End If
2786 End If
2787 Else
2788 For bNum = fNum To UBound(OpenFiles) - 1
2789 OpenFiles(bNum) = OpenFiles(bNum + 1)
2790 OpenFileDates(bNum) = OpenFileDates(bNum + 1)
2791 Next bNum
2792 ReDim Preserve OpenFiles(UBound(OpenFiles) - 1) As String, OpenFileDates(UBound(OpenFileDates) - 1) As Date
2793 fNum = fNum - 1
2794 If UBound(OpenFiles) = 0 Then Timer1.Enabled = False
2795 End If
2796 If fNum >= UBound(OpenFiles) Then Exit For
2797 Next fNum
2798 If FileExists(CD.FileName) Then
2799 If FileDateTime(CD.FileName) <> MpqDate And NewFile = False Then OpenMpq
2800 Else
2801 OpenMpq
2802 End If
2803 End Sub
2804 Private Sub Toolbar_ButtonClick(ByVal Button As Button)
2805 Select Case Button.Key
2806 Case "New"
2807 mnuFNew_Click
2808 Case "Open"
2809 mnuFOpen_Click
2810 Case "Add"
2811 mnuMAdd_Click
2812 Case "Add Folder"
2813 mnuMAddFolder_Click
2814 Case "Extract"
2815 mnuMExtract_Click
2816 Case "Compact"
2817 mnuMCompact_Click
2818 Case "List"
2819 If NewFile = False Then OpenMpq
2820 End Select
2821 End Sub
2822 Private Sub txtCommand_GotFocus()
2823 cmdGo.Default = True
2824 txtCommandHasFocus = True
2825 StatBar.Style = 1
2826 StatBar.SimpleText = "Current directory: " + Chr(34) + CurDir + Chr(34)
2827 End Sub
2828 Private Sub txtCommand_LostFocus()
2829 cmdGo.Default = False
2830 txtCommandHasFocus = False
2831 StatBar.Style = 0
2832 StatBar.SimpleText = ""
2833 End Sub
|