Main
Current News
Archived News
Search News
Forums
Discussion Forum


Old Forum
Programs
Install Programs
Downloads
More Downloads...
Troubleshooting
Other Sections
Source Code
Format Specs.
Misc. Information
Non-SF Stuff
Links



projects / WinMPQ.git / blame
? search:
summary | graphiclog | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
WinMPQ v1.54
[WinMPQ.git] / listing.frm
CommitLineData
0d212c7b 1VERSION 4.00
2Begin 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
396End
397Attribute VB_Name = "MpqEx"
398Attribute VB_Creatable = False
399Attribute VB_Exposed = False
400Option Explicit
401
402Dim txtCommandHasFocus As Boolean
403Dim OpenFiles() As String, OpenFileDates() As Date, MpqDate As Date
404Sub AddRecentFile(rFileName As String)
405Dim bNum As Long, fNum As Long
406NewKey AppKey + "Recent\"
407For 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
419Next bNum
420If 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
432End If
433BuildRecentFileList
434End Sub
435Sub BuildPopup(FileName As String, Shift As Integer)
436Dim aNum As Long, aItem As String, aName As String, bNum As Long, PItem As Menu, dItem As String
437mnuPopup.Tag = 0
438For Each PItem In mnuPItem
439 If PItem.Index <> 0 Then Unload PItem
440Next PItem
441If InStr(FileName, ".") = 0 Then
442 GoSub AddUnknown
443Else
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
510End If
511Exit Sub
512AddUnknown:
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 = ""
547Return
548End Sub
549Sub DelRecentFile(rFileName As String)
550Dim bNum As Long, fNum As Long
551For 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
559Next bNum
560BuildRecentFileList
561End Sub
562Sub AddToListing(AddedFile As String)
563Dim 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
564If 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
607End If
608End Sub
609Sub MpqAddToListing(hMPQ As Long, AddedFile As String)
610Dim 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
611If 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
655End If
656End Sub
657Sub RemoveFromListing(RemovedFile As String)
658Dim FileCount As Long
659On Error GoTo FileRemoved
660Do
661List.ListItems.Remove RemovedFile
662FileCount = FileCount + 1
663Loop
664FileRemoved:
665If 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
672End If
673End Sub
674Sub RenameInListing(OldName As String, NewName As String)
675Dim lIndex As Long
676If LCase(OldName) <> LCase(NewName) Then RemoveFromListing NewName
677On Error GoTo RenameError
678lIndex = List.ListItems.Item(OldName).Index
679List.ListItems.Item(lIndex).Text = NewName
680List.ListItems.Item(lIndex).Tag = NewName
681On Error Resume Next
682List.ListItems.Item(lIndex).Key = NewName
683On Error GoTo 0
684Exit Sub
685RenameError:
686For 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
695Next lIndex
696End Sub
697Sub ExecuteFile(FileName As String, Index As Integer)
698Dim Param As String, bNum As Long, bNum2 As Long, EnvName As String
699If Index < mnuPopup.Tag Then
700 ShellExecute hWnd, mnuPItem(Index).Tag, FileName, vbNullString, vbNullString, 1
701Else
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
728End If
729Exit Sub
730NoProgram:
731If Err.Number = 53 Then MsgBox "No program is assigned for this action.", , "WinMPQ"
732End Sub
733Sub RunMpq2kCommand(CmdLine As String)
734Dim 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
735CurPath = CurDir
736If Right(CurPath, 1) <> "\" Then CurPath = CurPath + "\"
737sLine = CmdLine
738If Right(sLine, 1) <> " " Then sLine = sLine + " "
739If 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
1247End If
1248End Sub
1249Sub BuildRecentFileList()
1250Dim rNum As Long, rNum2 As Long, RecentFile As String, FirstSep As Long, LastSep As Long, RItem As Menu
1251For Each RItem In mnuFRecent
1252 If RItem.Index <> 0 Then Unload RItem
1253Next RItem
1254rNum2 = 1
1255For 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
1280Next rNum
1281End Sub
1282Sub BuildToolsList()
1283Dim tNum As Long, ToolName As String, ToolCommand, TItem As Menu
1284For Each TItem In mnuTItem
1285 If TItem.Index <> 0 Then Unload TItem
1286Next TItem
1287mnuTItem(0).Caption = "(Empty)"
1288mnuTItem(0).Tag = ""
1289Do
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
1307Loop Until ToolName = ""
1308End Sub
1309Sub OpenMpq()
1310Dim 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
1311On Error Resume Next
1312If 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
1320End If
1321On Error GoTo 0
1322If IsMPQ(CD.FileName) = False Then
1323 CD.FileName = ""
1324 MsgBox "This file does not contain an MPQ archive.", vbExclamation, "WinMPQ"
1325 Exit Sub
1326End If
1327If 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
1331End If
1332StatBar.Style = 1
1333StatBar.SimpleText = "Loading list..."
1334MousePointer = 11
1335Path = App.Path: If Right(Path, 1) <> "\" Then Path = Path + "\"
1336ReDim FileList(0) As String
1337#If InternalListing Then
1338FileList(0) = "(listfile)"
1339If 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
1356End If
1357nFiles = UBound(FileList)
1358ReDim Preserve FileList(UBound(FileList) + UBound(GlobalFileList)) As String
1359For bNum = nFiles + 1 To UBound(FileList)
1360 FileList(bNum) = GlobalFileList(bNum - nFiles)
1361Next bNum
1362#End If
1363Dim 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
1364SendMessageA List.hWnd, WM_SETREDRAW, 0, ByVal 0&
1365List.ListItems.Clear
1366List.Sorted = False
1367LoadExtraInfo = GetReg(AppKey + "LoadExtraInfo", 1)
1368FileFilter = mFilter
1369StatBar.SimpleText = "Building list... 0% complete"
1370For 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
1440Next fNum
1441Mpq.SFileCloseArchive hMPQ
1442List.Sorted = True
1443#If InternalListing Then
1444RemoveDuplicates
1445#End If
1446On Error Resume Next
1447List.SelectedItem.Selected = False
1448On Error GoTo 0
1449SendMessageA List.hWnd, WM_SETREDRAW, 1, ByVal 0&
1450ShowSelected
1451ShowTotal
1452NewFile = False
1453mFilter = FileFilter
1454FileOpened:
1455ReDim OpenFiles(0) As String, OpenFileDates(0) As Date
1456If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
1457mnuMpq.Enabled = True
1458For Each TItem In mnuTItem
1459 TItem.Enabled = True
1460Next TItem
1461Toolbar.Buttons.Item("Add").Enabled = True
1462Toolbar.Buttons.Item("Add Folder").Enabled = True
1463Toolbar.Buttons.Item("Extract").Enabled = True
1464Toolbar.Buttons.Item("Compact").Enabled = True
1465Toolbar.Buttons.Item("List").Enabled = True
1466StatBar.Style = 0
1467StatBar.SimpleText = ""
1468If 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
1476End If
1477Caption = "WinMPQ - " + Mid(CD.FileName, bNum)
1478AddRecentFile CD.FileName
1479MousePointer = 0
1480End Sub
1481Sub RemoveDuplicates()
1482Dim fNum As Long
1483fNum = 1
1484Do 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
1490Loop
1491End Sub
1492Sub ShowSelected()
1493Dim fNum As Long, nSelect As Long, sSize As Long, fSize As Long, L2 As String
1494On Error GoTo NotSelected
1495List.SelectedItem.Tag = List.SelectedItem.Tag
1496On Error GoTo 0
1497For 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
1516Next fNum
1517If sSize / 1024 > 0 And sSize / 1024 < 1 Then
1518 StatBar.Panels.Item(1).Text = "Selected " + CStr(nSelect) + " files, <1KB"
1519ElseIf sSize = 0 Then
1520 StatBar.Panels.Item(1).Text = "Selected " + CStr(nSelect) + " files, 0KB"
1521Else
1522 StatBar.Panels.Item(1).Text = "Selected " + CStr(nSelect) + " files, " + CStr(Int(sSize / 1024)) + "KB"
1523End If
1524Exit Sub
1525NotSelected:
1526StatBar.Panels.Item(1).Text = "Selected 0 files, 0KB"
1527End Sub
1528Sub ShowTotal()
1529Dim fNum As Long, nFiles As Long, tSize As Long
1530For 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
1535Next fNum
1536If tSize / 1024 > 0 And tSize / 1024 < 1 Then
1537 StatBar.Panels.Item(2).Text = "Total " + CStr(nFiles) + "/" + CStr(GetNumMpqFiles(CD.FileName)) + " files, <1KB"
1538Else
1539 StatBar.Panels.Item(2).Text = "Total " + CStr(nFiles) + "/" + CStr(GetNumMpqFiles(CD.FileName)) + " files, " + CStr(Int(tSize / 1024)) + "KB"
1540End If
1541End Sub
1542Private Sub cmdGo_Click()
1543StatBar.Style = 1
1544RunMpq2kCommand txtCommand
1545txtCommand = ""
1546If StatBar.SimpleText = "" Then txtCommand_GotFocus
1547End Sub
1548Private Sub Form_Load()
1549Dim 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
1550FixIcon hWnd, 1
1551InitFileDialog CD
1552CD.hwndOwner = hWnd
1553CD.DefaultExt = "mpq"
1554CD.MaxFileSize = 5120
1555InitFolderDialog PathInput
1556PathInput.hwndOwner = hWnd
1557PathInput.Flags = BIF_RETURNONLYFSDIRS
1558ReDim OpenFiles(0) As String, OpenFileDates(0) As Date
1559Dim Path
1560Path = App.Path: If Right(Path, 1) <> "\" Then Path = Path + "\"
1561ChDir App.Path
1562If 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
1576End If
1577ExtractPathNum = -1
1578CopyPathNum = -1
1579OldStartPath = CurDir
1580CurPath = GetReg(AppKey + "StartupPath", CurDir)
1581CurPathType = GetReg(AppKey + "StartupPathType", 0)
1582If CurPathType < 0 Then CurPathType = 0
1583If CurPathType > 2 Then CurPathType = 2
1584If CurPathType = 1 Then
1585 CurPath = App.Path
1586End If
1587CurPath2 = CurPath
1588If Right(CurPath2, 1) <> "\" Then CurPath2 = CurPath2 + "\"
1589If IsDir(CurPath2) Then
1590 If Mid(CurPath, 2, 1) = ":" Then ChDrive Left(CurPath, 1)
1591 ChDir CurPath
1592End If
1593NewStartPath = CurDir
1594On Error Resume Next
1595Height = GetReg(AppKey + "Status\WindowHeight", Height)
1596Left = GetReg(AppKey + "Status\WindowLeft", Left)
1597Top = GetReg(AppKey + "Status\WindowTop", Top)
1598Width = GetReg(AppKey + "Status\WindowWidth", Width)
1599If GetReg(AppKey + "Status\WindowState", WindowState) = 2 Then WindowState = 2 Else WindowState = 0
1600ListFile = GetReg(AppKey + "ListFile", Path + "mpq_data.txt")
1601Mpq.DefaultMaxFiles = GetReg(AppKey + "DefaultMaxFiles", 1024)
1602LocaleID = GetReg(AppKey + "LocaleID", 0)
1603BuildRecentFileList
1604BuildToolsList
1605On Error GoTo 0
1606Mpq.SetLocale LocaleID
1607ReDim GlobalFileList(0) As String
1608#If InternalListing Then
1609If 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
1616End If
1617#End If
1618FileName = Trim(Command)
1619If Left(FileName, 1) = Chr(34) Then FileName = Mid(FileName, 2)
1620If Right(FileName, 1) = Chr(34) Then FileName = Left(FileName, Len(FileName) - 1)
1621FileName = Trim(FileName)
1622If FileExists(FileName) Then
1623 CD.FileName = FileName
1624 Show
1625 OpenMpq
1626 Exit Sub
1627End If
1628ReDim FileList(0) As String
1629If Right(CurPath, 1) <> "\" Then CurPath = CurPath + "\"
1630sLine = Command
1631If Right(sLine, 1) <> " " Then sLine = sLine + " "
1632If 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
1676End If
1677End Sub
1678
1679
1680Private Sub Form_Resize()
1681On Error Resume Next
1682If 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
1694End If
1695End Sub
1696Private Sub Form_Unload(Cancel As Integer)
1697Dim Path As String
1698Path = App.Path
1699If Right(Path, 1) <> "\" Then Path = Path + "\"
1700On Error Resume Next
1701If ExtractPathNum > -1 Then
1702 KillEx Path + "Temp_extract\" + CStr(ExtractPathNum) + "\", "*", 6, True
1703 RmDir Path + "Temp_extract\" + CStr(ExtractPathNum) + "\"
1704End If
1705If DirEx(Path + "Temp_extract\", "*", 6, True) = "" Or App.PrevInstance = False Then
1706 KillEx Path + "Temp_extract\", "*", 6, True
1707 RmDir Path + "Temp_extract\"
1708End If
1709If CopyPathNum > -1 Then
1710 KillEx Path + "Temp_copy\" + CStr(CopyPathNum) + "\", "*", 6, True
1711 RmDir Path + "Temp_copy\" + CStr(CopyPathNum) + "\"
1712End If
1713If DirEx(Path + "Temp_copy\", "*", 6, True) = "" Or App.PrevInstance = False Then
1714 KillEx Path + "Temp_copy\", "*", 6, True
1715 RmDir Path + "Temp_copy\"
1716End If
1717If 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
1727End If
1728If GetReg(AppKey + "StartupPathType", 0) <= 0 Then
1729 SetReg AppKey + "StartupPath", CurDir
1730End If
1731End
1732End Sub
1733Private Sub Label1_Click()
1734txtCommand.SetFocus
1735End Sub
1736Private Sub List_AfterLabelEdit(Cancel As Integer, NewString As String)
1737Dim Result As Long
1738If 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
1760End If
1761ShowSelected
1762End Sub
1763Private Sub List_Click()
1764On Error GoTo NotSelected
1765List.SelectedItem.Tag = List.SelectedItem.Tag
1766On Error GoTo NotClick
1767List.HitTest(CX, CY).Tag = List.HitTest(CX, CY).Tag
1768On Error GoTo 0
1769ShowSelected
1770Exit Sub
1771NotClick:
1772List.SelectedItem.Selected = False
1773NotSelected:
1774ShowSelected
1775End Sub
1776Private Sub List_ColumnClick(ByVal ColumnHeader As ColumnHeader)
1777If 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
1783Else
1784 List.SortOrder = 0
1785 List.SortKey = ColumnHeader.Index - 1
1786End If
1787End Sub
1788Private Sub List_DblClick()
1789Dim fNum As Long, Path As String, fName As String, fName2 As String, bNum As Long, AlreadyInList As Boolean, hMPQ As Long
1790On Error GoTo NotSelected
1791List.SelectedItem.Tag = List.SelectedItem.Tag
1792On Error GoTo NotClick
1793List.HitTest(CX, CY).Tag = List.HitTest(CX, CY).Tag
1794On Error GoTo 0
1795Path = App.Path
1796If Right(Path, 1) <> "\" Then Path = Path + "\"
1797Path = Path + "Temp_extract\"
1798If 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
1805End If
1806Path = Path + CStr(ExtractPathNum) + "\"
1807If Mpq.SFileOpenArchive(CD.FileName, 0, 0, hMPQ) = 0 Then Exit Sub
1808For 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
1835Next fNum
1836Mpq.SFileCloseArchive hMPQ
1837StatBar.Style = 0
1838StatBar.SimpleText = ""
1839MousePointer = 0
1840Exit Sub
1841NotClick:
1842List.SelectedItem.Selected = False
1843NotSelected:
1844End Sub
1845Private Sub List_KeyPress(KeyAscii As Integer)
1846If KeyAscii = 13 Then List_DblClick
1847End Sub
1848Private Sub List_KeyUp(KeyCode As Integer, Shift As Integer)
1849If KeyCode = vbKeyDelete Then
1850 mnuMDelete_Click
1851ElseIf 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
1859End If
1860NotSelected:
1861End Sub
1862Private Sub List_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
1863CX = x
1864CY = y
1865If 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)
1873End If
1874NotClick:
1875NotSelected:
1876End Sub
1877Private Sub List_OLECompleteDrag(Effect As Long)
1878List.Tag = ""
1879End Sub
1880Private Sub List_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
1881Dim 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
1882Dim 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
1883If Data.GetFormat(ccCFFiles) <> True Then Exit Sub
1884For 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
1892Next fNum
1893Path = Data.Files.Item(1)
1894For 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
1903Next bNum
1904PathFound:
1905Path = Left(Path, bNum - 1)
1906ReDim Files(0) As String
1907Files(0) = Path
1908If Right(Path, 1) <> "\" Then Path = Path + "\"
1909ReDim Preserve Files(Data.Files.Count) As String
1910For 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)
1920Next bNum
1921If FolderFiles = "" Then Exit Sub
1922ReDim Preserve Files(0) As String
1923For 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
1932Next bNum
1933FoldName.Show 1
1934If 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
1943Else
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))
1954End If
1955If NewFile = True Then
1956 If FileExists(CD.FileName) Then Kill CD.FileName
1957 NewFile = False
1958End If
1959List.Sorted = False
1960FileFilter = mFilter
1961hMPQ = Mpq.mOpenMpq(CD.FileName)
1962If hMPQ = 0 Then
1963 StatBar.SimpleText = "Can't create archive " + CD.FileName
1964 Exit Sub
1965End If
1966For 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
1991Next bNum
1992Mpq.mCloseMpq hMPQ
1993If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
1994If 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
2005End If
2006StatBar.Style = 0
2007StatBar.SimpleText = ""
2008MousePointer = 0
2009If MatchesFilter("(listfile)", FileFilter) Then
2010 AddToListing "(listfile)"
2011End If
2012mFilter = FileFilter
2013List.Sorted = True
2014RemoveDuplicates
2015ShowTotal
2016Cancel:
2017End Sub
2018Private 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)
2019If CD.FileName = "" Or Data.GetFormat(ccCFFiles) <> True Or List.Tag = "WinMPQ" Then
2020 Effect = ccOLEDropEffectNone
2021Else
2022 Effect = ccOLEDropEffectCopy
2023End If
2024End Sub
2025Private Sub List_OLESetData(Data As MSComctlLib.DataObject, DataFormat As Integer)
2026Dim fNum As Long, Path As String, fCount As Long, FirstFile As String, hMPQ As Long
2027Path = App.Path
2028If Right(Path, 1) <> "\" Then Path = Path + "\"
2029Path = Path + "Temp_copy\"
2030If 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
2037End If
2038Path = Path + CStr(CopyPathNum) + "\"
2039KillEx Path, "*", 6, True
2040fCount = 0
2041If Mpq.SFileOpenArchive(CD.FileName, 0, 0, hMPQ) = 0 Then Exit Sub
2042For 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
2054Next fNum
2055Mpq.SFileCloseArchive hMPQ
2056StatBar.Style = 0
2057StatBar.SimpleText = ""
2058MousePointer = 0
2059If GetReg(AppKey + "UseDragDropWildcards", 1) <> 0 And fCount > 1 Then
2060 Data.Files.Add Path + "*"
2061ElseIf fCount = 1 Then
2062 Data.Files.Add FirstFile
2063End If
2064End Sub
2065Private Sub List_OLEStartDrag(Data As MSComctlLib.DataObject, AllowedEffects As Long)
2066Data.SetData , ccCFFiles
2067AllowedEffects = ccOLEDropEffectCopy
2068List.Tag = "WinMPQ"
2069End Sub
2070Private Sub mFilter_KeyPress(KeyAscii As Integer)
2071If KeyAscii = 13 And Toolbar.Buttons.Item("List").Enabled Then
2072 If NewFile = False Then OpenMpq
2073End If
2074End Sub
2075Private Sub mnuFExit_Click()
2076Unload Me
2077End Sub
2078Private Sub mnuFile_Click()
2079If FileExists(CD.FileName) Then mnuFReopen.Enabled = True Else mnuFReopen.Enabled = False
2080End Sub
2081
2082Private Sub mnuFRecent_Click(Index As Integer)
2083Dim OldFileName As String
2084OldFileName = CD.FileName
2085CD.FileName = mnuFRecent(Index).Tag
2086If 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
2091End If
2092OpenMpq
2093If CD.FileName = "" Then
2094 CD.FileName = OldFileName
2095 DelRecentFile mnuFRecent(Index).Tag
2096End If
2097End Sub
2098Private Sub mnuFReopen_Click()
2099OpenMpq
2100End Sub
2101
2102Private Sub mnuFScript_Click()
2103Dim OldFileName As String, OldPath As String
2104CD.Flags = &H1000 Or &H4 Or &H2
2105CD.Filter = "All Files (*.*)|*.*"
2106OldFileName = CD.FileName
2107OldPath = CurDir
2108If ShowOpen(CD) = False Then GoTo Cancel
2109StatBar.Style = 1
2110StatBar.SimpleText = "Running script " + CD.FileName + "..."
2111MousePointer = 11
2112RunScript CD.FileName
2113StatBar.Style = 0
2114StatBar.SimpleText = ""
2115MousePointer = 0
2116CD.FileName = OldFileName
2117Cancel:
2118If Mid(OldPath, 2, 1) = ":" Then ChDrive Left(OldPath, 1)
2119ChDir OldPath
2120End Sub
2121Private Sub mnuHAbout_Click()
2122About.Show 1
2123End Sub
2124Private Sub mnuHReadme_Click()
2125Dim Path As String
2126Path = App.Path
2127If Right(Path, 1) <> "\" Then Path = Path + "\"
2128If FileExists(Path + "WinMPQ.rtf") Then
2129 ShellExecute hWnd, vbNullString, Path + "WinMPQ.rtf", vbNullString, vbNullString, 1
2130Else
2131 MsgBox "Could not find WinMPQ.rtf!", vbCritical, "WinMPQ"
2132End If
2133End Sub
2134Private Sub mnuMAdd_Click()
2135Dim Files() As String, ShortFiles() As String, bNum As Long, OldFileName As String, fNum As Long, cNum As Long, FileFilter As String
2136Dim 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
2137CD.Flags = OFN_EXPLORER Or &H1000 Or &H200 Or &H4 Or &H2
2138CD.Filter = "All Files (*.*)|*.*"
2139OldFileName = CD.FileName
2140If ShowOpen(CD) = False Then GoTo Cancel
2141ReDim Files(0) As String
2142bNum = 1
2143If 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
2146Else
2147 Files(0) = Mid(CD.FileName, 1)
2148End If
2149For 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
2158Next bNum
2159CD.FileName = OldFileName
2160FoldName.Show 1
2161If 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
2170Else
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))
2181End If
2182If NewFile = True Then
2183 If FileExists(CD.FileName) Then Kill CD.FileName
2184 NewFile = False
2185End If
2186List.Sorted = False
2187FileFilter = mFilter
2188hMPQ = Mpq.mOpenMpq(CD.FileName)
2189If hMPQ = 0 Then
2190 StatBar.SimpleText = "Can't create archive " + CD.FileName
2191 Exit Sub
2192End If
2193For 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
2218Next bNum
2219Mpq.mCloseMpq hMPQ
2220If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
2221If 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
2232End If
2233StatBar.Style = 0
2234StatBar.SimpleText = ""
2235MousePointer = 0
2236If MatchesFilter("(listfile)", FileFilter) Then
2237 AddToListing "(listfile)"
2238End If
2239mFilter = FileFilter
2240List.Sorted = True
2241RemoveDuplicates
2242ShowTotal
2243Cancel:
2244End Sub
2245Private Sub mnuMAddFolder_Click()
2246Dim 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
2247Dim 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
2248Path = PathInputBox(PathInput, "Folder to add files from...", CurDir)
2249If Path = "" Then GoTo Cancel
2250FolderFiles = DirEx(Path, "*", 6, True)
2251If FolderFiles = "" Then Exit Sub
2252ReDim Files(0) As String
2253Files(0) = Path
2254If Right(Path, 1) <> "\" Then Path = Path + "\"
2255For 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
2264Next bNum
2265FoldName.Show 1
2266If 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
2275Else
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))
2286End If
2287If NewFile = True Then
2288 If FileExists(CD.FileName) Then Kill CD.FileName
2289 NewFile = False
2290End If
2291List.Sorted = False
2292FileFilter = mFilter
2293hMPQ = Mpq.mOpenMpq(CD.FileName)
2294If hMPQ = 0 Then
2295 StatBar.SimpleText = "Can't create archive " + CD.FileName
2296 Exit Sub
2297End If
2298For 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
2323Next bNum
2324Mpq.mCloseMpq hMPQ
2325If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
2326If 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
2337End If
2338StatBar.Style = 0
2339StatBar.SimpleText = ""
2340MousePointer = 0
2341If MatchesFilter("(listfile)", FileFilter) Then
2342 AddToListing "(listfile)"
2343End If
2344mFilter = FileFilter
2345List.Sorted = True
2346RemoveDuplicates
2347ShowTotal
2348Cancel:
2349End Sub
2350Private Sub mnuMCAHighest_Click()
2351mnuMCNone.Checked = False
2352mnuMCStandard.Checked = False
2353mnuMCALowest.Checked = False
2354mnuMCAMedium.Checked = False
2355mnuMCAHighest.Checked = True
2356mnuMCAuto.Checked = False
2357End Sub
2358Private Sub mnuMCALowest_Click()
2359mnuMCNone.Checked = False
2360mnuMCStandard.Checked = False
2361mnuMCALowest.Checked = True
2362mnuMCAMedium.Checked = False
2363mnuMCAHighest.Checked = False
2364mnuMCAuto.Checked = False
2365End Sub
2366
2367
2368Private Sub mnuMCAMedium_Click()
2369mnuMCNone.Checked = False
2370mnuMCStandard.Checked = False
2371mnuMCALowest.Checked = False
2372mnuMCAMedium.Checked = True
2373mnuMCAHighest.Checked = False
2374mnuMCAuto.Checked = False
2375End Sub
2376
2377Private Sub mnuMCAuto_Click()
2378mnuMCNone.Checked = False
2379mnuMCStandard.Checked = False
2380mnuMCALowest.Checked = False
2381mnuMCAMedium.Checked = False
2382mnuMCAHighest.Checked = False
2383mnuMCAuto.Checked = True
2384End Sub
2385
2386Private Sub mnuMCNone_Click()
2387mnuMCNone.Checked = True
2388mnuMCStandard.Checked = False
2389mnuMCALowest.Checked = False
2390mnuMCAMedium.Checked = False
2391mnuMCAHighest.Checked = False
2392mnuMCAuto.Checked = False
2393End Sub
2394
2395Private Sub mnuMCompact_Click()
2396Dim fNum As Long, Result As Long
2397If GetReg(AppKey + "ShowConfirmation", 1) = 0 Then
2398 Result = vbYes
2399Else
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")
2401End If
2402If 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
2412End If
2413End Sub
2414Private Sub mnuMCStandard_Click()
2415mnuMCNone.Checked = False
2416mnuMCStandard.Checked = True
2417mnuMCALowest.Checked = False
2418mnuMCAMedium.Checked = False
2419mnuMCAHighest.Checked = False
2420End Sub
2421Private Sub mnuMDelete_Click()
2422Dim fNum As Long, Result As Long
2423On Error GoTo NotSelected
2424List.SelectedItem.Tag = List.SelectedItem.Tag
2425On Error GoTo 0
2426For fNum = 1 To List.ListItems.Count
2427 If List.ListItems.Item(fNum).Selected Then
2428 GoTo FileSelected
2429 End If
2430Next fNum
2431GoTo NotSelected
2432FileSelected:
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
2458Exit Sub
2459NotSelected:
2460MsgBox "No files are selected.", , "WinMPQ"
2461End Sub
2462Private Sub mnuMExtract_Click()
2463Dim fNum As Long, Path As String, Result As Long, hMPQ As Long
2464On Error GoTo NotSelected
2465List.SelectedItem.Tag = List.SelectedItem.Tag
2466On Error GoTo 0
2467For fNum = 1 To List.ListItems.Count
2468 If List.ListItems.Item(fNum).Selected Then
2469 GoTo FileSelected
2470 End If
2471Next fNum
2472GoTo NotSelected
2473FileSelected:
2474Path = PathInputBox(PathInput, "Extract file(s) to...", CurDir)
2475If Path = "" Then Exit Sub
2476If Right(Path, 1) <> "\" Then Path = Path + "\"
2477If Mpq.SFileOpenArchive(CD.FileName, 0, 0, hMPQ) = 0 Then Exit Sub
2478For 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
2485Next fNum
2486Mpq.SFileCloseArchive hMPQ
2487StatBar.Style = 0
2488StatBar.SimpleText = ""
2489MousePointer = 0
2490Exit Sub
2491NotSelected:
2492If GetReg(AppKey + "ShowConfirmation", 1) = 0 Then
2493 Result = vbYes
2494Else
2495 Result = MsgBox("No files are selected." + vbCrLf + "Extract all listed files?", vbYesNo Or vbQuestion Or vbDefaultButton2, "WinMPQ")
2496End If
2497If 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
2512End If
2513End Sub
2514Private Sub mnuFNew_Click()
2515Dim TItem As Menu
2516CD.Flags = &H1000 Or &H4 Or &H2
2517CD.DefaultExt = "mpq"
2518CD.Filter = "Mpq Archives (*.mpq;*.exe;*.snp;*.scm;*.scx;*.w3m)|*.mpq;*.exe;*.snp;*.scm;*.scx;*.w3m|All Files (*.*)|*.*"
2519If ShowSave(CD) = False Then GoTo Cancel
2520ReDim FileList(0) As String
2521List.ListItems.Clear
2522ShowSelected
2523ShowTotal
2524NewFile = True
2525ReDim OpenFiles(0) As String, OpenFileDates(0) As Date
2526mnuMpq.Enabled = True
2527For Each TItem In mnuTItem
2528 TItem.Enabled = True
2529Next TItem
2530Toolbar.Buttons.Item("Add").Enabled = True
2531Toolbar.Buttons.Item("Add Folder").Enabled = True
2532Toolbar.Buttons.Item("Extract").Enabled = True
2533Toolbar.Buttons.Item("Compact").Enabled = True
2534Toolbar.Buttons.Item("List").Enabled = True
2535Caption = "WinMPQ - " + CD.FileTitle
2536AddRecentFile CD.FileName
2537Cancel:
2538End Sub
2539Private Sub mnuFOpen_Click()
2540Dim OldFileName As String
2541CD.Flags = &H1000 Or &H4 Or &H2
2542CD.Filter = "Mpq Archives (*.mpq;*.exe;*.snp;*.scm;*.scx;*.w3m)|*.mpq;*.exe;*.snp;*.scm;*.scx;*.w3m|All Files (*.*)|*.*"
2543OldFileName = CD.FileName
2544If ShowOpen(CD) = False Then GoTo Cancel
2545OpenMpq
2546If CD.FileName = "" Then CD.FileName = OldFileName
2547Cancel:
2548End Sub
2549Private Sub mnuMRename_Click()
2550List.StartLabelEdit
2551End Sub
2552Private Sub mnuMSaveList_Click()
2553Dim fNum As Long, fList As String, OldFileName As String
2554CD.Flags = &H1000 Or &H4 Or &H2
2555CD.DefaultExt = "txt"
2556CD.Filter = "Text File (*.txt)|*.txt|All Files (*.*)|*.*"
2557OldFileName = CD.FileName
2558CD.FileName = CD.FileName + ".txt"
2559If ShowSave(CD) = False Then GoTo Cancel
2560StatBar.Style = 1
2561StatBar.SimpleText = "Creating list..."
2562MousePointer = 11
2563For fNum = 1 To List.ListItems.Count
2564 fList = fList + List.ListItems.Item(fNum).Tag + vbCrLf
2565Next fNum
2566fNum = FreeFile
2567Open CD.FileName For Binary As #fNum
2568Put #fNum, 1, fList
2569Close #fNum
2570Cancel:
2571CD.FileName = OldFileName
2572StatBar.Style = 0
2573StatBar.SimpleText = ""
2574MousePointer = 0
2575End Sub
2576Private Sub mnuOptions_Click()
2577Options.Show 1
2578End Sub
2579Private Sub mnuPDelete_Click()
2580mnuMDelete_Click
2581End Sub
2582Private Sub mnuPExtract_Click()
2583mnuMExtract_Click
2584End Sub
2585Private Sub mnuPItem_Click(Index As Integer)
2586Dim fNum As Long, Path As String, fName As String, fName2 As String, bNum As Long, AlreadyInList As Boolean, hMPQ As Long
2587Path = App.Path
2588If Right(Path, 1) <> "\" Then Path = Path + "\"
2589Path = Path + "Temp_extract\"
2590If 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
2597End If
2598Path = Path + CStr(ExtractPathNum) + "\"
2599If Mpq.SFileOpenArchive(CD.FileName, 0, 0, hMPQ) = 0 Then Exit Sub
2600For 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
2626Next fNum
2627Mpq.SFileCloseArchive hMPQ
2628StatBar.Style = 0
2629StatBar.SimpleText = ""
2630MousePointer = 0
2631End Sub
2632Private Sub mnuPRename_Click()
2633mnuMRename_Click
2634End Sub
2635
2636Private Sub mnuTAdd_Click()
2637ToolList.Show 1
2638BuildToolsList
2639End Sub
2640Private Sub mnuTItem_Click(Index As Integer)
2641Dim 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
2642Param = mnuTItem(Index).Tag
2643On Error GoTo NoProgram
2644If Param = "" Then Err.Raise 53
2645On Error GoTo 0
2646Do
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
2651Loop While InStr(1, Param, "%mpq", 1)
2652NewParam = Param
2653On Error GoTo NotSelected
2654List.SelectedItem.Tag = List.SelectedItem.Tag
2655On Error GoTo 0
2656If List.SelectedItem.Selected Then FileName = List.SelectedItem.Tag
2657NotSelected:
2658If 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
2725ElseIf 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
2731Else
2732 MsgBox "No files are selected.", , "WinMPQ"
2733End If
2734If FileName <> "" Then
2735 StatBar.Style = 0
2736 StatBar.SimpleText = ""
2737 MousePointer = 0
2738End If
2739Exit Sub
2740NoProgram:
2741If Err.Number = 53 Then MsgBox "No program is assigned for this action.", , "WinMPQ"
2742End Sub
2743Private Sub Timer1_Timer()
2744Dim fNum As Long, Path As String, Result As Long, bNum As Long
2745If Screen.ActiveForm.Name <> "MpqEx" Then Exit Sub
2746Path = App.Path
2747If Right(Path, 1) <> "\" Then Path = Path + "\"
2748Path = Path + "Temp_extract\"
2749Path = Path + CStr(ExtractPathNum) + "\"
2750For 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
2797Next fNum
2798If FileExists(CD.FileName) Then
2799 If FileDateTime(CD.FileName) <> MpqDate And NewFile = False Then OpenMpq
2800Else
2801 OpenMpq
2802End If
2803End Sub
2804Private Sub Toolbar_ButtonClick(ByVal Button As Button)
2805Select Case Button.Key
2806Case "New"
2807 mnuFNew_Click
2808Case "Open"
2809 mnuFOpen_Click
2810Case "Add"
2811 mnuMAdd_Click
2812Case "Add Folder"
2813 mnuMAddFolder_Click
2814Case "Extract"
2815 mnuMExtract_Click
2816Case "Compact"
2817 mnuMCompact_Click
2818Case "List"
2819 If NewFile = False Then OpenMpq
2820End Select
2821End Sub
2822Private Sub txtCommand_GotFocus()
2823cmdGo.Default = True
2824txtCommandHasFocus = True
2825StatBar.Style = 1
2826StatBar.SimpleText = "Current directory: " + Chr(34) + CurDir + Chr(34)
2827End Sub
2828Private Sub txtCommand_LostFocus()
2829cmdGo.Default = False
2830txtCommandHasFocus = False
2831StatBar.Style = 0
2832StatBar.SimpleText = ""
2833End Sub
MPQ editor for Windows