forked from syntax53/Nightmare-Redux
-
Notifications
You must be signed in to change notification settings - Fork 0
/
frmMain.frm
3135 lines (2680 loc) · 96.1 KB
/
frmMain.frm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.2#0"; "mscomctl.OCX"
Object = "{20D5284F-7B23-4F0A-B8B1-6C9D18B64F1C}#1.0#0"; "exlimiter.ocx"
Object = "{AA61DC5D-A4D1-4F73-AF2B-208862262908}#3.0#0"; "NMRTaskBar.ocx"
Begin VB.MDIForm frmMain
BackColor = &H00000000&
Caption = "Nightmare Redux"
ClientHeight = 8250
ClientLeft = 165
ClientTop = 450
ClientWidth = 10635
Icon = "frmMain.frx":0000
LinkTopic = "MDIForm1"
Picture = "frmMain.frx":08CA
StartUpPosition = 2 'CenterScreen
Begin NMRTaskBar.ctlTaskBar tbTaskBar
Align = 1 'Align Top
Height = 375
Left = 0
TabIndex = 1
Top = 0
Width = 10635
_ExtentX = 18759
_ExtentY = 661
ButtonHeight = 22
End
Begin MSComctlLib.StatusBar stsStatusBar
Align = 2 'Align Bottom
Height = 255
Left = 0
TabIndex = 0
Top = 7995
Width = 10635
_ExtentX = 18759
_ExtentY = 450
_Version = 393216
BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628}
NumPanels = 5
BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628}
Alignment = 1
AutoSize = 2
Object.Width = 3519
MinWidth = 3528
EndProperty
BeginProperty Panel2 {8E3867AB-8586-11D1-B16A-00C0F0283628}
Alignment = 1
AutoSize = 2
Object.Width = 2302
MinWidth = 2293
EndProperty
BeginProperty Panel3 {8E3867AB-8586-11D1-B16A-00C0F0283628}
Alignment = 1
AutoSize = 2
Object.Width = 3175
MinWidth = 3175
EndProperty
BeginProperty Panel4 {8E3867AB-8586-11D1-B16A-00C0F0283628}
Alignment = 1
AutoSize = 2
Object.Width = 2461
MinWidth = 2470
EndProperty
BeginProperty Panel5 {8E3867AB-8586-11D1-B16A-00C0F0283628}
AutoSize = 1
Object.Width = 8819
MinWidth = 8819
EndProperty
EndProperty
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin exlimiter.EL EL1
Left = 9780
Top = 7140
_ExtentX = 1270
_ExtentY = 1270
End
Begin VB.Menu mnuFile
Caption = "&File"
Begin VB.Menu mnuSettings
Caption = "&Settings"
Shortcut = {F2}
End
Begin VB.Menu mnuDisableWrite
Caption = "&Disable DB Writing"
Shortcut = {F4}
End
Begin VB.Menu mnusep
Caption = "-"
Index = 0
End
Begin VB.Menu mnuExit
Caption = "E&xit"
End
End
Begin VB.Menu mnuEdit
Caption = "&Editors"
Begin VB.Menu mnuEditAction
Caption = "Actio&ns"
Shortcut = ^N
End
Begin VB.Menu mnuEditBankbooks
Caption = "&Bankbooks"
Shortcut = ^B
End
Begin VB.Menu mnuEditClass
Caption = "C&lasses"
Shortcut = ^L
End
Begin VB.Menu mnuEditGangs
Caption = "&Gangs"
Shortcut = ^G
End
Begin VB.Menu mnuEditItem
Caption = "&Items"
Shortcut = ^I
End
Begin VB.Menu mnuEditMessage
Caption = "M&essages"
Shortcut = ^E
End
Begin VB.Menu mnuEditMonster
Caption = "&Monsters"
Shortcut = ^M
End
Begin VB.Menu mnuEditRace
Caption = "&Races"
Shortcut = ^R
End
Begin VB.Menu mnuEditRoom
Caption = "R&ooms"
Shortcut = ^O
End
Begin VB.Menu mnuEditShop
Caption = "S&hops"
Shortcut = ^H
End
Begin VB.Menu mnuEditSpell
Caption = "&Spells"
Shortcut = ^S
End
Begin VB.Menu mnuEditTextblock
Caption = "&Textblocks"
Shortcut = ^T
End
Begin VB.Menu mnuEditUser
Caption = "&Users"
Shortcut = ^U
End
End
Begin VB.Menu mnuTools
Caption = "&Tools"
Begin VB.Menu mnuDatabase
Caption = "&Databases"
Begin VB.Menu mnuakjhfw
Caption = "External Database Actions--"
Enabled = 0 'False
End
Begin VB.Menu mnuDatabaseExporter
Caption = "&Export Records"
Shortcut = {F12}
End
Begin VB.Menu mnuDatabaseIndexChange
Caption = "Monster Group/Index Changer"
End
Begin VB.Menu mnuRecordChanger
Caption = "&Record Number Changer"
Shortcut = +{F12}
End
Begin VB.Menu mnuMMUDExplorer
Caption = "Export to &MMUD Explorer"
Shortcut = ^{F12}
End
Begin VB.Menu mnuaslqkjrg
Caption = "Internal Database Actions--"
Enabled = 0 'False
End
Begin VB.Menu mnuDatabaseImporter
Caption = "&Import Records"
Shortcut = {F11}
End
Begin VB.Menu mnuDatabaseDeleter
Caption = "&Delete Records"
End
End
Begin VB.Menu mnuItem
Caption = "&Items"
Begin VB.Menu mnuLimitedItemList
Caption = "&Build Limited Item List"
Shortcut = ^{F8}
End
Begin VB.Menu mnuFindItem
Caption = "&Find an Item"
Shortcut = ^{F3}
End
Begin VB.Menu mnuItemsFixUses
Caption = "Fix Number of Uses"
End
Begin VB.Menu mnuNoLimited
Caption = "No Limited &Items"
End
Begin VB.Menu mnuNoLevelRestrictions
Caption = "No Level &Restrictions"
End
End
Begin VB.Menu mnuMonster
Caption = "&Monsters"
Begin VB.Menu mnuMonsterAttackSim
Caption = "&Attack Simulator"
End
Begin VB.Menu mnuDivideExp
Caption = "&Divide All Exp"
End
Begin VB.Menu mnuExp
Caption = "&Multiply All Exp"
End
Begin VB.Menu mnuMultiplyBossExp
Caption = "Multiply &Boss Exp"
End
Begin VB.Menu mnuMonsterItemDropPct
Caption = "Modify Item Drop Percentages"
End
Begin VB.Menu mnuMonstersCombineExp
Caption = "Combine Exp and Exp Multi Fields"
End
Begin VB.Menu mnudash
Caption = "-"
End
Begin VB.Menu mnuResetMonsterKillsToTime
Caption = "&Set Last Killed Times to Date"
End
Begin VB.Menu mnuResetMonsterKills
Caption = "&Reset Last Killed Times to Zero"
End
Begin VB.Menu mnudash2
Caption = "-"
End
Begin VB.Menu mnuFixMonsterUses
Caption = "Fix Number of &Uses on Item Drops"
End
End
Begin VB.Menu mnuRooms
Caption = "R&ooms"
Begin VB.Menu mnuChangeRoomCallLetters
Caption = "&Change dat call letters"
End
Begin VB.Menu mnuMassRoomEditor
Caption = "&Mass Room Editor"
Shortcut = ^{F5}
End
Begin VB.Menu mnufds
Caption = "-"
End
Begin VB.Menu mnuRoomPad
Caption = "&Insert Buffer Rooms"
End
Begin VB.Menu mnuDeleteBufferRooms
Caption = "&Delete Buffer Rooms"
End
Begin VB.Menu mnudash3
Caption = "-"
End
Begin VB.Menu mnuRoomsCombineItems
Caption = "Combine like items on floor"
End
End
Begin VB.Menu mnuShops
Caption = "S&hops"
Begin VB.Menu mnuShopRestock
Caption = "&Restock All Shops"
End
End
Begin VB.Menu mnuTextblocks
Caption = "&Textblocks"
Begin VB.Menu mnuStripChars
Caption = "&Strip characters off the end"
End
End
Begin VB.Menu mnuUsers
Caption = "&Users"
Begin VB.Menu mnuDatabaseMerge
Caption = "&Merge Users"
End
Begin VB.Menu mnuUserModifyGang
Caption = "Change &Gang on All Users"
End
Begin VB.Menu mnuRetrainUsers
Caption = "&Retrain All Users"
End
End
Begin VB.Menu mnusep6
Caption = "-"
End
Begin VB.Menu mnuAbilityEditor
Caption = "&Ability List Editor"
Shortcut = {F6}
End
Begin VB.Menu mnuControlRoomList
Caption = "Create Control Room List"
End
Begin VB.Menu mnuBuildMonsterIndex
Caption = "Create Monster/&Index List"
Shortcut = ^D
End
Begin VB.Menu mnuMonsterNPCList
Caption = "Create N&PC/Room List"
Shortcut = ^P
End
Begin VB.Menu mnuExpCalculator
Caption = "E&xp Calculator"
End
Begin VB.Menu mnuSwingCalculator
Caption = "S&wing Calculator"
End
Begin VB.Menu mnuUniversalModifier
Caption = "&Universal Modifier"
Shortcut = {F7}
End
Begin VB.Menu mnuQuestOrganizer
Caption = "&Quest Organizer"
Shortcut = {F9}
End
Begin VB.Menu mnusep5
Caption = "-"
End
Begin VB.Menu mnuCompileUpdateMenu
Caption = "&Compile Update File"
Begin VB.Menu mnuCompileUpdate
Caption = "Compile Full Update File"
Shortcut = {F8}
End
Begin VB.Menu mnuCompileBlank
Caption = "Compile Blank Update File"
Shortcut = +{F8}
End
End
End
Begin VB.Menu mnuWindow
Caption = "&Window"
WindowList = -1 'True
Begin VB.Menu mnuCascade
Caption = "C&ascade Windows"
End
Begin VB.Menu mnuCloseAll
Caption = "&Close All Windows"
Shortcut = +{F4}
End
Begin VB.Menu mnuMinimizeWindows
Caption = "&Minimize All Windows"
Shortcut = +{F3}
End
Begin VB.Menu mnuRestoreWindows
Caption = "&Restore All Windows"
Shortcut = +{F2}
End
Begin VB.Menu mnusep4
Caption = "-"
Visible = 0 'False
End
Begin VB.Menu mnuUnDock
Caption = "UnDock Current Window"
Visible = 0 'False
End
End
Begin VB.Menu mnuHelp
Caption = "&Help"
Begin VB.Menu mnuHelpGeneral
Caption = "&General Info"
Shortcut = {F1}
End
Begin VB.Menu mnuHelpMessages
Caption = "&Messages"
End
Begin VB.Menu mnuHelpMonsters
Caption = "&Monsters"
End
Begin VB.Menu mnuHelpRooms
Caption = "&Rooms"
End
Begin VB.Menu mnuHelpTextblocks
Caption = "&Textblocks"
End
Begin VB.Menu mnusep2
Caption = "-"
End
Begin VB.Menu mnuHelpChangeLog
Caption = "&Change Log"
End
Begin VB.Menu mnuHelpBug
Caption = "&Bug or Suggestion?"
End
Begin VB.Menu mnuAbout2
Caption = "&About"
End
End
Begin VB.Menu mnuLimitedRightClick
Caption = "limited list right click"
Visible = 0 'False
Begin VB.Menu mnuLimitedCopyLine
Caption = "Copy Line to clipboard"
End
End
Begin VB.Menu mnuItemFindRightClick
Caption = "item find right click"
Visible = 0 'False
Begin VB.Menu mnuItemFindCopyLine
Caption = "Copy Line to clipboard"
End
End
Begin VB.Menu mnuMonsterIndexRightClick
Caption = "monster index right click"
Visible = 0 'False
Begin VB.Menu mnuMonsterIndexCopyLine
Caption = "Copy Line to clipboard"
End
End
Begin VB.Menu mnuMonsterNPCListRightClick
Caption = "monster npc lis right click"
Visible = 0 'False
Begin VB.Menu mnuMonsterListCopyLine
Caption = "Copy Line to clipboard"
End
End
Begin VB.Menu mnuMapUp
Caption = "MapUp"
Visible = 0 'False
Begin VB.Menu mnuMapUpFollow
Caption = "Follow Up and Redraw"
End
Begin VB.Menu mnuMapUpRedraw
Caption = "Redraw from here"
End
End
Begin VB.Menu mnuMapDown
Caption = "MapDown"
Visible = 0 'False
Begin VB.Menu mnuMapDownFollow
Caption = "Follow Down and Redraw"
End
Begin VB.Menu mnuMapDownRedraw
Caption = "Redraw from here"
End
End
Begin VB.Menu mnuMapUpDown
Caption = "MapUpDown"
Visible = 0 'False
Begin VB.Menu mnuMapUpDownFollowUp
Caption = "Follow Up and Redraw"
End
Begin VB.Menu mnuMapUpDownFollowDown
Caption = "Follow Down and Redraw"
End
Begin VB.Menu mnuMapUpDownRedraw
Caption = "Redraw from here"
End
End
Begin VB.Menu mnuMapEditorUp
Caption = "MapEditorUp"
Visible = 0 'False
Begin VB.Menu mnuMapEditorUpFollow
Caption = "Follow Up and Redraw"
End
Begin VB.Menu mnuMapEditorUpRedraw
Caption = "Redraw from here"
End
End
Begin VB.Menu mnuMapEditorDown
Caption = "MapEditorDown"
Visible = 0 'False
Begin VB.Menu mnuMapEditorDownFollow
Caption = "Follow Down and Redraw"
End
Begin VB.Menu mnuMapEditorDownRedraw
Caption = "Redraw from here"
End
End
Begin VB.Menu mnuMapEditorUpDown
Caption = "MapEditorUpDown"
Visible = 0 'False
Begin VB.Menu mnuMapEditorUpDownFollowUp
Caption = "Follow Up and Redraw"
End
Begin VB.Menu mnuMapEditorUpDownFollowDown
Caption = "Follow Down and Redraw"
End
Begin VB.Menu mnuMapEditorUpDownRedraw
Caption = "Redraw from here"
End
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Base 0
Option Explicit
Dim bStopProcess As Boolean
Dim bWarnedAboutCopy As Boolean
Private Sub MDIForm_Load()
On Error GoTo error:
Dim nTmp As Integer
Dim fso As FileSystemObject
sAppVersion = "v" & App.Major & "." & App.Minor _
& IIf(App.Revision > 0, "." & App.Revision, "") _
& IIf(WorksWithN = True, "n", "")
sMenuCaption = App.Title & " " & sAppVersion
Load frmSplash
frmSplash.lblStatus.Caption = "Loading ..."
'frmSplash.Left = frmMain.Width / 4
'frmSplash.Top = frmMain.Height / 4
frmSplash.Show
DoEvents
Set fso = CreateObject("Scripting.FileSystemObject")
Call LockMenus
' & "." & App.Revision & " BETA"
Me.Caption = sMenuCaption
With EL1
.FormInQuestion = Me
.EnableLimiter = True
.MINHEIGHT = 470
.MINWIDTH = 580
.CenterOnLoad = True
End With
If Right(App.Path, 1) = "\" Then
sINIFileName = App.Path & "settings.ini"
Else
sINIFileName = App.Path & "\settings.ini"
End If
If fso.FileExists(sINIFileName) = False Then Call CreateSettings
If Val(ReadINI("Windows", "MainNoMax")) = 0 Then
Me.WindowState = vbMaximized
Else
Me.Width = ReadINI("Windows", "MainWidth")
Me.Height = ReadINI("Windows", "MainHeight")
End If
Call Startup
If ReadINI("Settings", "DisableWriting") = "1" Then
mnuDisableWrite.Checked = True
bDisableWriting = True
Me.Caption = sMenuCaption & " -- *DB WRITING DISABLED*"
stsStatusBar.Panels(1).Text = "*WRITING DISABLED*"
Else
mnuDisableWrite.Checked = False
bDisableWriting = False
Me.Caption = sMenuCaption
stsStatusBar.Panels(1).Text = ""
End If
DoEvents
Unload frmSplash
DoEvents
Call UnLockMenus
Me.Show
Me.Enabled = True
Set fso = Nothing
DoEvents
Exit Sub
error:
Call HandleError("Main_Load")
Resume Next
End Sub
Private Sub MDIForm_Resize()
On Error Resume Next
' frmLogo.Left = Me.Width - 8700
' frmLogo.Top = Me.Height - 2200
End Sub
Private Sub mnuBuildMonsterIndex_Click()
On Error GoTo error:
If FormIsLoaded("frmMonsterIndex") Then
frmMonsterIndex.SetFocus
Else
frmMonsterIndex.Show
End If
Exit Sub
error:
Call HandleError
End Sub
Private Sub mnuCascade_Click()
Me.Arrange (vbCascade)
End Sub
Private Sub mnuChangeRoomCallLetters_Click()
On Error GoTo error:
Dim sLetters As String, nRoom As Long, nStatus As Integer, x As Integer, sFile As String
sLetters = InputBox("This will change every text string in the rooms database that refers to files " _
& "with the specified call letters below to your current call letter setting." _
& vbCrLf & vbCrLf & "So if you specified 'CC' and your current setting is 'BB', it would change occurances like " _
& "'WCCMAP01.ANS' to 'WBBMAP01.ANS' and 'WCC89615.HSE' to 'WBB89615.HSE'. " _
& vbCrLf & vbCrLf & "(It scanes room descriptions, room name, and ansi map)" _
& vbCrLf & vbCrLf & "Enter call letters to change FROM: " _
& vbCrLf & "(They will be changed to your current setting of " & strDatCallLetters & ")", "Change Call Letters", "cc")
If sLetters = "" Then Exit Sub
If bDisableWriting = True Then MsgBox "Writing Currently Disabled -- Check out the File menu.", vbInformation: Exit Sub
nStatus = BTRCALL(BGETFIRST, RoomPosBlock, Roomdatabuf, Len(Roomdatabuf), ByVal RoomKeyBuffer, KEY_BUF_LEN, 0)
If Not nStatus = 0 Then MsgBox "Error getting first room, error: " & BtrieveErrorCode(nStatus): Exit Sub
frmProgressBar.sCaption = "Changing room call letters"
frmProgressBar.lblCaption = "Changing room call letters ..."
frmProgressBar.cmdCancel.Enabled = True
frmProgressBar.ProgressBar.Value = 0
frmProgressBar.lblPanel(0).Caption = "w" & strDatCallLetters & "mp002.dat"
frmProgressBar.lblPanel(1).Caption = ""
frmProgressBar.Show
frmMain.Enabled = False
DoEvents
nStatus = BTRCALL(BSTAT, RoomPosBlock, DBStatDatabuf, Len(Roomdatabuf), 0, KEY_BUF_LEN, 0)
DBStatRowToStruct DBStatDatabuf.buf
Call frmProgressBar.SetRange(DBStat.nRecords)
nStatus = BTRCALL(BGETFIRST, RoomPosBlock, Roomdatabuf, Len(Roomdatabuf), ByVal RoomKeyBuffer, KEY_BUF_LEN, 0)
bStopProcess = False
nRoom = 0
Do While nStatus = 0 And bStopProcess = False
RoomRowToStruct Roomdatabuf.buf
nRoom = nRoom + 1
frmProgressBar.lblPanel(1).Caption = nRoom
Call frmProgressBar.IncreaseProgress
Roomrec.AnsiMap = ChangeCallLetters(sLetters, Roomrec.AnsiMap)
Roomrec.Name = ChangeCallLetters(sLetters, Roomrec.Name)
For x = 0 To 6
Roomrec.Desc(x) = ChangeCallLetters(sLetters, Roomrec.Desc(x))
Next x
nStatus = UpdateRoom
If Not nStatus = 0 Then Exit Do
nStatus = BTRCALL(BGETNEXT, RoomPosBlock, Roomdatabuf, Len(Roomdatabuf), ByVal RoomKeyBuffer, KEY_BUF_LEN, 0)
If Not bUseCPU Then DoEvents
Loop
If bStopProcess = True Then GoTo kill:
If Not nStatus = 9 And Not nStatus = 0 Then
MsgBox "Abnormal Exit: " & BtrieveErrorCode(nStatus), vbOKOnly + vbExclamation
Else
frmProgressBar.ProgressBar.Value = frmProgressBar.ProgressBar.Max
DoEvents
MsgBox "Complete!", vbInformation
End If
kill:
frmMain.Enabled = True
Unload frmProgressBar
If Me.Visible Then Me.SetFocus
Exit Sub
error:
Call HandleError
On Error Resume Next
frmMain.Enabled = True
Unload frmProgressBar
End Sub
Private Sub mnuCloseAll_Click()
UnloadForms (Me.Name)
End Sub
Private Sub mnuCompileBlank_Click()
If bDisableWriting = True Then MsgBox "Writing Currently Disabled -- Check out the File menu.", vbInformation: Exit Sub
Call CompileUpdatefile(True)
End Sub
Private Sub mnuControlRoomList_Click()
On Error GoTo error:
If FormIsLoaded("frmRoomControlRoomList") Then
frmRoomControlRoomList.SetFocus
Else
frmRoomControlRoomList.Show
End If
Exit Sub
error:
Call HandleError
End Sub
Private Sub mnuDatabaseIndexChange_Click()
Unload frmMonsterIndexChanger
Load frmMonsterIndexChanger
End Sub
Private Sub mnuDatabaseMerge_Click()
Unload frmDatabaseMerge
Load frmDatabaseMerge
End Sub
Private Sub mnuDeleteBufferRooms_Click()
On Error GoTo error:
Dim nMap As Long, nRoom As Long, nStatus As Integer, x As Integer, sFile As String
Dim fso As FileSystemObject, ts As TextStream, nPrevRoom As Long, nPrevMap As Long
Dim nLastRoom As Long, nYesNo As Integer, bAll As Boolean, nMaxRooms As Long
nMap = Val(InputBox("This will delete any rooms on the chosen map which name begins with ""Buffer Room""." _
& vbCrLf & "Enter a value of -1 to delete buffer rooms on all maps." _
& vbCrLf & vbCrLf & "Enter map number to delete buffer rooms on:", "Delete buffer rooms", 1))
If nMap = 0 Then Exit Sub
If nMap = -1 Then bAll = True
If nMap < -1 Then Exit Sub
If bDisableWriting = True Then MsgBox "Writing Currently Disabled -- Check out the File menu.", vbInformation: Exit Sub
nStatus = BTRCALL(BGETFIRST, RoomPosBlock, Roomdatabuf, Len(Roomdatabuf), ByVal RoomKeyBuffer, KEY_BUF_LEN, 0)
If Not nStatus = 0 Then MsgBox "Error getting first room, error: " & BtrieveErrorCode(nStatus): Exit Sub
Set fso = CreateObject("Scripting.FileSystemObject")
If Right(App.Path, 1) = "\" Then
sFile = App.Path & "NMR-Log_RoomBufDelete.txt"
Else
sFile = App.Path & "\NMR-Log_RoomBufDelete.txt"
End If
If fso.FileExists(sFile) Then Call fso.DeleteFile(sFile, True)
Set ts = fso.OpenTextFile(sFile, ForWriting, True)
ts.WriteLine ("Buffer room delete job started " & Date & " @ " & Time)
ts.WriteBlankLines (1)
frmProgressBar.sCaption = "Deleting buffer rooms"
frmProgressBar.lblCaption = "Deleting buffer rooms ..."
frmProgressBar.cmdCancel.Enabled = True
frmProgressBar.ProgressBar.Value = 0
frmProgressBar.lblPanel(0).Caption = "w" & strDatCallLetters & "mp002.dat"
frmProgressBar.lblPanel(1).Caption = ""
frmProgressBar.Show
frmMain.Enabled = False
DoEvents
bStopProcess = False
nStatus = BTRCALL(BSTAT, RoomPosBlock, DBStatDatabuf, Len(Roomdatabuf), 0, KEY_BUF_LEN, 0)
If Not nStatus = 0 Then
nMaxRooms = 30000
Else
DBStatRowToStruct DBStatDatabuf.buf
nMaxRooms = DBStat.nRecords
End If
Call frmProgressBar.SetRange(nMaxRooms)
nStatus = BTRCALL(BGETFIRST, RoomPosBlock, Roomdatabuf, Len(Roomdatabuf), ByVal RoomKeyBuffer, KEY_BUF_LEN, 0)
bStopProcess = False
Do While nStatus = 0 And bStopProcess = False
RoomRowToStruct Roomdatabuf.buf
If Roomrec.MapNumber = nMap Or bAll Then
If UCase(Left(Roomrec.Name, 11)) = "BUFFER ROOM" Then
nStatus = BTRCALL(BDELETE, RoomPosBlock, Roomdatabuf, Len(Roomdatabuf), ByVal RoomKeyBuffer, KEY_BUF_LEN, 0)
If Not nStatus = 0 Then
MsgBox "Error deleting Map " & Roomrec.MapNumber & " Room " & Roomrec.RoomNumber & ", Error: " & BtrieveErrorCode(nStatus)
GoTo kill:
End If
ts.WriteLine "Deleted Room: Map " & Roomrec.MapNumber & " Room " & Roomrec.RoomNumber
End If
Call frmProgressBar.IncreaseProgress
frmProgressBar.lblPanel(1).Caption = Roomrec.MapNumber & "/" & Roomrec.RoomNumber
End If
nStatus = BTRCALL(BGETNEXT, RoomPosBlock, Roomdatabuf, Len(Roomdatabuf), ByVal RoomKeyBuffer, KEY_BUF_LEN, 0)
If Not bUseCPU Then DoEvents
Loop
If bStopProcess = True Then
ts.WriteLine "...canceled by user"
GoTo kill:
End If
If Not nStatus = 0 And Not nStatus = 9 Then
ts.WriteLine "Exited because of btrieve error: " & BtrieveErrorCode(nStatus)
MsgBox "Abnormal Exit: " & BtrieveErrorCode(nStatus), vbOKOnly + vbExclamation
Else
ts.WriteBlankLines (1)
ts.WriteLine ("Complete: " & Date & " @ " & Time)
frmProgressBar.ProgressBar.Value = frmProgressBar.ProgressBar.Max
DoEvents
nYesNo = MsgBox("Complete, view log?", vbYesNo + vbQuestion, "View?")
If nYesNo = vbYes Then Call ShellExecute(0&, "open", sFile, vbNullString, vbNullString, vbNormalFocus)
DoEvents
End If
kill:
On Error Resume Next
ts.Close
Set ts = Nothing
Set fso = Nothing
frmMain.Enabled = True
Unload frmProgressBar
If Me.Visible Then Me.SetFocus
Exit Sub
error:
Call HandleError
Resume kill:
End Sub
Private Sub mnuDisableWrite_Click()
If mnuDisableWrite.Checked = False Then
mnuDisableWrite.Checked = True
bDisableWriting = True
Me.Caption = sMenuCaption & " -- *DB WRITING DISABLED*"
stsStatusBar.Panels(1).Text = "*WRITING DISABLED*"
Else
mnuDisableWrite.Checked = False
bDisableWriting = False
Me.Caption = sMenuCaption
stsStatusBar.Panels(1).Text = ""
End If
End Sub
Private Sub mnuDivideExp_Click()
On Error GoTo error:
Dim nStatus As Integer, nYesNo As Long, nTemp As Double, nDivisor As Integer
Dim nBase As Double, nMulti As Double, nMultiMax As Double, x As Double
nDivisor = Val(InputBox("Divide monster exp by how many times (2-20)?" & vbCrLf & "(Minimum exp will be 1)", "Monster EXP Divider", "2"))
If nDivisor <= 0 Then Exit Sub
If nDivisor > 20 Then nDivisor = 20
If nDivisor < 2 Then nDivisor = 2
If bDisableWriting = True Then MsgBox "Writing Currently Disabled -- Check out the File menu.", vbInformation: Exit Sub
nYesNo = MsgBox("Are you sure you want to DIVIDE monster EXP by " & nDivisor & "?", vbYesNo + vbQuestion + vbDefaultButton2)
If nYesNo <> vbYes Then Exit Sub
UnloadForms (Me.Name)
frmProgressBar.sCaption = "Dividing Monster EXP"
frmProgressBar.lblCaption.Caption = "Dividing Monster EXP ..."
frmProgressBar.cmdCancel.Enabled = True
frmProgressBar.lblPanel(0).Caption = "w" & strDatCallLetters & "knms2.dat"
frmProgressBar.Show
frmMain.Enabled = False
DoEvents
nStatus = BTRCALL(BGETFIRST, MonsterPosBlock, Monsterdatabuf, Len(Monsterdatabuf), ByVal MonsterKeyBuffer, KEY_BUF_LEN, 0)
If Not nStatus = 0 Then
MsgBox "BGETFIRST, Error: " & BtrieveErrorCode(nStatus)
GoTo finish:
Else
nStatus = BTRCALL(BSTAT, MonsterPosBlock, DBStatDatabuf, Len(Monsterdatabuf), 0, KEY_BUF_LEN, 0)
If Not nStatus = 0 Then
Call frmProgressBar.SetRange(30000)
Else
DBStatRowToStruct DBStatDatabuf.buf
Call frmProgressBar.SetRange(DBStat.nRecords)
End If
nStatus = BTRCALL(BGETFIRST, MonsterPosBlock, Monsterdatabuf, Len(Monsterdatabuf), ByVal MonsterKeyBuffer, KEY_BUF_LEN, 0)
End If
bStopProcess = False
Do While nStatus = 0 And bStopProcess = False
MonsterRowToStruct Monsterdatabuf.buf
frmProgressBar.lblPanel(1).Caption = Monsterrec.Number
Call frmProgressBar.IncreaseProgress
If eDatFileVersion >= v111j Then
If Monsterrec.ExpMulti = 1 Or Monsterrec.ExpMulti = 0 Then
nBase = SLong2ULong(Monsterrec.Experience)
nBase = Round(nBase / nDivisor)
If nBase <= 0 Then nBase = 1
If nBase > 2147483646 Then nBase = 2147483646
Monsterrec.Experience = ULong2SLong(nBase)
Else
nBase = SLong2ULong(Monsterrec.Experience) * SLong2ULong(Monsterrec.ExpMulti)
nBase = Round(nBase / nDivisor)
If nBase > 2147483646 Then nBase = 2147483646
tryagain:
If nBase > 100000 Then
nMultiMax = 20
For x = 20 To 32767
If x * 65538 >= nBase Then
nMultiMax = x
Exit For
End If
Next x
nMulti = 1
For x = 3 To nMultiMax
nTemp = nBase Mod x
If nTemp = 0 Then nMulti = x
Next x
If nMulti = 1 Then
nBase = nBase - 1
GoTo tryagain:
End If
nBase = nBase / nMulti
Else
nMulti = 1
End If
If nBase <= 0 Then nBase = 1
Monsterrec.Experience = ULong2SLong(nBase)
Monsterrec.ExpMulti = ULong2SLong(nMulti)
End If
Else
nBase = SLong2ULong(Monsterrec.Experience)
nBase = Round(nBase / nDivisor)
If nBase <= 0 Then nBase = 1
Monsterrec.Experience = ULong2SLong(nBase)
End If
nStatus = UpdateMonster
If Not nStatus = 0 Then
MsgBox "Update record Error, " & BtrieveErrorCode(nStatus)
GoTo finish:
End If
nStatus = BTRCALL(BGETNEXT, MonsterPosBlock, Monsterdatabuf, Len(Monsterdatabuf), ByVal MonsterKeyBuffer, KEY_BUF_LEN, 0)
DoEvents
Loop
If bStopProcess = True Then GoTo finish:
If Not nStatus = 9 And Not nStatus = 0 Then
MsgBox "Abnormal Exit: " & BtrieveErrorCode(nStatus), vbOKOnly + vbExclamation
Else
frmProgressBar.ProgressBar.Value = frmProgressBar.ProgressBar.Max
DoEvents
MsgBox "Complete!", vbInformation
End If
finish:
frmMain.Enabled = True
Unload frmProgressBar
If Me.Visible Then Me.SetFocus
Exit Sub
error:
Call HandleError
frmMain.Enabled = True
Unload frmProgressBar
End Sub
Private Sub mnuAbilityEditor_Click()
On Error GoTo error:
If bAbilityDBOpen = False Then
MsgBox "The ability database was never opened successfully, reload program.", vbOKOnly + vbExclamation
Exit Sub
End If
Unload frmAbilityEdit
Load frmAbilityEdit
Exit Sub
error:
Call HandleError
End Sub
Public Sub mnuEditAction_Click()
On Error GoTo error:
If FormIsLoaded("frmAction") = True Then
Call CopyActionForm
Else
Unload frmAction
Load frmAction
End If
Exit Sub