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