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: |
a257dd8762668b24304cf5e30175417ac6c4f53d
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 Currency, 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 On Error Resume Next
1763 For fNum = 1 To List.ListItems.Count
1764 If List.ListItems.Item(fNum).Selected Then
1765 nSelect = nSelect + 1
1766 If List.ListItems.Item(fNum).ListSubItems(1).Text <> "" Then
1767 sSize = sSize + List.ListItems.Item(fNum).ListSubItems(1).Tag
1768 Else
1769 If SFileOpenArchive(CD.FileName, 0, 0, hMPQ) Then
1770 If SFileOpenFileEx(hMPQ, List.ListItems.Item(fNum).Tag, 0, hFile) Then
1771 fSize = SFileGetFileSize(hFile, 0)
1772 SFileCloseFile hFile
1773 End If
1774 SFileCloseArchive hMPQ
1775 End If
1776 If fSize / 1024 > 0 And fSize / 1024 < 1 Then
1777 L2 = "<1KB"
1778 ElseIf fSize = 0 Then
1779 L2 = "0KB"
1780 Else
1781 L2 = CStr(Int(fSize / 1024)) + "KB"
1782 End If
1783 List.ListItems.Item(fNum).ListSubItems(1).Text = L2
1784 List.ListItems.Item(fNum).ListSubItems(1).Tag = fSize
1785 sSize = sSize + List.ListItems.Item(fNum).ListSubItems(1).Tag
1786 End If
1787 End If
1788 Next fNum
1789 If sSize / 1024 > 0 And sSize / 1024 < 1 Then
1790 StatBar.Panels.Item(1).Text = "Selected " + CStr(nSelect) + " files, <1KB"
1791 ElseIf sSize = 0 Then
1792 StatBar.Panels.Item(1).Text = "Selected " + CStr(nSelect) + " files, 0KB"
1793 Else
1794 StatBar.Panels.Item(1).Text = "Selected " + CStr(nSelect) + " files, " + CStr(Int(sSize / 1024)) + "KB"
1795 End If
1796 On Error GoTo 0
1797 Exit Sub
1798 NotSelected:
1799 StatBar.Panels.Item(1).Text = "Selected 0 files, 0KB"
1800 End Sub
1801 Sub ShowTotal()
1802 Dim fNum As Long, nFiles As Long, tSize As Currency
1803 On Error Resume Next
1804 For fNum = 1 To List.ListItems.Count
1805 nFiles = nFiles + 1
1806 If List.ListItems.Item(fNum).ListSubItems(1).Text <> "" Then
1807 tSize = tSize + List.ListItems.Item(fNum).ListSubItems(1).Tag
1808 End If
1809 Next fNum
1810 If tSize / 1024 > 0 And tSize / 1024 < 1 Then
1811 StatBar.Panels.Item(2).Text = "Total " + CStr(nFiles) + "/" + CStr(GetNumMpqFiles(CD.FileName)) + " files, <1KB"
1812 Else
1813 StatBar.Panels.Item(2).Text = "Total " + CStr(nFiles) + "/" + CStr(GetNumMpqFiles(CD.FileName)) + " files, " + CStr(Int(tSize / 1024)) + "KB"
1814 End If
1815 On Error GoTo 0
1816 End Sub
1817 Private Sub cmdGo_Click()
1818 StatBar.Style = 1
1819 RunMpq2kCommand txtCommand
1820 txtCommand = ""
1821 If StatBar.SimpleText = "" Then txtCommand_GotFocus
1822 End Sub
1824 Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
1825 If KeyCode = vbKeyShift Then
1826 ShiftState = True
1827 BuildMpqActionList
1828 End If
1829 End Sub
1830 Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
1831 If KeyCode = vbKeyShift Then
1832 ShiftState = False
1833 BuildMpqActionList
1834 End If
1835 End Sub
1836 Private Sub Form_Load()
1837 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
1838 Dim Path
1839 Path = App.Path: If Right(Path, 1) <> "\" Then Path = Path + "\"
1840 NewKey AppKey
1841 SetReg AppKey + "InstallPath", GetLongPath(App.Path), REG_SZ
1842 SetReg AppKey + "ProgramFilename", GetLongPath(Path + App.EXEName + ".exe"), REG_SZ
1843 FixIcon hWnd, 1
1844 InitFileDialog CD
1845 CD.hwndOwner = hWnd
1846 CD.DefaultExt = "mpq"
1847 CD.MaxFileSize = 5120
1848 InitFolderDialog PathInput
1849 PathInput.hwndOwner = hWnd
1850 PathInput.Flags = BIF_RETURNONLYFSDIRS
1851 ReDim OpenFiles(0) As String, OpenFileDates(0) As Date
1852 ChDir App.Path
1853 'If Mpq.MpqInitialize = False Then
1854 ' ErrorText = "Mpq Control did not initialize properly!" + vbCrLf + "Reason: "
1855 ' Select Case Mpq.LastError
1856 ' Case MPQ_ERROR_NO_STAREDIT
1857 ' ErrorText = ErrorText + "Can't find StarEdit.exe"
1858 ' Case MPQ_ERROR_BAD_STAREDIT
1859 ' ErrorText = ErrorText + "Wrong version of StarEdit.exe. Need SC/BW 1.07"
1860 ' Case MPQ_ERROR_STAREDIT_RUNNING
1861 ' ErrorText = ErrorText + "StarEdit.exe is running. It must be closed before running this"
1862 ' Case Else
1863 ' ErrorText = ErrorText + "Unknown"
1864 ' End Select
1865 ' MsgBox ErrorText
1866 ' End
1867 'End If
1868 ExtractPathNum = -1
1869 CopyPathNum = -1
1870 OldStartPath = CurDir
1871 CurPath = GetReg(AppKey + "StartupPath", CurDir)
1872 CurPathType = GetReg(AppKey + "StartupPathType", 0)
1873 If CurPathType < 0 Then CurPathType = 0
1874 If CurPathType > 2 Then CurPathType = 2
1875 If CurPathType = 1 Then
1876 CurPath = App.Path
1877 End If
1878 CurPath2 = CurPath
1879 If Right(CurPath2, 1) <> "\" Then CurPath2 = CurPath2 + "\"
1880 If IsDir(CurPath2) Then
1881 If Mid(CurPath, 2, 1) = ":" Then ChDrive Left(CurPath, 1)
1882 ChDir CurPath
1883 End If
1884 NewStartPath = CurDir
1885 On Error Resume Next
1886 Height = GetReg(AppKey + "Status\WindowHeight", Height)
1887 Left = GetReg(AppKey + "Status\WindowLeft", Left)
1888 Top = GetReg(AppKey + "Status\WindowTop", Top)
1889 Width = GetReg(AppKey + "Status\WindowWidth", Width)
1890 If GetReg(AppKey + "Status\WindowState", WindowState) = 2 Then WindowState = 2 Else WindowState = 0
1891 ListFile = GetReg(AppKey + "ListFile", Path + "mpq_data.txt")
1892 DefaultMaxFiles = GetReg(AppKey + "DefaultMaxFiles", 1024)
1893 DefaultBlockSize = GetReg(AppKey + "DefaultBlockSize", DEFAULT_BLOCK_SIZE)
1894 LocaleID = GetReg(AppKey + "LocaleID", 0)
1895 GlobalEncrypt = False
1896 DefaultCompressID = GetReg(AppKey + "DefaultCompress", -1)
1897 Select Case DefaultCompressID
1898 Case -3
1899 DefaultCompress = MAFA_COMPRESS_DEFLATE
1900 Case Else
1901 DefaultCompress = MAFA_COMPRESS_STANDARD
1902 End Select
1903 DefaultCompressLevel = GetReg(AppKey + "DefaultZlibLevel", Z_DEFAULT_COMPRESSION)
1904 BuildRecentFileList
1905 BuildToolsList
1906 On Error GoTo 0
1907 SFileSetLocale LocaleID
1908 ReDim GlobalFileList(0) As String
1909 #If InternalListing Then
1910 If FileExists(ListFile) Then
1911 Open ListFile For Input As #1
1912 Do While Not EOF(1)
1913 ReDim Preserve GlobalFileList(UBound(GlobalFileList) + 1) As String
1914 Line Input #1, GlobalFileList(UBound(GlobalFileList))
1915 Loop
1916 Close #1
1917 End If
1918 #End If
1919 FileName = Trim(Command)
1920 If Left(FileName, 1) = Chr(34) Then FileName = Mid(FileName, 2)
1921 If Right(FileName, 1) = Chr(34) Then FileName = Left(FileName, Len(FileName) - 1)
1922 FileName = Trim(FileName)
1923 If FileExists(FileName) Then
1924 CD.FileName = FileName
1925 Show
1926 OpenMpq
1927 Exit Sub
1928 End If
1929 ReDim FileList(0) As String
1930 If Right(CurPath, 1) <> "\" Then CurPath = CurPath + "\"
1931 sLine = Command
1932 If Right(sLine, 1) <> " " Then sLine = sLine + " "
1933 If sLine <> "" Then
1934 ReDim Param(0) As String
1935 For pNum = 1 To Len(sLine)
1936 If Mid(sLine, pNum, 1) = Chr(34) Then
1937 pNum = pNum + 1
1938 EndParam = InStr(pNum, sLine, Chr(34))
1939 If UBound(Param) = 1 Then ParamCutout = Mid(sLine, pNum - 1, (EndParam + 1) - (pNum - 1))
1940 Else
1941 EndParam = InStr(pNum, sLine, " ")
1942 If UBound(Param) = 1 Then ParamCutout = Mid(sLine, pNum, EndParam - pNum)
1943 End If
1944 If EndParam = 0 Then EndParam = Len(sLine) + 1
1945 If pNum <> EndParam Then
1946 If Trim(Mid(sLine, pNum, EndParam - pNum)) <> "" Then
1947 ReDim Preserve Param(UBound(Param) + 1) As String
1948 Param(UBound(Param)) = Trim(Mid(sLine, pNum, EndParam - pNum))
1949 End If
1950 End If
1951 pNum = EndParam
1952 Next pNum
1953 If UBound(Param) < 3 Then ReDim Preserve Param(3) As String
1954 Select Case LCase(Param(1))
1955 Case "o", "open", "n", "new"
1956 Show
1957 If Mid(OldStartPath, 2, 1) = ":" Then ChDrive Left(OldStartPath, 1)
1958 ChDir OldStartPath
1959 RunMpq2kCommand sLine
1960 Case "a", "add", "e", "extract", "r", "ren", "rename", "m", "move", "d", "del", "delete", "f", "flush", "compact", "l", "list"
1961 If Mid(OldStartPath, 2, 1) = ":" Then ChDrive Left(OldStartPath, 1)
1962 ChDir OldStartPath
1963 CD.FileName = FullPath(CurDir, Param(2))
1964 sLine = Left(sLine, InStr(sLine, ParamCutout) - 1) + Mid(sLine, InStr(sLine, ParamCutout) + Len(ParamCutout))
1965 RunMpq2kCommand sLine
1966 If Mid(NewStartPath, 2, 1) = ":" Then ChDrive Left(NewStartPath, 1)
1967 ChDir NewStartPath
1968 Unload Me
1969 Case "s", "script"
1970 Show
1971 If Mid(OldStartPath, 2, 1) = ":" Then ChDrive Left(OldStartPath, 1)
1972 ChDir OldStartPath
1973 RunMpq2kCommand sLine
1974 If Mid(NewStartPath, 2, 1) = ":" Then ChDrive Left(NewStartPath, 1)
1975 ChDir NewStartPath
1976 End Select
1977 End If
1978 End Sub
1979 Private Sub Form_Resize()
1980 On Error Resume Next
1981 If WindowState <> 1 Then
1982 List.Top = Toolbar.Height
1983 List.Width = ScaleWidth
1984 List.Height = ScaleHeight - List.Top - StatBar.Height - txtCommand.Height
1985 Label1.Top = List.Top + List.Height + (txtCommand.Height - Label1.Height) / 2
1986 txtCommand.Top = List.Top + List.Height
1987 txtCommand.Left = Label1.Width
1988 txtCommand.Width = ScaleWidth - cmdGo.Width - Label1.Width
1989 cmdGo.Top = txtCommand.Top
1990 cmdGo.Left = txtCommand.Left + txtCommand.Width
1991 mFilter.Width = ScaleWidth - mFilter.Left - Toolbar.Buttons.Item("List").Width
1992 Toolbar.Buttons.Item("filterspace").Width = mFilter.Width
1993 End If
1994 End Sub
1995 Private Sub Form_Unload(Cancel As Integer)
1996 Dim Path As String
1997 Path = App.Path
1998 If Right(Path, 1) <> "\" Then Path = Path + "\"
1999 On Error Resume Next
2000 If ExtractPathNum > -1 Then
2001 KillEx Path + "Temp_extract\" + CStr(ExtractPathNum) + "\", "*", 6, True
2002 RmDir Path + "Temp_extract\" + CStr(ExtractPathNum) + "\"
2003 End If
2004 If DirEx(Path + "Temp_extract\", "*", 6, True) = "" Or App.PrevInstance = False Then
2005 KillEx Path + "Temp_extract\", "*", 6, True
2006 RmDir Path + "Temp_extract\"
2007 End If
2008 If CopyPathNum > -1 Then
2009 KillEx Path + "Temp_copy\" + CStr(CopyPathNum) + "\", "*", 6, True
2010 RmDir Path + "Temp_copy\" + CStr(CopyPathNum) + "\"
2011 End If
2012 If DirEx(Path + "Temp_copy\", "*", 6, True) = "" Or App.PrevInstance = False Then
2013 KillEx Path + "Temp_copy\", "*", 6, True
2014 RmDir Path + "Temp_copy\"
2015 End If
2016 If GetReg(AppKey + "SaveWindowStatus", 1) > 0 Then
2017 NewKey AppKey
2018 NewKey AppKey + "Status\"
2019 If WindowState = 1 Then WindowState = 0
2020 SetReg AppKey + "Status\WindowState", WindowState, REG_DWORD
2021 WindowState = 0
2022 SetReg AppKey + "Status\WindowHeight", Height, REG_DWORD
2023 SetReg AppKey + "Status\WindowLeft", Left, REG_DWORD
2024 SetReg AppKey + "Status\WindowTop", Top, REG_DWORD
2025 SetReg AppKey + "Status\WindowWidth", Width, REG_DWORD
2026 End If
2027 If GetReg(AppKey + "StartupPathType", 0) <= 0 Then
2028 SetReg AppKey + "StartupPath", CurDir
2029 End If
2030 End
2031 End Sub
2032 Private Sub Label1_Click()
2033 txtCommand.SetFocus
2034 End Sub
2035 Private Sub List_AfterLabelEdit(Cancel As Integer, NewString As String)
2036 Dim result As Long, hMPQ As Long, hFile As Long
2037 If List.SelectedItem.Text <> NewString Then
2038 If GetReg(AppKey + "ShowConfirmation", 1) = 0 Then
2039 result = vbYes
2040 Else
2041 result = MsgBox("Rename file?", vbYesNo Or vbQuestion Or vbDefaultButton2, "WinMPQ")
2042 End If
2043 If result = vbYes Then
2044 List.SelectedItem.Tag = NewString
2045 hMPQ = mOpenMpq(CD.FileName)
2046 If hMPQ Then
2047 If SFileOpenFileEx(hMPQ, NewString, 0, hFile) Then
2048 SFileCloseFile hFile
2049 SFileSetLocale List.SelectedItem.ListSubItems(4).Tag
2050 MpqDeleteFile hMPQ, NewString
2051 MpqRenameFile hMPQ, List.SelectedItem.Text, NewString
2052 SFileSetLocale LocaleID
2053 RemoveDuplicates
2054 Else
2055 SFileSetLocale List.SelectedItem.ListSubItems(4).Tag
2056 MpqRenameFile hMPQ, List.SelectedItem.Text, NewString
2057 SFileSetLocale LocaleID
2058 End If
2059 MpqCloseUpdatedArchive hMPQ, 0
2060 On Error Resume Next
2061 List.SelectedItem.Key = NewString
2062 On Error GoTo 0
2063 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
2064 End If
2065 Else
2066 Cancel = True
2067 End If
2068 End If
2069 ShowSelected
2070 End Sub
2071 Private Sub List_Click()
2072 On Error GoTo NotSelected
2073 List.SelectedItem.Tag = List.SelectedItem.Tag
2074 On Error GoTo NotClick
2075 List.HitTest(CX, CY).Tag = List.HitTest(CX, CY).Tag
2076 On Error GoTo 0
2077 ShowSelected
2078 Exit Sub
2079 NotClick:
2080 List.SelectedItem.Selected = False
2081 NotSelected:
2082 ShowSelected
2083 BuildMpqActionList
2084 End Sub
2085 Private Sub List_ColumnClick(ByVal ColumnHeader As ColumnHeader)
2086 If List.SortKey = ColumnHeader.Index - 1 Then
2087 If List.SortOrder = 0 Then
2088 List.SortOrder = 1
2089 Else
2090 List.SortOrder = 0
2091 End If
2092 Else
2093 List.SortOrder = 0
2094 List.SortKey = ColumnHeader.Index - 1
2095 End If
2096 End Sub
2097 Private Sub List_DblClick()
2098 Dim fNum As Long, Path As String, fName As String, fName2 As String, bNum As Long, AlreadyInList As Boolean, hMPQ As Long
2099 On Error GoTo NotSelected
2100 List.SelectedItem.Tag = List.SelectedItem.Tag
2101 On Error GoTo NotClick
2102 List.HitTest(CX, CY).Tag = List.HitTest(CX, CY).Tag
2103 On Error GoTo 0
2104 Path = App.Path
2105 If Right(Path, 1) <> "\" Then Path = Path + "\"
2106 Path = Path + "Temp_extract\"
2107 If ExtractPathNum = -1 Then
2108 fNum = 0
2109 Do
2110 If DirEx(Path + CStr(fNum), "*", 6, True) = "" Then Exit Do
2111 fNum = fNum + 1
2112 Loop
2113 ExtractPathNum = fNum
2114 End If
2115 Path = Path + CStr(ExtractPathNum) + "\"
2116 If SFileOpenArchive(CD.FileName, 0, 0, hMPQ) = 0 Then Exit Sub
2117 For fNum = 1 To List.ListItems.Count
2118 If List.ListItems.Item(fNum).Selected Then
2119 StatBar.Style = 1
2120 StatBar.SimpleText = "Extracting " + List.ListItems.Item(fNum).Tag + "..."
2121 MousePointer = 11
2122 SFileSetLocale List.ListItems.Item(fNum).ListSubItems(4).Tag
2123 sGetFile hMPQ, List.ListItems.Item(fNum).Tag, Path, True
2124 SFileSetLocale LocaleID
2125 If GetReg(AppKey + "CheckModDateTime", 1) > 0 Then
2126 For bNum = 1 To UBound(OpenFiles)
2127 If LCase(OpenFiles(bNum)) = LCase(List.ListItems.Item(fNum).Tag) Then
2128 AlreadyInList = True
2129 If FileExists(FullPath(Path, List.ListItems.Item(fNum).Tag)) Then OpenFileDates(bNum) = FileDateTime(FullPath(Path, List.ListItems.Item(fNum).Tag))
2130 Exit For
2131 End If
2132 Next bNum
2133 If AlreadyInList = False Then
2134 ReDim Preserve OpenFiles(UBound(OpenFiles) + 1) As String, OpenFileDates(UBound(OpenFileDates) + 1) As Date
2135 OpenFiles(UBound(OpenFiles)) = List.ListItems.Item(fNum).Tag
2136 If FileExists(FullPath(Path, List.ListItems.Item(fNum).Tag)) Then OpenFileDates(UBound(OpenFileDates)) = FileDateTime(FullPath(Path, List.ListItems.Item(fNum).Tag))
2137 End If
2138 End If
2139 StatBar.Style = 1
2140 StatBar.SimpleText = "Opening " + List.ListItems.Item(fNum).Tag + "..."
2141 fName = List.ListItems.Item(fNum).Tag
2142 BuildPopup Path + fName, 0, mnuPopup, mnuPItem
2143 ExecuteFile Path + fName, 0, mnuPopup, mnuPItem
2144 If GetReg(AppKey + "CheckModDateTime", 1) > 0 Then Timer1.Enabled = True
2145 End If
2146 Next fNum
2147 SFileCloseArchive hMPQ
2148 StatBar.Style = 0
2149 StatBar.SimpleText = ""
2150 MousePointer = 0
2151 Exit Sub
2152 NotClick:
2153 List.SelectedItem.Selected = False
2154 NotSelected:
2155 End Sub
2156 Private Sub List_ItemClick(ByVal Item As ListItem)
2157 BuildMpqActionList
2158 End Sub
2159 Private Sub List_KeyPress(KeyAscii As Integer)
2160 If KeyAscii = 13 Then List_DblClick
2161 End Sub
2162 Private Sub List_KeyUp(KeyCode As Integer, Shift As Integer)
2163 If KeyCode = vbKeyDelete Then
2164 mnuMDelete_Click
2165 ElseIf KeyCode = 93 Or ((Shift And vbShiftMask) And KeyCode = vbKeyF10) Then
2166 On Error GoTo NotSelected
2167 List.SelectedItem.Tag = List.SelectedItem.Tag
2168 On Error GoTo 0
2169 If List.SelectedItem.Selected = True Then
2170 BuildPopup List.SelectedItem.Tag, Shift, mnuPopup, mnuPItem
2171 PopupMenu mnuPopup, vbPopupMenuRightButton, List.Left + List.SelectedItem.Left + 12 * Screen.TwipsPerPixelX, List.Top + List.SelectedItem.Top + 16 * Screen.TwipsPerPixelY, mnuPItem(0)
2172 End If
2173 End If
2174 NotSelected:
2175 End Sub
2176 Private Sub List_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
2177 CX = X
2178 CY = Y
2179 If Button And vbRightButton Then
2180 On Error GoTo NotSelected
2181 List.SelectedItem.Tag = List.SelectedItem.Tag
2182 On Error GoTo NotClick
2183 List.HitTest(CX, CY).Tag = List.HitTest(CX, CY).Tag
2184 On Error GoTo 0
2185 BuildPopup List.SelectedItem.Tag, Shift, mnuPopup, mnuPItem
2186 PopupMenu mnuPopup, vbPopupMenuRightButton, , , mnuPItem(0)
2187 End If
2188 NotClick:
2189 NotSelected:
2190 End Sub
2191 Private Sub List_OLECompleteDrag(Effect As Long)
2192 List.Tag = ""
2193 End Sub
2194 Private Sub List_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
2195 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
2196 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
2197 If Data.GetFormat(ccCFFiles) <> True Then Exit Sub
2198 For fNum = 1 To Data.Files.Count
2199 Path = Data.Files.Item(fNum)
2200 If Right(Path, 1) <> "\" Then Path = Path + "\"
2201 If IsDir(Path) Then
2202 Path = Path + "*"
2203 Data.Files.Remove fNum
2204 Data.Files.Add Path, fNum
2205 End If
2206 Next fNum
2207 Path = Data.Files.Item(1)
2208 For bNum = 1 To Len(Path)
2209 If InStr(bNum, Path, "\") > 0 Then
2210 For fNum = 1 To Data.Files.Count
2211 If Left(Data.Files.Item(fNum), InStr(bNum, Path, "\")) <> Left(Path, InStr(bNum, Path, "\")) Then GoTo PathFound
2212 Next fNum
2213 bNum = InStr(bNum, Path, "\")
2214 Else
2215 Exit For
2216 End If
2217 Next bNum
2218 PathFound:
2219 Path = Left(Path, bNum - 1)
2220 ReDim Files(0) As String
2221 Files(0) = Path
2222 If Right(Path, 1) <> "\" Then Path = Path + "\"
2223 ReDim Preserve Files(Data.Files.Count) As String
2224 For bNum = 1 To Data.Files.Count
2225 Files(bNum) = Mid(Data.Files.Item(bNum), 1 + Len(Path))
2226 For fNum = 1 To Len(Files(bNum))
2227 If InStr(fNum, Files(bNum), "\") > 0 Then
2228 fNum = InStr(fNum, Files(bNum), "\")
2229 Else
2230 Exit For
2231 End If
2232 Next fNum
2233 FolderFiles = FolderFiles + DirEx(Path + Left(Files(bNum), fNum - 1), Mid(Files(bNum), fNum), 6, True)
2234 Next bNum
2235 If FolderFiles = "" Then Exit Sub
2236 ReDim Preserve Files(0) As String
2237 For bNum = 1 To Len(FolderFiles)
2238 ReDim Preserve Files(UBound(Files) + 1) As String
2239 If InStr(bNum, FolderFiles, vbCrLf) > 0 Then
2240 Files(UBound(Files)) = Mid(FolderFiles, bNum + Len(Path), InStr(bNum, FolderFiles, vbCrLf) - bNum - Len(Path))
2241 bNum = InStr(bNum, FolderFiles, vbCrLf) + 1
2242 Else
2243 Files(UBound(Files)) = Mid(FolderFiles, bNum + Len(Path))
2244 Exit For
2245 End If
2246 Next bNum
2247 FoldName.Show 1
2248 If AddFolderName = Chr(0) + Chr(255) + Chr(127) + Chr(128) Then GoTo Cancel
2249 If UBound(Files) > 1 Then
2250 ReDim ShortFiles(UBound(Files)) As String
2251 For bNum = 0 To UBound(Files)
2252 ShortFiles(bNum) = AddFolderName + Files(bNum)
2253 Next bNum
2254 If Right(Files(0), 1) <> "\" Then Files(0) = Files(0) + "\"
2255 For bNum = 1 To UBound(Files)
2256 Files(bNum) = FullPath(Files(0), Files(bNum))
2257 Next bNum
2258 Else
2259 For bNum = 1 To Len(Files(1))
2260 If InStr(bNum, Files(1), "\") > 0 Then
2261 bNum = InStr(bNum, Files(1), "\")
2262 Else
2263 Exit For
2264 End If
2265 Next bNum
2266 ReDim ShortFiles(UBound(Files)) As String
2267 ShortFiles(1) = AddFolderName + Mid(Files(1), bNum)
2268 Files(1) = FullPath(Files(0), Files(1))
2269 End If
2270 If NewFile = True Then
2271 If FileExists(CD.FileName) Then Kill CD.FileName
2272 NewFile = False
2273 End If
2274 List.Sorted = False
2275 FileFilter = mFilter
2276 hMPQ = mOpenMpq(CD.FileName)
2277 If hMPQ = 0 Then
2278 StatBar.SimpleText = "Can't create archive " + CD.FileName
2279 Exit Sub
2280 End If
2281 dwFlags = MAFA_REPLACE_EXISTING
2282 If GlobalEncrypt Then dwFlags = dwFlags Or MAFA_ENCRYPT
2283 For bNum = 1 To UBound(Files)
2284 StatBar.Style = 1
2285 StatBar.SimpleText = "Adding " + Files(bNum) + "..."
2286 MousePointer = 11
2287 If mnuMCNone.Checked Then
2288 MpqAddFileToArchiveEx hMPQ, Files(bNum), ShortFiles(bNum), dwFlags, 0, 0
2289 ElseIf mnuMCStandard.Checked Then
2290 MpqAddFileToArchiveEx hMPQ, Files(bNum), ShortFiles(bNum), dwFlags Or MAFA_COMPRESS, MAFA_COMPRESS_STANDARD, 0
2291 ElseIf mnuMCDeflate.Checked Then
2292 MpqAddFileToArchiveEx hMPQ, Files(bNum), ShortFiles(bNum), dwFlags Or MAFA_COMPRESS, MAFA_COMPRESS_DEFLATE, DefaultCompressLevel
2293 ElseIf mnuMCAMedium.Checked Then
2294 MpqAddWaveToArchive hMPQ, Files(bNum), ShortFiles(bNum), dwFlags Or MAFA_COMPRESS, 0
2295 ElseIf mnuMCAHighest.Checked Then
2296 MpqAddWaveToArchive hMPQ, Files(bNum), ShortFiles(bNum), dwFlags Or MAFA_COMPRESS, 1
2297 ElseIf mnuMCALowest.Checked Then
2298 MpqAddWaveToArchive hMPQ, Files(bNum), ShortFiles(bNum), dwFlags Or MAFA_COMPRESS, 2
2299 ElseIf mnuMCAuto.Checked Then
2300 mAddAutoFile hMPQ, Files(bNum), ShortFiles(bNum)
2301 End If
2302 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
2303 mFilter.AddItem "*" + GetExtension(ShortFiles(bNum))
2304 For cNum = 1 To mFilter.ListCount - 1
2305 If LCase(mFilter.List(cNum)) = LCase(mFilter.List(cNum - 1)) Then
2306 mFilter.RemoveItem cNum
2307 Exit For
2308 End If
2309 Next cNum
2310 Next bNum
2311 MpqCloseUpdatedArchive hMPQ, 0
2312 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
2313 If SFileOpenArchive(CD.FileName, 0, 0, hMPQ) Then
2314 StatBar.SimpleText = "Adding files to listing... 0% complete"
2315 For bNum = 1 To UBound(Files)
2316 If MatchesFilter(ShortFiles(bNum), FileFilter) Then
2317 MpqAddToListing hMPQ, ShortFiles(bNum)
2318 End If
2319 On Error Resume Next
2320 StatBar.SimpleText = "Adding files to listing... " + CStr(Int((bNum / UBound(Files)) * 100)) + "% complete"
2321 On Error GoTo 0
2322 Next bNum
2323 SFileCloseArchive hMPQ
2324 End If
2325 StatBar.Style = 0
2326 StatBar.SimpleText = ""
2327 MousePointer = 0
2328 If MatchesFilter("(listfile)", FileFilter) Then
2329 AddToListing "(listfile)"
2330 End If
2331 mFilter = FileFilter
2332 List.Sorted = True
2333 RemoveDuplicates
2334 ShowTotal
2335 Cancel:
2336 End Sub
2337 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)
2338 If CD.FileName = "" Or Data.GetFormat(ccCFFiles) <> True Or List.Tag = "WinMPQ" Then
2339 Effect = ccOLEDropEffectNone
2340 Else
2341 Effect = ccOLEDropEffectCopy
2342 End If
2343 End Sub
2344 Private Sub List_OLESetData(Data As MSComctlLib.DataObject, DataFormat As Integer)
2345 Dim fNum As Long, Path As String, fCount As Long, FirstFile As String, hMPQ As Long
2346 Path = App.Path
2347 If Right(Path, 1) <> "\" Then Path = Path + "\"
2348 Path = Path + "Temp_copy\"
2349 If CopyPathNum = -1 Then
2350 fNum = 0
2351 Do
2352 If DirEx(Path + CStr(fNum), "*", 6, True) = "" Then Exit Do
2353 fNum = fNum + 1
2354 Loop
2355 CopyPathNum = fNum
2356 End If
2357 Path = Path + CStr(CopyPathNum) + "\"
2358 KillEx Path, "*", 6, True
2359 fCount = 0
2360 If SFileOpenArchive(CD.FileName, 0, 0, hMPQ) = 0 Then Exit Sub
2361 For fNum = 1 To List.ListItems.Count
2362 If List.ListItems.Item(fNum).Selected Then
2363 StatBar.Style = 1
2364 StatBar.SimpleText = "Extracting " + List.ListItems.Item(fNum).Tag + "..."
2365 MousePointer = 11
2366 SFileSetLocale List.ListItems.Item(fNum).ListSubItems(4).Tag
2367 sGetFile hMPQ, List.ListItems.Item(fNum).Tag, Path, True
2368 SFileSetLocale LocaleID
2369 If GetReg(AppKey + "UseDragDropWildcards", 1) = 0 Then
2370 Data.Files.Add Path + List.ListItems.Item(fNum).Tag
2371 End If
2372 fCount = fCount + 1
2373 If fCount = 1 Then FirstFile = Path + List.ListItems.Item(fNum).Tag
2374 End If
2375 Next fNum
2376 SFileCloseArchive hMPQ
2377 StatBar.Style = 0
2378 StatBar.SimpleText = ""
2379 MousePointer = 0
2380 If GetReg(AppKey + "UseDragDropWildcards", 1) <> 0 And fCount > 1 Then
2381 Data.Files.Add Path + "*"
2382 ElseIf fCount = 1 Then
2383 Data.Files.Add FirstFile
2384 End If
2385 End Sub
2386 Private Sub List_OLEStartDrag(Data As MSComctlLib.DataObject, AllowedEffects As Long)
2387 Data.SetData , ccCFFiles
2388 AllowedEffects = ccOLEDropEffectCopy
2389 List.Tag = "WinMPQ"
2390 End Sub
2391 Private Sub mFilter_KeyPress(KeyAscii As Integer)
2392 If KeyAscii = 13 And Toolbar.Buttons.Item("List").Enabled Then
2393 If NewFile = False Then OpenMpq
2394 End If
2395 End Sub
2396 Private Sub mnuFExit_Click()
2397 Unload Me
2398 End Sub
2399 Private Sub mnuFile_Click()
2400 If FileExists(CD.FileName) Then mnuFReopen.Enabled = True Else mnuFReopen.Enabled = False
2401 End Sub
2402 Private Sub mnuFRecent_Click(Index As Integer)
2403 Dim OldFileName As String
2404 OldFileName = CD.FileName
2405 CD.FileName = mnuFRecent(Index).Tag
2406 If FileExists(CD.FileName) = False Then
2407 CD.FileName = OldFileName
2408 MsgBox "The file " + Chr(34) + mnuFRecent(Index).Tag + Chr(34) + " does not exist.", vbExclamation, "WinMPQ"
2409 DelRecentFile mnuFRecent(Index).Tag
2410 Exit Sub
2411 End If
2412 OpenMpq
2413 If CD.FileName = "" Then
2414 CD.FileName = OldFileName
2415 DelRecentFile mnuFRecent(Index).Tag
2416 End If
2417 End Sub
2418 Private Sub mnuFReopen_Click()
2419 OpenMpq
2420 End Sub
2422 Private Sub mnuFScript_Click()
2423 Dim OldFileName As String, OldPath As String
2424 CD.Flags = &H1000 Or &H4 Or &H2
2425 CD.Filter = "All Files (*.*)|*.*"
2426 OldFileName = CD.FileName
2427 OldPath = CurDir
2428 CD.hwndOwner = hWnd
2429 If ShowOpen(CD) = False Then GoTo Cancel
2430 StatBar.Style = 1
2431 StatBar.SimpleText = "Running script " + CD.FileName + "..."
2432 MousePointer = 11
2433 RunScript CD.FileName
2434 StatBar.Style = 0
2435 StatBar.SimpleText = ""
2436 MousePointer = 0
2437 CD.FileName = OldFileName
2438 Cancel:
2439 If Mid(OldPath, 2, 1) = ":" Then ChDrive Left(OldPath, 1)
2440 ChDir OldPath
2441 End Sub
2442 Private Sub mnuHAbout_Click()
2443 About.Show 1
2444 End Sub
2445 Private Sub mnuHReadme_Click()
2446 Dim Path As String
2447 Path = App.Path
2448 If Right(Path, 1) <> "\" Then Path = Path + "\"
2449 If FileExists(Path + "WinMPQ.rtf") Then
2450 ShellExecute hWnd, vbNullString, Path + "WinMPQ.rtf", vbNullString, vbNullString, 1
2451 Else
2452 MsgBox "Could not find WinMPQ.rtf!", vbCritical, "WinMPQ"
2453 End If
2454 End Sub
2455 Private Sub mnuMAdd_Click()
2456 Dim Files() As String, ShortFiles() As String, bNum As Long, OldFileName As String, fNum As Long, cNum As Long, FileFilter As String
2457 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
2458 CD.Flags = OFN_EXPLORER Or &H1000 Or &H200 Or &H4 Or &H2
2459 CD.Filter = "All Files (*.*)|*.*"
2460 OldFileName = CD.FileName
2461 CD.hwndOwner = hWnd
2462 If ShowOpen(CD) = False Then GoTo Cancel
2463 ReDim Files(0) As String
2464 bNum = 1
2465 If InStr(1, CD.FileName, Chr(0)) > 0 Then
2466 Files(0) = Mid(CD.FileName, 1, InStr(1, CD.FileName, Chr(0)) - 1)
2467 bNum = InStr(1, CD.FileName, Chr(0)) + 1
2468 Else
2469 Files(0) = Mid(CD.FileName, 1)
2470 End If
2471 For bNum = bNum To Len(CD.FileName)
2472 ReDim Preserve Files(UBound(Files) + 1) As String
2473 If InStr(bNum, CD.FileName, Chr(0)) > 0 Then
2474 Files(UBound(Files)) = Mid(CD.FileName, bNum, InStr(bNum, CD.FileName, Chr(0)) - bNum)
2475 bNum = InStr(bNum, CD.FileName, Chr(0))
2476 Else
2477 Files(UBound(Files)) = Mid(CD.FileName, bNum)
2478 Exit For
2479 End If
2480 Next bNum
2481 CD.FileName = OldFileName
2482 FoldName.Show 1
2483 If AddFolderName = Chr(0) + Chr(255) + Chr(127) + Chr(128) Then GoTo Cancel
2484 If UBound(Files) > 1 Then
2485 ReDim ShortFiles(UBound(Files)) As String
2486 For bNum = 0 To UBound(Files)
2487 ShortFiles(bNum) = AddFolderName + Files(bNum)
2488 Next bNum
2489 If Right(Files(0), 1) <> "\" Then Files(0) = Files(0) + "\"
2490 For bNum = 1 To UBound(Files)
2491 Files(bNum) = FullPath(Files(0), Files(bNum))
2492 Next bNum
2493 Else
2494 For bNum = 1 To Len(Files(1))
2495 If InStr(bNum, Files(1), "\") > 0 Then
2496 bNum = InStr(bNum, Files(1), "\")
2497 Else
2498 Exit For
2499 End If
2500 Next bNum
2501 ReDim ShortFiles(UBound(Files)) As String
2502 ShortFiles(1) = AddFolderName + Mid(Files(1), bNum)
2503 Files(1) = FullPath(Files(0), Files(1))
2504 End If
2505 If NewFile = True Then
2506 If FileExists(CD.FileName) Then Kill CD.FileName
2507 NewFile = False
2508 End If
2509 List.Sorted = False
2510 FileFilter = mFilter
2511 hMPQ = mOpenMpq(CD.FileName)
2512 If hMPQ = 0 Then
2513 StatBar.SimpleText = "Can't create archive " + CD.FileName
2514 Exit Sub
2515 End If
2516 dwFlags = MAFA_REPLACE_EXISTING
2517 If GlobalEncrypt Then dwFlags = dwFlags Or MAFA_ENCRYPT
2518 For bNum = 1 To UBound(Files)
2519 StatBar.Style = 1
2520 StatBar.SimpleText = "Adding " + Files(bNum) + "..."
2521 MousePointer = 11
2522 If mnuMCNone.Checked Then
2523 MpqAddFileToArchiveEx hMPQ, Files(bNum), ShortFiles(bNum), dwFlags, 0, 0
2524 ElseIf mnuMCStandard.Checked Then
2525 MpqAddFileToArchiveEx hMPQ, Files(bNum), ShortFiles(bNum), dwFlags Or MAFA_COMPRESS, MAFA_COMPRESS_STANDARD, 0
2526 ElseIf mnuMCDeflate.Checked Then
2527 MpqAddFileToArchiveEx hMPQ, Files(bNum), ShortFiles(bNum), dwFlags Or MAFA_COMPRESS, MAFA_COMPRESS_DEFLATE, DefaultCompressLevel
2528 ElseIf mnuMCAMedium.Checked Then
2529 MpqAddWaveToArchive hMPQ, Files(bNum), ShortFiles(bNum), dwFlags Or MAFA_COMPRESS, 0
2530 ElseIf mnuMCAHighest.Checked Then
2531 MpqAddWaveToArchive hMPQ, Files(bNum), ShortFiles(bNum), dwFlags Or MAFA_COMPRESS, 1
2532 ElseIf mnuMCALowest.Checked Then
2533 MpqAddWaveToArchive hMPQ, Files(bNum), ShortFiles(bNum), dwFlags Or MAFA_COMPRESS, 2
2534 ElseIf mnuMCAuto.Checked Then
2535 mAddAutoFile hMPQ, Files(bNum), ShortFiles(bNum)
2536 End If
2537 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
2538 mFilter.AddItem "*" + GetExtension(ShortFiles(bNum))
2539 For cNum = 1 To mFilter.ListCount - 1
2540 If LCase(mFilter.List(cNum)) = LCase(mFilter.List(cNum - 1)) Then
2541 mFilter.RemoveItem cNum
2542 Exit For
2543 End If
2544 Next cNum
2545 Next bNum
2546 MpqCloseUpdatedArchive hMPQ, 0
2547 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
2548 If SFileOpenArchive(CD.FileName, 0, 0, hMPQ) Then
2549 StatBar.SimpleText = "Adding files to listing... 0% complete"
2550 For bNum = 1 To UBound(Files)
2551 If MatchesFilter(ShortFiles(bNum), FileFilter) Then
2552 MpqAddToListing hMPQ, ShortFiles(bNum)
2553 End If
2554 On Error Resume Next
2555 StatBar.SimpleText = "Adding files to listing... " + CStr(Int((bNum / UBound(Files)) * 100)) + "% complete"
2556 On Error GoTo 0
2557 Next bNum
2558 SFileCloseArchive hMPQ
2559 End If
2560 StatBar.Style = 0
2561 StatBar.SimpleText = ""
2562 MousePointer = 0
2563 If MatchesFilter("(listfile)", FileFilter) Then
2564 AddToListing "(listfile)"
2565 End If
2566 mFilter = FileFilter
2567 List.Sorted = True
2568 RemoveDuplicates
2569 ShowTotal
2570 Cancel:
2571 End Sub
2572 Private Sub mnuMAddFolder_Click()
2573 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
2574 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
2575 PathInput.hwndOwner = hWnd
2576 Path = PathInputBox(PathInput, "Folder to add files from...", CurDir)
2577 If Path = "" Then GoTo Cancel
2578 FolderFiles = DirEx(Path, "*", 6, True)
2579 If FolderFiles = "" Then Exit Sub
2580 ReDim Files(0) As String
2581 Files(0) = Path
2582 If Right(Path, 1) <> "\" Then Path = Path + "\"
2583 For bNum = 1 To Len(FolderFiles)
2584 ReDim Preserve Files(UBound(Files) + 1) As String
2585 If InStr(bNum, FolderFiles, vbCrLf) > 0 Then
2586 Files(UBound(Files)) = Mid(FolderFiles, bNum + Len(Path), InStr(bNum, FolderFiles, vbCrLf) - bNum - Len(Path))
2587 bNum = InStr(bNum, FolderFiles, vbCrLf) + 1
2588 Else
2589 Files(UBound(Files)) = Mid(FolderFiles, bNum + Len(Path))
2590 Exit For
2591 End If
2592 Next bNum
2593 FoldName.Show 1
2594 If AddFolderName = Chr(0) + Chr(255) + Chr(127) + Chr(128) Then GoTo Cancel
2595 If UBound(Files) > 1 Then
2596 ReDim ShortFiles(UBound(Files)) As String
2597 For bNum = 0 To UBound(Files)
2598 ShortFiles(bNum) = AddFolderName + Files(bNum)
2599 Next bNum
2600 If Right(Files(0), 1) <> "\" Then Files(0) = Files(0) + "\"
2601 For bNum = 1 To UBound(Files)
2602 Files(bNum) = FullPath(Files(0), Files(bNum))
2603 Next bNum
2604 Else
2605 For bNum = 1 To Len(Files(1))
2606 If InStr(bNum, Files(1), "\") > 0 Then
2607 bNum = InStr(bNum, Files(1), "\")
2608 Else
2609 Exit For
2610 End If
2611 Next bNum
2612 ReDim ShortFiles(UBound(Files)) As String
2613 ShortFiles(1) = AddFolderName + Mid(Files(1), bNum)
2614 Files(1) = FullPath(Files(0), Files(1))
2615 End If
2616 If NewFile = True Then
2617 If FileExists(CD.FileName) Then Kill CD.FileName
2618 NewFile = False
2619 End If
2620 List.Sorted = False
2621 FileFilter = mFilter
2622 hMPQ = mOpenMpq(CD.FileName)
2623 If hMPQ = 0 Then
2624 StatBar.SimpleText = "Can't create archive " + CD.FileName
2625 Exit Sub
2626 End If
2627 dwFlags = MAFA_REPLACE_EXISTING
2628 If GlobalEncrypt Then dwFlags = dwFlags Or MAFA_ENCRYPT
2629 For bNum = 1 To UBound(Files)
2630 StatBar.Style = 1
2631 StatBar.SimpleText = "Adding " + Files(bNum) + "..."
2632 MousePointer = 11
2633 If mnuMCNone.Checked Then
2634 MpqAddFileToArchiveEx hMPQ, Files(bNum), ShortFiles(bNum), dwFlags, 0, 0
2635 ElseIf mnuMCStandard.Checked Then
2636 MpqAddFileToArchiveEx hMPQ, Files(bNum), ShortFiles(bNum), dwFlags Or MAFA_COMPRESS, MAFA_COMPRESS_STANDARD, 0
2637 ElseIf mnuMCDeflate.Checked Then
2638 MpqAddFileToArchiveEx hMPQ, Files(bNum), ShortFiles(bNum), dwFlags Or MAFA_COMPRESS, MAFA_COMPRESS_DEFLATE, DefaultCompressLevel
2639 ElseIf mnuMCAMedium.Checked Then
2640 MpqAddWaveToArchive hMPQ, Files(bNum), ShortFiles(bNum), dwFlags Or MAFA_COMPRESS, 0
2641 ElseIf mnuMCAHighest.Checked Then
2642 MpqAddWaveToArchive hMPQ, Files(bNum), ShortFiles(bNum), dwFlags Or MAFA_COMPRESS, 1
2643 ElseIf mnuMCALowest.Checked Then
2644 MpqAddWaveToArchive hMPQ, Files(bNum), ShortFiles(bNum), dwFlags Or MAFA_COMPRESS, 2
2645 ElseIf mnuMCAuto.Checked Then
2646 mAddAutoFile hMPQ, Files(bNum), ShortFiles(bNum)
2647 End If
2648 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
2649 mFilter.AddItem "*" + GetExtension(ShortFiles(bNum))
2650 For cNum = 1 To mFilter.ListCount - 1
2651 If LCase(mFilter.List(cNum)) = LCase(mFilter.List(cNum - 1)) Then
2652 mFilter.RemoveItem cNum
2653 Exit For
2654 End If
2655 Next cNum
2656 Next bNum
2657 MpqCloseUpdatedArchive hMPQ, 0
2658 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
2659 If SFileOpenArchive(CD.FileName, 0, 0, hMPQ) Then
2660 StatBar.SimpleText = "Adding files to listing... 0% complete"
2661 For bNum = 1 To UBound(Files)
2662 If MatchesFilter(ShortFiles(bNum), FileFilter) Then
2663 MpqAddToListing hMPQ, ShortFiles(bNum)
2664 End If
2665 On Error Resume Next
2666 StatBar.SimpleText = "Adding files to listing... " + CStr(Int((bNum / UBound(Files)) * 100)) + "% complete"
2667 On Error GoTo 0
2668 Next bNum
2669 SFileCloseArchive hMPQ
2670 End If
2671 StatBar.Style = 0
2672 StatBar.SimpleText = ""
2673 MousePointer = 0
2674 If MatchesFilter("(listfile)", FileFilter) Then
2675 AddToListing "(listfile)"
2676 End If
2677 mFilter = FileFilter
2678 List.Sorted = True
2679 RemoveDuplicates
2680 ShowTotal
2681 Cancel:
2682 End Sub
2684 Private Sub mnuMAddToList_Click()
2685 frmAddToList.Show 1
2686 End Sub
2687 Private Sub mnuMCAHighest_Click()
2688 mnuMCNone.Checked = False
2689 mnuMCStandard.Checked = False
2690 mnuMCDeflate.Checked = False
2691 mnuMCALowest.Checked = False
2692 mnuMCAMedium.Checked = False
2693 mnuMCAHighest.Checked = True
2694 mnuMCAuto.Checked = False
2695 End Sub
2696 Private Sub mnuMCALowest_Click()
2697 mnuMCNone.Checked = False
2698 mnuMCStandard.Checked = False
2699 mnuMCDeflate.Checked = False
2700 mnuMCALowest.Checked = True
2701 mnuMCAMedium.Checked = False
2702 mnuMCAHighest.Checked = False
2703 mnuMCAuto.Checked = False
2704 End Sub
2707 Private Sub mnuMCAMedium_Click()
2708 mnuMCNone.Checked = False
2709 mnuMCStandard.Checked = False
2710 mnuMCDeflate.Checked = False
2711 mnuMCALowest.Checked = False
2712 mnuMCAMedium.Checked = True
2713 mnuMCAHighest.Checked = False
2714 mnuMCAuto.Checked = False
2715 End Sub
2716 Private Sub mnuMCAuto_Click()
2717 mnuMCNone.Checked = False
2718 mnuMCStandard.Checked = False
2719 mnuMCDeflate.Checked = False
2720 mnuMCALowest.Checked = False
2721 mnuMCAMedium.Checked = False
2722 mnuMCAHighest.Checked = False
2723 mnuMCAuto.Checked = True
2724 End Sub
2726 Private Sub mnuMCDeflate_Click()
2727 mnuMCNone.Checked = False
2728 mnuMCStandard.Checked = False
2729 mnuMCDeflate.Checked = True
2730 mnuMCALowest.Checked = False
2731 mnuMCAMedium.Checked = False
2732 mnuMCAHighest.Checked = False
2733 mnuMCAuto.Checked = False
2734 End Sub
2737 Private Sub mnuMChLCID_Click()
2738 Dim fNum As Long
2739 On Error GoTo NotSelected
2740 List.SelectedItem.Tag = List.SelectedItem.Tag
2741 On Error GoTo 0
2742 For fNum = 1 To List.ListItems.Count
2743 If List.ListItems.Item(fNum).Selected Then
2744 GoTo FileSelected
2745 End If
2746 Next fNum
2747 GoTo NotSelected
2748 FileSelected:
2749 ChLCID.Show 1
2750 Exit Sub
2751 NotSelected:
2752 MsgBox "No files are selected.", , "WinMPQ"
2753 End Sub
2754 Private Sub mnuMCNone_Click()
2755 mnuMCNone.Checked = True
2756 mnuMCStandard.Checked = False
2757 mnuMCDeflate.Checked = False
2758 mnuMCALowest.Checked = False
2759 mnuMCAMedium.Checked = False
2760 mnuMCAHighest.Checked = False
2761 mnuMCAuto.Checked = False
2762 End Sub
2763 Private Sub mnuMCompact_Click()
2764 Dim fNum As Long, result As Long, hMPQ As Long
2765 If GetReg(AppKey + "ShowConfirmation", 1) = 0 Then
2766 result = vbYes
2767 Else
2768 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")
2769 End If
2770 If result = vbYes Then
2771 StatBar.Style = 1
2772 StatBar.SimpleText = "Compacting " + CD.FileName + "..."
2773 MousePointer = 11
2774 hMPQ = mOpenMpq(CD.FileName)
2775 If hMPQ Then
2776 MpqCompactArchive hMPQ
2777 MpqCloseUpdatedArchive hMPQ, 0
2778 End If
2779 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
2780 StatBar.Style = 0
2781 StatBar.SimpleText = ""
2782 MousePointer = 0
2783 OpenMpq
2784 End If
2785 End Sub
2786 Private Sub mnuMCStandard_Click()
2787 mnuMCNone.Checked = False
2788 mnuMCStandard.Checked = True
2789 mnuMCDeflate.Checked = False
2790 mnuMCALowest.Checked = False
2791 mnuMCAMedium.Checked = False
2792 mnuMCAHighest.Checked = False
2793 mnuMCAuto.Checked = False
2794 End Sub
2795 Private Sub mnuMDelete_Click()
2796 Dim fNum As Long, result As Long, hMPQ As Long
2797 On Error GoTo NotSelected
2798 List.SelectedItem.Tag = List.SelectedItem.Tag
2799 On Error GoTo 0
2800 For fNum = 1 To List.ListItems.Count
2801 If List.ListItems.Item(fNum).Selected Then
2802 GoTo FileSelected
2803 End If
2804 Next fNum
2805 GoTo NotSelected
2806 FileSelected:
2807 If GetReg(AppKey + "ShowConfirmation", 1) = 0 Then
2808 result = vbYes
2809 Else
2810 result = MsgBox("Delete file(s)?", vbYesNo Or vbQuestion Or vbDefaultButton2, "WinMPQ")
2811 End If
2812 If result = vbYes Then
2813 fNum = 1
2814 hMPQ = mOpenMpq(CD.FileName)
2815 If hMPQ Then
2816 Do While fNum <= List.ListItems.Count
2817 If List.ListItems.Item(fNum).Selected Then
2818 StatBar.Style = 1
2819 StatBar.SimpleText = "Deleting " + List.ListItems.Item(fNum).Tag + "..."
2820 MousePointer = 11
2821 SFileSetLocale List.ListItems.Item(fNum).ListSubItems(4).Tag
2822 MpqDeleteFile hMPQ, List.ListItems.Item(fNum).Tag
2823 SFileSetLocale LocaleID
2824 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
2825 List.ListItems.Remove (fNum)
2826 fNum = fNum - 1
2827 End If
2828 fNum = fNum + 1
2829 Loop
2830 MpqCloseUpdatedArchive hMPQ, 0
2831 End If
2832 End If
2833 StatBar.Style = 0
2834 StatBar.SimpleText = ""
2835 MousePointer = 0
2836 ShowSelected
2837 ShowTotal
2838 Exit Sub
2839 NotSelected:
2840 MsgBox "No files are selected.", , "WinMPQ"
2841 End Sub
2842 Private Sub mnuMEncrypt_Click()
2843 If mnuMEncrypt.Checked = False Then
2844 mnuMEncrypt.Checked = True
2845 GlobalEncrypt = True
2846 Else
2847 mnuMEncrypt.Checked = False
2848 GlobalEncrypt = False
2849 End If
2850 End Sub
2851 Private Sub mnuMExtract_Click()
2852 Dim fNum As Long, Path As String, result As Long, hMPQ As Long
2853 On Error GoTo NotSelected
2854 List.SelectedItem.Tag = List.SelectedItem.Tag
2855 On Error GoTo 0
2856 For fNum = 1 To List.ListItems.Count
2857 If List.ListItems.Item(fNum).Selected Then
2858 GoTo FileSelected
2859 End If
2860 Next fNum
2861 GoTo NotSelected
2862 FileSelected:
2863 PathInput.hwndOwner = hWnd
2864 Path = PathInputBox(PathInput, "Extract file(s) to...", CurDir)
2865 If Path = "" Then Exit Sub
2866 If Right(Path, 1) <> "\" Then Path = Path + "\"
2867 If SFileOpenArchive(CD.FileName, 0, 0, hMPQ) = 0 Then Exit Sub
2868 For fNum = 1 To List.ListItems.Count
2869 If List.ListItems.Item(fNum).Selected Then
2870 StatBar.Style = 1
2871 StatBar.SimpleText = "Extracting " + List.ListItems.Item(fNum).Tag + "..."
2872 MousePointer = 11
2873 SFileSetLocale List.ListItems.Item(fNum).ListSubItems(4).Tag
2874 sGetFile hMPQ, List.ListItems.Item(fNum).Tag, Path, True
2875 SFileSetLocale LocaleID
2876 End If
2877 Next fNum
2878 SFileCloseArchive hMPQ
2879 StatBar.Style = 0
2880 StatBar.SimpleText = ""
2881 MousePointer = 0
2882 Exit Sub
2883 NotSelected:
2884 If GetReg(AppKey + "ShowConfirmation", 1) = 0 Then
2885 result = vbYes
2886 Else
2887 result = MsgBox("No files are selected." + vbCrLf + "Extract all listed files?", vbYesNo Or vbQuestion Or vbDefaultButton2, "WinMPQ")
2888 End If
2889 If result = vbYes Then
2890 PathInput.hwndOwner = hWnd
2891 Path = PathInputBox(PathInput, "Extract file(s) to...", CurDir)
2892 If Path = "" Then Exit Sub
2893 If Right(Path, 1) <> "\" Then Path = Path + "\"
2894 If SFileOpenArchive(CD.FileName, 0, 0, hMPQ) = 0 Then Exit Sub
2895 For fNum = 1 To List.ListItems.Count
2896 StatBar.Style = 1
2897 StatBar.SimpleText = "Extracting " + List.ListItems.Item(fNum).Tag + "..."
2898 MousePointer = 11
2899 SFileSetLocale List.ListItems.Item(fNum).ListSubItems(4).Tag
2900 sGetFile hMPQ, List.ListItems.Item(fNum).Tag, Path, True
2901 SFileSetLocale LocaleID
2902 Next fNum
2903 SFileCloseArchive hMPQ
2904 StatBar.Style = 0
2905 StatBar.SimpleText = ""
2906 MousePointer = 0
2907 End If
2908 End Sub
2909 Private Sub mnuFNew_Click()
2910 Dim TItem As Menu
2911 CD.Flags = &H1000 Or &H4 Or &H2
2912 CD.DefaultExt = "mpq"
2913 CD.Filter = "Mpq Archives (*.mpq;*.exe;*.snp;*.scm;*.scx;*.w3m)|*.mpq;*.exe;*.snp;*.scm;*.scx;*.w3m|All Files (*.*)|*.*"
2914 CD.hwndOwner = hWnd
2915 If ShowSave(CD) = False Then GoTo Cancel
2916 ReDim FileList(0) As String
2917 List.ListItems.Clear
2918 ShowSelected
2919 ShowTotal
2920 NewFile = True
2921 ReDim OpenFiles(0) As String, OpenFileDates(0) As Date
2922 mnuMpq.Enabled = True
2923 For Each TItem In mnuTItem
2924 TItem.Enabled = True
2925 Next TItem
2926 Toolbar.Buttons.Item("Add").Enabled = True
2927 Toolbar.Buttons.Item("Add Folder").Enabled = True
2928 Toolbar.Buttons.Item("Extract").Enabled = True
2929 Toolbar.Buttons.Item("Compact").Enabled = True
2930 Toolbar.Buttons.Item("List").Enabled = True
2931 Caption = "WinMPQ - " + CD.FileTitle
2932 AddRecentFile CD.FileName
2933 Cancel:
2934 End Sub
2935 Private Sub mnuFOpen_Click()
2936 Dim OldFileName As String
2937 CD.Flags = &H1000 Or &H4 Or &H2
2938 CD.Filter = "Mpq Archives (*.mpq;*.exe;*.snp;*.scm;*.scx;*.w3m)|*.mpq;*.exe;*.snp;*.scm;*.scx;*.w3m|All Files (*.*)|*.*"
2939 OldFileName = CD.FileName
2940 CD.hwndOwner = hWnd
2941 If ShowOpen(CD) = False Then GoTo Cancel
2942 OpenMpq
2943 If CD.FileName = "" Then CD.FileName = OldFileName
2944 Cancel:
2945 End Sub
2946 Private Sub mnuMItem_Click(Index As Integer)
2947 FileActionClick mnuMpq, mnuMItem, Index
2948 End Sub
2949 Private Sub mnuMRename_Click()
2950 List.StartLabelEdit
2951 End Sub
2952 Private Sub mnuMSaveList_Click()
2953 Dim fNum As Long, fList As String, OldFileName As String
2954 CD.Flags = &H1000 Or &H4 Or &H2
2955 CD.DefaultExt = "txt"
2956 CD.Filter = "Text File (*.txt)|*.txt|All Files (*.*)|*.*"
2957 OldFileName = CD.FileName
2958 CD.FileName = CD.FileName + ".txt"
2959 CD.hwndOwner = hWnd
2960 If ShowSave(CD) = False Then GoTo Cancel
2961 StatBar.Style = 1
2962 StatBar.SimpleText = "Creating list..."
2963 MousePointer = 11
2964 For fNum = 1 To List.ListItems.Count
2965 fList = fList + List.ListItems.Item(fNum).Tag + vbCrLf
2966 Next fNum
2967 fNum = FreeFile
2968 Open CD.FileName For Binary As #fNum
2969 Put #fNum, 1, fList
2970 Close #fNum
2971 Cancel:
2972 CD.FileName = OldFileName
2973 StatBar.Style = 0
2974 StatBar.SimpleText = ""
2975 MousePointer = 0
2976 End Sub
2977 Private Sub mnuOptions_Click()
2978 Options.Show 1
2979 End Sub
2981 Private Sub mnuPChLCID_Click()
2982 mnuMChLCID_Click
2983 End Sub
2984 Private Sub mnuPDelete_Click()
2985 mnuMDelete_Click
2986 End Sub
2987 Private Sub mnuPExtract_Click()
2988 mnuMExtract_Click
2989 End Sub
2990 Private Sub mnuPItem_Click(Index As Integer)
2991 FileActionClick mnuPopup, mnuPItem, Index
2992 End Sub
2993 Private Sub mnuPRename_Click()
2994 mnuMRename_Click
2995 End Sub
2996 Private Sub mnuPTItem_Click(Index As Integer)
2997 mnuTItem_Click Index
2998 End Sub
2999 Private Sub mnuTAdd_Click()
3000 ToolList.Show 1
3001 BuildToolsList
3002 End Sub
3003 Private Sub mnuTItem_Click(Index As Integer)
3004 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
3005 Param = mnuTItem(Index).Tag
3006 On Error GoTo NoProgram
3007 If Param = "" Then Err.Raise 53
3008 On Error GoTo 0
3009 Do
3010 If InStr(1, Param, "%mpq", 1) Then
3011 bNum = InStr(1, Param, "%mpq", 1)
3012 Param = Left(Param, bNum - 1) + CD.FileName + Mid(Param, bNum + 4)
3013 End If
3014 Loop While InStr(1, Param, "%mpq", 1)
3015 NewParam = Param
3016 On Error GoTo NotSelected
3017 List.SelectedItem.Tag = List.SelectedItem.Tag
3018 On Error GoTo 0
3019 If List.SelectedItem.Selected Then FileName = List.SelectedItem.Tag
3020 NotSelected:
3021 If FileName <> "" And (InStr(Param, "%1") Or (InStr(Param, "%1") = 0 And InStr(1, mnuTItem(Index).Tag, "%mpq", 1) = 0)) Then
3022 Path = App.Path
3023 If Right(Path, 1) <> "\" Then Path = Path + "\"
3024 Path = Path + "Temp_extract\"
3025 If ExtractPathNum = -1 Then
3026 fNum = 0
3027 Do
3028 If DirEx(Path + CStr(fNum), "*", 6, True) = "" Then Exit Do
3029 fNum = fNum + 1
3030 Loop
3031 ExtractPathNum = fNum
3032 End If
3033 Path = Path + CStr(ExtractPathNum) + "\"
3034 If SFileOpenArchive(CD.FileName, 0, 0, hMPQ) = 0 Then Exit Sub
3035 For fNum = 1 To List.ListItems.Count
3036 If List.ListItems.Item(fNum).Selected Then
3037 StatBar.Style = 1
3038 StatBar.SimpleText = "Extracting " + List.ListItems.Item(fNum).Tag + "..."
3039 MousePointer = 11
3040 SFileSetLocale List.ListItems.Item(fNum).ListSubItems(4).Tag
3041 sGetFile hMPQ, List.ListItems.Item(fNum).Tag, Path, True
3042 SFileSetLocale LocaleID
3043 If GetReg(AppKey + "CheckModDateTime", 1) > 0 Then
3044 For bNum = 1 To UBound(OpenFiles)
3045 If LCase(OpenFiles(bNum)) = LCase(List.ListItems.Item(fNum).Tag) Then
3046 AlreadyInList = True
3047 If FileExists(FullPath(Path, List.ListItems.Item(fNum).Tag)) Then OpenFileDates(bNum) = FileDateTime(FullPath(Path, List.ListItems.Item(fNum).Tag))
3048 Exit For
3049 End If
3050 Next bNum
3051 If AlreadyInList = False Then
3052 ReDim Preserve OpenFiles(UBound(OpenFiles) + 1) As String, OpenFileDates(UBound(OpenFileDates) + 1) As Date
3053 OpenFiles(UBound(OpenFiles)) = List.ListItems.Item(fNum).Tag
3054 If FileExists(FullPath(Path, List.ListItems.Item(fNum).Tag)) Then OpenFileDates(UBound(OpenFileDates)) = FileDateTime(FullPath(Path, List.ListItems.Item(fNum).Tag))
3055 End If
3056 End If
3057 StatBar.Style = 1
3058 StatBar.SimpleText = "Opening " + List.ListItems.Item(fNum).Tag + "..."
3059 FileName = FullPath(Path, List.ListItems.Item(fNum).Tag)
3060 UseFile = True
3061 Param = NewParam
3062 Do
3063 If InStr(Param, "%1") = 0 And InStr(1, mnuTItem(Index).Tag, "%mpq", 1) = 0 Then
3064 If FileName <> "" Then
3065 Param = Param + " " + FileName
3066 End If
3067 ElseIf InStr(Param, Chr(34) + "%1" + Chr(34)) Then
3068 bNum = InStr(Param, Chr(34) + "%1" + Chr(34))
3069 If FileName <> "" Then
3070 Param = Left(Param, bNum - 1) + Chr(34) + FileName + Chr(34) + Mid(Param, bNum + 4)
3071 Else
3072 Param = Left(Param, bNum - 1) + Mid(Param, bNum + 4)
3073 End If
3074 ElseIf InStr(Param, "%1") Then
3075 bNum = InStr(Param, "%1")
3076 If FileName <> "" Then
3077 Param = Left(Param, bNum - 1) + FileName + Mid(Param, bNum + 2)
3078 Else
3079 Param = Left(Param, bNum - 1) + Mid(Param, bNum + 2)
3080 End If
3081 End If
3082 Loop While InStr(Param, "%1")
3083 On Error GoTo NoProgram
3084 Shell Param, 1
3085 On Error GoTo 0
3086 If GetReg(AppKey + "CheckModDateTime", 1) > 0 Then Timer1.Enabled = True
3087 End If
3088 Next fNum
3089 SFileCloseArchive hMPQ
3090 ElseIf InStr(1, mnuTItem(Index).Tag, "%mpq", 1) Then
3091 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
3092 On Error GoTo NoProgram
3093 Shell Param, 1
3094 On Error GoTo 0
3095 Timer1.Enabled = True
3096 Else
3097 MsgBox "No files are selected.", , "WinMPQ"
3098 End If
3099 If FileName <> "" Then
3100 StatBar.Style = 0
3101 StatBar.SimpleText = ""
3102 MousePointer = 0
3103 End If
3104 Exit Sub
3105 NoProgram:
3106 If Err.Number = 53 Then MsgBox "No program is assigned for this action.", , "WinMPQ"
3107 End Sub
3109 Private Sub mnuTMpqEmbed_Click()
3110 frmMpq.Show
3111 End Sub
3112 Private Sub Timer1_Timer()
3113 Dim fNum As Long, Path As String, result As Long, bNum As Long, hMPQ As Long, dwFlags As Long
3114 If Screen.ActiveForm.Name <> "MpqEx" Then Exit Sub
3115 Path = App.Path
3116 If Right(Path, 1) <> "\" Then Path = Path + "\"
3117 Path = Path + "Temp_extract\"
3118 Path = Path + CStr(ExtractPathNum) + "\"
3119 For fNum = 1 To UBound(OpenFiles)
3120 If FileExists(FullPath(Path, OpenFiles(fNum))) Then
3121 If FileDateTime(FullPath(Path, OpenFiles(fNum))) > OpenFileDates(fNum) Then
3122 If GetReg(AppKey + "ShowConfirmation", 1) = 0 Then
3123 result = vbYes
3124 Else
3125 result = MsgBox("File " + OpenFiles(fNum) + " has been changed since it was extracted." + vbCrLf + vbCrLf + "Update archive with this file?", vbYesNo Or vbInformation, "WinMPQ")
3126 End If
3127 If FileExists(FullPath(Path, OpenFiles(fNum))) Then
3128 OpenFileDates(fNum) = FileDateTime(FullPath(Path, OpenFiles(fNum)))
3129 If result = vbYes Then
3130 List.Sorted = False
3131 StatBar.Style = 1
3132 StatBar.SimpleText = "Adding " + OpenFiles(fNum) + "..."
3133 MousePointer = 11
3134 dwFlags = MAFA_REPLACE_EXISTING
3135 If GlobalEncrypt Then dwFlags = dwFlags Or MAFA_ENCRYPT
3136 hMPQ = mOpenMpq(CD.FileName)
3137 If hMPQ Then
3138 If mnuMCNone.Checked Then
3139 MpqAddFileToArchiveEx hMPQ, FullPath(Path, OpenFiles(fNum)), OpenFiles(fNum), dwFlags, 0, 0
3140 ElseIf mnuMCStandard.Checked Then
3141 MpqAddFileToArchiveEx hMPQ, FullPath(Path, OpenFiles(fNum)), OpenFiles(fNum), dwFlags Or MAFA_COMPRESS, MAFA_COMPRESS_STANDARD, 0
3142 ElseIf mnuMCDeflate.Checked Then
3143 MpqAddFileToArchiveEx hMPQ, FullPath(Path, OpenFiles(fNum)), OpenFiles(fNum), dwFlags Or MAFA_COMPRESS, MAFA_COMPRESS_DEFLATE, DefaultCompressLevel
3144 ElseIf mnuMCAMedium.Checked Then
3145 MpqAddWaveToArchive hMPQ, FullPath(Path, OpenFiles(fNum)), OpenFiles(fNum), dwFlags Or MAFA_COMPRESS, 0
3146 ElseIf mnuMCAHighest.Checked Then
3147 MpqAddWaveToArchive hMPQ, FullPath(Path, OpenFiles(fNum)), OpenFiles(fNum), dwFlags Or MAFA_COMPRESS, 1
3148 ElseIf mnuMCALowest.Checked Then
3149 MpqAddWaveToArchive hMPQ, FullPath(Path, OpenFiles(fNum)), OpenFiles(fNum), dwFlags Or MAFA_COMPRESS, 2
3150 ElseIf mnuMCAuto.Checked Then
3151 mAddAutoFile hMPQ, FullPath(Path, OpenFiles(fNum)), OpenFiles(fNum)
3152 End If
3153 End If
3154 MpqAddToListing hMPQ, OpenFiles(fNum)
3155 MpqCloseUpdatedArchive hMPQ, 0
3156 If FileExists(CD.FileName) Then MpqDate = FileDateTime(CD.FileName)
3157 StatBar.Style = 0
3158 StatBar.SimpleText = ""
3159 MousePointer = 0
3160 List.Sorted = True
3161 RemoveDuplicates
3162 ShowTotal
3163 End If
3164 End If
3165 End If
3166 Else
3167 For bNum = fNum To UBound(OpenFiles) - 1
3168 OpenFiles(bNum) = OpenFiles(bNum + 1)
3169 OpenFileDates(bNum) = OpenFileDates(bNum + 1)
3170 Next bNum
3171 ReDim Preserve OpenFiles(UBound(OpenFiles) - 1) As String, OpenFileDates(UBound(OpenFileDates) - 1) As Date
3172 fNum = fNum - 1
3173 If UBound(OpenFiles) = 0 Then Timer1.Enabled = False
3174 End If
3175 If fNum >= UBound(OpenFiles) Then Exit For
3176 Next fNum
3177 If FileExists(CD.FileName) Then
3178 If FileDateTime(CD.FileName) <> MpqDate And NewFile = False Then OpenMpq
3179 Else
3180 OpenMpq
3181 End If
3182 End Sub
3183 Private Sub Toolbar_ButtonClick(ByVal Button As Button)
3184 Select Case Button.Key
3185 Case "New"
3186 mnuFNew_Click
3187 Case "Open"
3188 mnuFOpen_Click
3189 Case "Add"
3190 mnuMAdd_Click
3191 Case "Add Folder"
3192 mnuMAddFolder_Click
3193 Case "Extract"
3194 mnuMExtract_Click
3195 Case "Compact"
3196 mnuMCompact_Click
3197 Case "List"
3198 If NewFile = False Then OpenMpq
3199 End Select
3200 End Sub
3201 Private Sub txtCommand_GotFocus()
3202 cmdGo.Default = True
3203 txtCommandHasFocus = True
3204 StatBar.Style = 1
3205 StatBar.SimpleText = "Current directory: " + Chr(34) + CurDir + Chr(34)
3206 End Sub
3207 Private Sub txtCommand_LostFocus()
3208 cmdGo.Default = False
3209 txtCommandHasFocus = False
3210 StatBar.Style = 0
3211 StatBar.SimpleText = ""
3212 End Sub
|