Google Groups no longer supports new Usenet posts or subscriptions. Historical content remains viewable.

Dismiss

A Mud In Visual Basic 5?

1 view

Skip to first unread message

Anne-Lise Pasch

unread,

Apr 11, 1998, 3:00:00 AM4/11/98

Hi...

I'm currently working on a mud server in VB5.

Its runnable, its stable, it can technically handle up to 32000
players, but realistically does 500 on a well-resourced pentium.

Its *not* event orientated - I tried that path but it fell down.
It uses ActiveX controls as objects. (Char.ocx, Env.ocx, Object.ocx,
Monster.ocx) with the commands in bas files.

At the moment, on my pentium 133 testbed, it handles roughly 930
player commands per heartbeat (650 milliseconds). On a P2 300+ it
ramps up to around 4-5000 commands to the heartbeat, thus facilitating
8000+ players. (If you has insane bandwidth/memory) My testbed has
32MB ram and comfortably holds 50 players, 500 rooms, 250 monsters and
an assortment of objects (Be they weapons, armour or just items)

I'm currently having fun with the combat code - as anyone who has
programmed mud is aware, its not simple at all. I'm a long time MudOS
coder, and I'm pretty au fait with the mechanics, but its not a job
for one person.

My mud daemon has been set up to handle the usual fantasy stat
system... Charisma, Constitution, Dex... What I would like is a
non-copyright set of Algorithms that could be implemented.

EG. My sever limb algorithm:

If (LostHP > (CurrentHP / 2)) And (Random(100) > (Constitution * 5)
Then SeverLimb(CurrentSelectedLimb)

Here is the last completed code revision for interested VB users to
look at. If you're interested in helping out and are moderate with VB,
let me know. The source code and sample database mudlib are available
on request. (It weighs in at around 1.5 MB for the source and mdb
file) I wont send the executable because its about 20 times the size
of the source code, and you really need to compile the ocx files on
your own machines anyway... At least until I have a releasable
installation set (IE. Combat works properly.)

Lastly, if anyone has a fairly endowed pentium and available bandwidth
and a stable site and they wouldn't mind hosting a mud after its ready
(Not very likely I know) I'm eager to hear from you!

Always yours,
Anne-Lise.

Library.bas:

Option Explicit
Sub Clean(Index As Integer, Subdued As Integer)
Dim a&, b%, d&, e&, g%, h&, i%
On Error Resume Next
i = Index
b = Subdued
d = EMDMain.Character(i).LimbCount
If d > 0 Then
For e = 1 To d
a = EMDMain.Character(i).GetLimbWieldedWeapon(e)
If a > 0 Then
g = EMDMain.Character(i).SetLimbWieldedWeapon(e, 0)
End If
Next
End If
d = EMDMain.Character(i).ObjectCount()
If d > 0 Then
For e = (d - 1) To 0 Step -1
a = EMDMain.Character(i).ObjectIndex(e)
EMDMain.Character(i).ObjectRemove = Trim$(a)
For h = 0 To EMDAdmin.Objects.ListCount - 1
If a = Val(EMDAdmin.Objects.List(h)) Then
EMDAdmin.Objects.RemoveItem h
Exit For
End If
Next
Unload EMDMain.Object(a)
Next
End If
If Not b Then
EMDMain.Character(i).Send = "Cleaned inventory." + CR
End If
End Sub
Sub DestructRoom(RoomIndex As Long, Forced As Boolean)
Dim a&, d&, e&, f As Boolean, h&, i&
On Error Resume Next
i = RoomIndex
f = Forced
If Not f Then
If ((EMDMain.Environment(i).AllowDestruct = False) Or
(EMDMain.Environment(i).ObjectCount > 0) Or
(EMDMain.Environment(i).CharacterCount > 0)) Then
Exit Sub
End If
End If
d = EMDMain.Environment(i).ObjectCount()
If d > 0 Then
For e = (d - 1) To 0 Step -1
a = EMDMain.Environment(i).ObjectIndex(e)
EMDMain.Environment(i).ObjectRemove = Trim$(a)
For h = 0 To EMDAdmin.Objects.ListCount - 1
If a = Val(EMDAdmin.Objects.List(h)) Then
EMDAdmin.Objects.RemoveItem h
Exit For
End If
Next
Unload EMDMain.Object(a)
Next
End If
d = EMDMain.Environment(i).CharacterCount
If d > 0 Then
For e = (d - 1) To 0 Step -1
a = EMDMain.Environment(i).CharacterIndex(e)
EMDMain.Environment(i).CharacterRemove = Trim$(a)
EMDMain.Environment(i).CharacterAdd = "1"
EMDMain.Character(a).Send = "You are magically telepoeted
to %^YELLOW%^" + EMDMain.Environment(1).RoomName + "%^WHITE%^." + CR
Next
End If
For h = 0 To EMDAdmin.Rooms.ListCount - 1
If i = Val(EMDAdmin.Rooms.List(h)) Then
EMDAdmin.Rooms.RemoveItem h
Exit For
End If
Next
Unload EMDMain.Environment(i)
End Sub
Sub DropItem(Index As Integer, Entry As String, Subdued As Integer)
Dim a&, b%, c&, d&, e&, f%, g%, h&, i%, j&, k&, s$, t$, w&, u$, v$
On Error Resume Next
i = Index
s = Entry
b = Subdued
s = Trim$(LCase(s))
If s = "all" Then
d = EMDMain.Character(i).LimbCount
If d > 0 Then
For e = 1 To d
a = EMDMain.Character(i).GetLimbWieldedWeapon(e)
If a > 0 Then
g = EMDMain.Character(i).SetLimbWieldedWeapon(e,
0)
Else
a = EMDMain.Character(i).GetLimbWornArmour(e)
If a > 0 Then
g = EMDMain.Character(i).SetLimbWornArmour(e,
0)
End If
End If
Next
End If
d = EMDMain.Character(i).ObjectCount()
If d > 0 Then
f = True
For e = (d - 1) To 0 Step -1
a = EMDMain.Character(i).ObjectIndex(e)
If EMDMain.Object(a).CanBeMoved Then
EMDMain.Character(i).ObjectRemove = Trim$(a)

EMDMain.Environment(EMDMain.Character(i).Environment).ObjectAdd =
Trim$(a)
If Not b Then
u = u + "You drop %^CYAN%^" +
EMDMain.Object(a).ObjectName + "%^WHITE%^." + CR
v = v + EMDMain.Character(i).CharName + "
drops %^CYAN%^" + EMDMain.Object(a).ObjectName + "%^WHITE%^." + CR
End If
Else
u = u + "You can't drop %^CYAN%^" +
EMDMain.Object(a).ObjectName + "%^WHITE%^." + CR
End If
Next
Else
f = False
End If
Else
If InStr(s, " ") > 0 Then
t = s
Do Until InStr(t, " ") = 0
t = Right$(t, Len(t) - InStr(t, " "))
If Val(t) > 0 Then
s = Trim$(Left$(s, Len(s) - Len(t)))
w = t
End If
Loop
End If
If w = 0 Then
w = 1
End If
s = ":" + s + ":"
d = EMDMain.Character(i).ObjectCount()
If d > 0 Then
For e = 0 To d - 1
a = EMDMain.Character(i).ObjectIndex(e)
t = Trim$(LCase(EMDMain.Object(a).ObjectID))
If InStr(t, s) > 0 Then
c = c + 1
If c = w Then
f = True
If EMDMain.Object(a).CanBeMoved Then
h = EMDMain.Character(i).LimbCount
If h > 0 Then
For j = 1 To h
k =
EMDMain.Character(i).GetLimbWieldedWeapon(j)
If k = a Then
g =
EMDMain.Character(i).SetLimbWieldedWeapon(j, 0)
Else
k =
EMDMain.Character(i).GetLimbWornArmour(j)
If k = a Then
g =
EMDMain.Character(i).SetLimbWornArmour(j, 0)
End If
End If
Next
End If
EMDMain.Character(i).ObjectRemove =
Trim$(a)

EMDMain.Environment(EMDMain.Character(i).Environment).ObjectAdd =
Trim$(a)
If Not b Then
u = u + "You drop %^CYAN%^" +
EMDMain.Object(a).ObjectName + "%^WHITE%^." + CR
v = v + EMDMain.Character(i).CharName
+ " drops %^CYAN%^" + EMDMain.Object(a).ObjectName + "%^WHITE%^." + CR
End If
Else
u = u + "You can't drop %^CYAN%^" +
EMDMain.Object(a).ObjectName + "%^WHITE%^." + CR
End If
Exit For
End If
End If
Next
End If
End If
If Not f Then
EMDMain.Character(i).Send = "Drop what?" + CR
Else
If Not b Then
EMDMain.Character(i).Send = u
SendToRoom EMDMain.Character(i).Environment, v, i, 0
End If
End If
End Sub
Sub Emote(Index As Integer, Entry As String)
Dim i%, s$
On Error Resume Next
i = Index
s = Entry
If ((Left$(s, 1) = "'") Or (Left$(s, 2) = "-c") Or (Left$(s, 2) =
"-k")) Then
s = EMDMain.Character(i).CharName + s
Else
s = EMDMain.Character(i).CharName + " " + Trim$(s)
End If
SendToRoom EMDMain.Character(i).Environment, s + CR, 0, 0
End Sub
Sub GetItem(Index As Integer, Entry As String, Subdued As Integer)
Dim a&, b%, c&, d&, e&, f%, i%, s$, t$, w&, u$, v$
On Error Resume Next
i = Index
s = Entry
b = Subdued
s = Trim$(LCase(s))
If s = "all" Then
d =
EMDMain.Environment(EMDMain.Character(i).Environment).ObjectCount()
If d > 0 Then
f = True
For e = (d - 1) To 0 Step -1
a =
EMDMain.Environment(EMDMain.Character(i).Environment).ObjectIndex(e)
If EMDMain.Object(a).CanBeMoved Then

EMDMain.Environment(EMDMain.Character(i).Environment).ObjectRemove =
Trim$(a)
EMDMain.Character(i).ObjectAdd = Trim$(a)
If Not b Then
u = u + "You pick up %^CYAN%^" +
EMDMain.Object(a).ObjectName + "%^WHITE%^." + CR
v = v + EMDMain.Character(i).CharName
+ " picks up %^CYAN%^" + EMDMain.Object(a).ObjectName + "%^WHITE%^." +
CR
End If
Else
u = u + "%^CYAN%^" +
EMDMain.Object(a).ObjectName + "%^WHITE%^ can't be moved." + CR
End If
Exit For
End If
End If
Next
End If
End If
If Not f Then
EMDMain.Character(i).Send = "Get what?" + CR
Else
If Not b Then
EMDMain.Character(i).Send = u
SendToRoom EMDMain.Character(i).Environment, v, i, 0
End If
End If
End Sub
Function HealthColour(Value As Integer) As String
Dim v%, s$
On Error Resume Next
v = Value
Select Case v
Case Is < 11:
s = "%^WHITE%^"
Case 11 To 35:
s = "%^YELLOW%^"
Case 36 To 50:
s = "%^CYAN%^"
Case 51 To 75:
s = "%^GREEN%^"
Case 76 To 95:
s = "%^MAGENTA%^"
Case Is > 95:
s = "%^RED%^"
End Select
HealthColour = s
End Function
Sub Init(Index As Integer)
Dim i%
On Error Resume Next
i = Index
EMDMain.Character(i).Send = CR + "Connected to
%^YELLOW%^%^MUDNAME%^%^WHITE%^:%^YELLOW%^" + Trim$(i) + "%^WHITE%^
from %^YELLOW%^" + EMDMain.Character(i).IPAddress + "%^WHITE%^." + CR
If EMDAdmin.Users.ListCount >= MaxConnections Then
EMDMain.Character(i).Send = FullMudMessage + CR
Quit i, False
Else
EMDAdmin.Users.AddItem Trim$(i)
Look i, "here", True
End If
End Sub
Sub Inventory(Index As Integer)
Dim a&, c&, d&, e&, f&, i%, t$
On Error Resume Next
i = Index
t = ""
d = EMDMain.Character(i).ObjectCount()
For f = 0 To 2
If d > 0 Then
For e = 0 To d - 1
a = EMDMain.Character(i).ObjectIndex(e)
If EMDMain.Object(a).ObjectType = f Then
c = c + 1
t = t + "%^CYAN%^" + EMDMain.Object(a).ObjectName
+ CR
End If
Next
End If
Next
If Len(t) > 0 Then
If c = 1 Then
t = "You are carrying one item:" + CR + t
Else
t = "You are carrying %^YELLOW%^" + Trim$(c) + "%^WHITE%^
items:" + CR + t
End If
Else
t = "%^CYAN%^You are empty-handed." + CR
End If
EMDMain.Character(i).Send = t
End Sub
Function IsDirection(Entry As String) As Integer
Dim s$
s = Entry
If s = "north" Then
IsDirection = True
ElseIf s = "east" Then
IsDirection = True
ElseIf s = "south" Then
IsDirection = True
ElseIf s = "west" Then
IsDirection = True
ElseIf s = "northeast" Then
IsDirection = True
ElseIf s = "southeast" Then
IsDirection = True
ElseIf s = "southwest" Then
IsDirection = True
ElseIf s = "northwest" Then
IsDirection = True
ElseIf s = "up" Then
IsDirection = True
ElseIf s = "down" Then
IsDirection = True
ElseIf s = "out" Then
IsDirection = True
Else
IsDirection = False
End If
End Function
Sub Logon(Index As Integer)
Dim i%, r&, s$
On Error Resume Next
i = Index
EMDMain.Character(i).Send = MessageOfTheDay + CR
SendToRoom EMDMain.Character(i).Environment,
EMDMain.Character(i).CharName + " has connected." + CR, 0, 0
Err.Number = 0
r = EMDMain.Character(i).Environment
s = EMDMain.Environment(r).RoomName
If Err.Number > 0 Then
ResetRoom 0, r, False
End If
EMDMain.Environment(r).CharacterAdd = Trim$(i)
Look i, "here", True
End Sub
Sub Look(Index As Integer, Entry As String, Subdued As Integer)
Dim a&, b%, c&, d&, e&, f&, g%, h%, i%, p%, s$, t$, u$, v$, w&, x
As Boolean
On Error Resume Next
i = Index
s = Entry
b = Subdued
If EMDMain.Character(i).Environment = 0 Then
EMDMain.Character(i).Send = WelcomeMessage + CR
Exit Sub
End If
s = LCase(Trim$(s))
If s = "" Then
s = "here"
ElseIf s = "me" Then
s = EMDMain.Character(i).CharName
End If
If s = "here" Then
x = True
ResetRoom 0, EMDMain.Character(i).Environment, False
u = "%^YELLOW%^" +
EMDMain.Environment(EMDMain.Character(i).Environment).RoomName + CR
t =
EMDMain.Environment(EMDMain.Character(i).Environment).Description
If ((Right$(t, 2) <> CR) And Right$(t, 2) <> "\n") Then
t = t + CR
End If
u = u + t
d =
EMDMain.Environment(EMDMain.Character(i).Environment).ExitCount
If d > 0 Then
t = ""
For e = 1 To d
If
EMDMain.Environment(EMDMain.Character(i).Environment).GetExitObviousExit(e)
= True Then
t = t +
EMDMain.Environment(EMDMain.Character(i).Environment).GetExitName(e) +
", "
End If
Next
If Len(t) > 0 Then
t = Left$(t, Len(t) - 2)
u = u + "%^MAGENTA%^Obvious Exits: " + t + "." + CR
Else
u = u + "%^MAGENTA%^Obvious Exits: None." + CR
End If
End If
t = ""
d =
EMDMain.Environment(EMDMain.Character(i).Environment).ObjectCount()
For f = 0 To 2
If d > 0 Then
For e = 0 To d - 1
a =
EMDMain.Environment(EMDMain.Character(i).Environment).ObjectIndex(e)
If EMDMain.Object(a).ObjectType = f Then
t = t + "%^CYAN%^" +
EMDMain.Object(a).ObjectName + ", "
End If
Next
End If
Next
If Len(t) > 0 Then
t = Left$(t, Len(t) - 2)
u = u + "%^CYAN%^" + t + "." + CR
End If
d =
EMDMain.Environment(EMDMain.Character(i).Environment).CharacterCount()
If d > 0 Then
For e = 0 To d - 1
u = u +
HealthColour(Int((EMDMain.Character(EMDMain.Environment(EMDMain.Character(i).Environment).CharacterIndex(e)).HitPoints
/
EMDMain.Character(EMDMain.Environment(EMDMain.Character(i).Environment).CharacterIndex(e)).MaxHitPoints)
* 100)) +
ReplaceString(EMDMain.Character(EMDMain.Environment(EMDMain.Character(i).Environment).CharacterIndex(e)).Title,
"%N",
EMDMain.Character(EMDMain.Environment(EMDMain.Character(i).Environment).CharacterIndex(e)).CharName)
+ CR
Next
End If
EMDMain.Character(i).Send = u
If Not b Then
SendToRoom EMDMain.Character(i).Environment,
EMDMain.Character(i).CharName + GenderParse(i, " looks at *his*
surroundings.") + CR, i, 0
End If
Else
p = FindPlayer(s)
If p = 0 Then
If InStr(s, " ") > 0 Then
t = s
Do Until InStr(t, " ") = 0
t = Right$(t, Len(t) - InStr(t, " "))
If Val(t) > 0 Then
s = Trim$(Left$(s, Len(s) - Len(t)))
w = t
End If
Loop
End If
If w = 0 Then
w = 1
End If
s = ":" + s + ":"
d = EMDMain.Character(i).ObjectCount()
If d > 0 Then
For e = 0 To d - 1
a = EMDMain.Character(i).ObjectIndex(e)
t = Trim$(LCase(EMDMain.Object(a).ObjectID))
If InStr(t, s) > 0 Then
c = c + 1
If c = w Then
u = EMDMain.Object(a).Description
If ((Right$(u, 2) <> CR) And Right$(u, 2)
<> "\n") Then
u = u + CR
End If
EMDMain.Character(i).Send = u
If Not b Then
SendToRoom
EMDMain.Character(i).Environment, EMDMain.Character(i).CharName + "
looks " + EMDMain.Object(a).ObjectName + " over." + CR, i, 0
End If
x = True
Exit For
End If
End If
Next
End If
If Not x Then
d =
EMDMain.Environment(EMDMain.Character(i).Environment).ObjectCount()
If d > 0 Then
For e = 0 To d - 1
a =
EMDMain.Environment(EMDMain.Character(i).Environment).ObjectIndex(e)
t = Trim$(LCase(EMDMain.Object(a).ObjectID))
If InStr(t, s) > 0 Then
c = c + 1
If c = w Then
u = EMDMain.Object(a).Description
If ((Right$(u, 2) <> CR) And Right$(u,
2) <> "\n") Then
u = u + CR
End If
EMDMain.Character(i).Send = u
If Not b Then
SendToRoom
EMDMain.Character(i).Environment, EMDMain.Character(i).CharName + "
looks " + EMDMain.Object(a).ObjectName + " over." + CR, i, 0
End If
x = True
Exit For
End If
End If
Next
End If
End If
Else
x = True
u = "%^YELLOW%^" + EMDMain.Character(p).CharName + CR
t = EMDMain.Character(p).Description
If ((Right$(t, 2) <> CR) And Right$(t, 2) <> "\n") Then
t = t + CR
End If
u = u + t
t = ""
d = EMDMain.Character(i).LimbCount
If d > 0 Then
For e = 1 To d
a = EMDMain.Character(i).GetLimbWieldedWeapon(e)
If a > 0 Then
g = False
If e < d Then
For c = (e + 1) To d
If
EMDMain.Character(i).GetLimbWieldedWeapon(c) = a Then
v = v + "%^CYAN%^" +
EMDMain.Object(a).ObjectName + " (Wielded in " +
EMDMain.Character(i).GetLimbName(e) + " and " +
EMDMain.Character(i).GetLimbName(c) + ")" + CR
g = True
Exit For
End If
Next
End If
If Not g Then
If e > 1 Then
For c = 1 To (e - 1)
If
EMDMain.Character(i).GetLimbWieldedWeapon(c) = a Then
g = True
Exit For
End If
Next
If Not g Then
v = v + "%^CYAN%^" +
EMDMain.Object(a).ObjectName + " (Wielded in " +
EMDMain.Character(i).GetLimbName(e) + ")" + CR
End If
Else
v = v + "%^CYAN%^" +
EMDMain.Object(a).ObjectName + " (Wielded in " +
EMDMain.Character(i).GetLimbName(e) + ")" + CR
End If
End If
End If
Next
End If
d = EMDMain.Character(p).ObjectCount()
If d > 0 Then
For f = 0 To 2
For e = 0 To d - 1
a = EMDMain.Character(p).ObjectIndex(e)
If EMDMain.Object(a).ObjectType = f Then
g = False
h = False
w = EMDMain.Character(i).LimbCount
For c = 1 To w
If a =
EMDMain.Character(i).GetLimbWieldedWeapon(c) Then
g = True
Exit For
End If
If a =
EMDMain.Character(i).GetLimbWornArmour(c) Then
h = True
Exit For
End If
Next
If Not g Then
If h Then
v = v + "%^CYAN%^" +
EMDMain.Object(a).ObjectName + " (Worn)" + CR
Else
t = t + "%^CYAN%^" +
EMDMain.Object(a).ObjectName + CR
End If
End If
End If
Next
Next
End If
t = (v + t)
If Len(t) = 0 Then
If (i = p) Then
t = "%^CYAN%^You are empty-handed." + CR
Else
t = "%^CYAN%^" + EMDMain.Character(p).CharName + "
is empty-handed." + CR
End If
End If
u = u + t
EMDMain.Character(i).Send = u
If Not b Then
If p = i Then
SendToRoom EMDMain.Character(i).Environment,
EMDMain.Character(i).CharName + GenderParse(i, " looks *himself*
over.") + CR, i, 0
Else
EMDMain.Character(p).Send =
EMDMain.Character(i).CharName + " looks you over." + CR
SendToRoom EMDMain.Character(i).Environment,
EMDMain.Character(i).CharName + " looks " +
EMDMain.Character(p).CharName + " over." + CR, i, p
End If
End If
End If
End If
If Not x Then
EMDMain.Character(i).Send = "Look at what?" + CR
End If
End Sub
Function MoveChar(Index As Integer, Entry As String, Subdued As
Integer) As Integer
Dim b%, d&, e&, f&, i%, s$, t$
On Error Resume Next
i = Index
s = Entry
b = Subdued
s = LCase(Trim$(s))
d =
EMDMain.Environment(EMDMain.Character(i).Environment).ExitCount
If d > 0 Then
For e = 1 To d
t =
EMDMain.Environment(EMDMain.Character(i).Environment).GetExitName(e)
If s = t Then
If
EMDMain.Environment(EMDMain.Character(i).Environment).GetExitBlocked(e)
= True Then
If EMDMain.Character(i).CharStatus > 0 Then
EMDMain.Character(i).Send = "You push through
the magical barrier." + CR
SendToRoom EMDMain.Character(i).Environment,
EMDMain.Character(i).CharName + " pushes through the magical barrier."
+ CR, i, 0
Else
EMDMain.Character(i).Send = "A magical barrier
prevents you going that way." + CR
SendToRoom EMDMain.Character(i).Environment,
EMDMain.Character(i).CharName + " is repelled by the magical barrier."
+ CR, i, 0
MoveChar = True
Exit Function
End If
End If
f =
EMDMain.Environment(EMDMain.Character(i).Environment).GetExitDestination(e)
If Not b Then
SendToRoom EMDMain.Character(i).Environment,
EMDMain.Character(i).CharName + " leaves " + s + "." + CR, i, 0
End If

EMDMain.Environment(EMDMain.Character(i).Environment).CharacterRemove
= Trim$(i)
DestructRoom EMDMain.Character(i).Environment, False
EMDMain.Character(i).Environment = f
Err.Number = 0
s = EMDMain.Environment(f).RoomName
If Err.Number > 0 Then
ResetRoom 0, f, False
End If
EMDMain.Environment(f).CharacterAdd = Trim$(i)
Look i, "here", True
If Not b Then
SendToRoom f, EMDMain.Character(i).CharName + "
has arrived." + CR, i, 0
End If
MoveChar = True
Exit Function
End If
Next
End If
MoveChar = False
End Function
Sub Parse(Index As Integer, Entry As String)
Dim f As Boolean
Dim i%, s$, t$
On Error Resume Next
i = Index
s = Entry
f = False
t = Left$(s, 1)
' Debug.Print Trim$(i)
If ((t = ";") Or (t = ":") Or (t = Chr$(34)) Or (t = "'")) Then
s = Trim$(Right$(s, Len(s) - 1))
If t = ";" Then s = "emote " + s
If t = ":" Then s = "emote " + s
If t = Chr$(34) Then s = "say " + s
If t = "'" Then s = "say " + s
End If
If InStr(s, " ") > 0 Then
t = Right$(s, Len(s) - InStr(s, " "))
s = Left$(s, InStr(s, " ") - 1)
Else
t = ""
End If
' Preparse
If s = "n" Then s = "north"
If s = "e" Then s = "east"
If s = "s" Then s = "south"
If s = "w" Then s = "west"
If s = "ne" Then s = "northeast"
If s = "se" Then s = "southeast"
If s = "sw" Then s = "southwest"
If s = "nw" Then s = "northwest"
If s = "u" Then s = "up"
If s = "d" Then s = "down"
If s = "o" Then s = "out"
'
If s = "co" Then s = "connect"
If s = "i" Then s = "inventory"
If s = "l" Then s = "look"
If s = "wi" Then s = "wield"
' End Preparse
If EMDMain.Character(i).LoginState = 0 Then
If s = "connect" Then f = True: Connect i, t
ElseIf EMDMain.Character(i).LoginState = 1 Then
If s = "drop" Then f = True: DropItem i, t, False
If s = "emote" Then f = True: Emote i, t
If s = "get" Then f = True: GetItem i, t, False
If s = "help" Then f = True: ReadHelp i, t
If s = "inventory" Then f = True: Inventory i
If s = "motd" Then f = True: EMDMain.Character(i).Send =
MessageOfTheDay + CR
If s = "remove" Then f = True: Remove i, t
If s = "reply" Then f = True: Tell i, t, True
If s = "say" Then f = True: Say i, t
If s = "take" Then f = True: GetItem i, t, False
If s = "tell" Then f = True: Tell i, t, False
If s = "unwield" Then f = True: Unwield i, t
If s = "wear" Then f = True: Wear i, t
If s = "wield" Then f = True: Wield i, t
If EMDMain.Character(i).CharStatus > 0 Then
If s = "clean" Then f = True: Clean i, False
If s = "guagelag" Then f = True: GuageLag i
If s = "refreshemd" Then f = True: RefreshEMD i
If s = "reset" Then f = True: ResetRoom i,
EMDMain.Character(i).Environment, True
If s = "socket" Then f = True: Socket i, t
End If
If f = False Then
f = Soul(i, s, t)
End If
If f = False Then
f = MoveChar(i, s, False)
End If
If f = False Then
f = CheckChannel(i, s, t)
End If
Else
End If
If s = "look" Then f = True: Look i, t, False
If s = "quit" Then f = True: Quit i, True
If s = "who" Then f = True: Who i
If s = "whox" Then f = True: EMDMain.Character(i).Send = WhoX() +
CR
If f = False Then
If EMDMain.Character(i).LoginState = 0 Then
EMDMain.Character(i).Send = Trim$("Unknown command: [" + s
+ "] " + t) + CR
Else
If IsDirection(s) Then
EMDMain.Character(i).Send = "You can't go that way." +
CR
Else
EMDMain.Character(i).Send = Trim$("Unknown command: ["
+ s + "] " + t) + CR
End If
End If
End If
End Sub
Sub Quit(Index As Integer, Voluntary As Boolean)
Dim d%, i%
Dim v As Boolean
On Error Resume Next
i = Index
v = Voluntary
If EMDMain.Character(i).ObjectCount() > 0 Then
Parse i, "drop all"
Clean i, True
End If
If v Then
EMDMain.Character(i).Send = LeavingMessage + CR
End If
For d = 0 To EMDAdmin.Users.ListCount - 1
If i = Val(EMDAdmin.Users.List(d)) Then
EMDAdmin.Users.RemoveItem d
Exit For
End If
Next

EMDMain.Environment(EMDMain.Character(i).Environment).CharacterRemove
= i
EMDMain.Character(i).Quit = True
SendToRoom EMDMain.Character(i).Environment,
EMDMain.Character(i).CharName + " has disconnected." + CR, 0, 0
Unload EMDMain.Character(i)
End Sub
Sub Remove(Index As Integer, Entry As String)
Dim a&, c&, d&, e&, f%, i%, g%, j&, k&, s$, t$, w&, x As Boolean
On Error Resume Next
i = Index
s = Entry
s = Trim$(LCase(s))
If InStr(s, " ") > 0 Then
t = s
Do Until InStr(t, " ") = 0
t = Right$(t, Len(t) - InStr(t, " "))
If Val(t) > 0 Then
s = Trim$(Left$(s, Len(s) - Len(t)))
w = t
End If
Loop
End If
If w = 0 Then
w = 1
End If
s = ":" + s + ":"
d = EMDMain.Character(i).ObjectCount()
If d > 0 Then
For e = 0 To d - 1
a = EMDMain.Character(i).ObjectIndex(e)
t = Trim$(LCase(EMDMain.Object(a).ObjectID))
If InStr(t, s) > 0 Then
c = c + 1
If c = w Then
f = True
If EMDMain.Object(a).ObjectType = 1 Then
j = EMDMain.Character(i).LimbCount
If j > 0 Then
For k = 1 To j
If
EMDMain.Character(i).GetLimbWornArmour(k) = a Then
x = True
g =
EMDMain.Character(i).SetLimbWornArmour(k, 0)
End If
Next
End If
End If
Exit For
End If
End If
Next
End If
If Not f Then
EMDMain.Character(i).Send = "You don't have that!" + CR
ElseIf Not x Then
EMDMain.Character(i).Send = "You aren't wearing that!" + CR
Else
EMDMain.Character(i).Send = "You remove %^CYAN%^" +
EMDMain.Object(a).ObjectName + "%^WHITE%^." + CR
SendToRoom EMDMain.Character(i).Environment,
EMDMain.Character(i).CharName + GenderParse(i, " removes *his*
%^CYAN%^" + EMDMain.Object(a).ObjectName + "%^WHITE%^.") + CR, i, 0
End If
End Sub
Sub ResetRoom(Index As Integer, RoomIndex As Long, Forced As Boolean)
Dim b As Boolean, d&, e&, f%, g%, i%, l&, r&, s$, SQL$, t$, u$, v&
Dim eb As Boolean, ed&, ek As Long, el As Boolean, elmo$, elms$,
emo$, ems$, en$, eoe As Boolean
Dim rs As Recordset
On Error Resume Next
i = Index
r = RoomIndex
b = Forced
Err.Number = 0
s = EMDMain.Environment(r).RoomName
If ((Err.Number > 0) Or b) Then
If Not b Then
Unload EMDMain.Environment(r)
DoEvents
If r > LastLoadedRoom Then
LastLoadedRoom = r
End If
Load EMDMain.Environment(r)
EMDAdmin.Rooms.AddItem Trim$(r)
DoEvents
End If
SQL = "SELECT * "
SQL = SQL + "FROM Rooms "
SQL = SQL + "WHERE RoomIndex = " + Trim$(r)
Set rs = EMDB.OpenRecordset(SQL, dbOpenDynaset)
If rs.RecordCount > 0 Then
Load EMDMain.Environment(r)
EMDMain.Environment(r).RoomName =
Trim$(NoNulls(rs!RoomName))
EMDMain.Environment(r).Description =
Trim$(NoNulls(rs!Description))
EMDMain.Environment(r).AllowDestruct = rs!AllowDestruct
EMDMain.Environment(r).IsShop = rs!IsShop
EMDMain.Environment(r).ShopKeeper = Trim$(rs!ShopKeeper)
EMDMain.Environment(r).ShopStockRoom = rs!ShopStockRoom
EMDMain.Environment(r).LoadOnReset =
Trim$(NoNulls(rs!LoadOnReset))
EMDMain.Environment(r).LastReset = rs!LastReset
End If
rs.Close
g = EMDMain.Environment(r).ClearExits()
SQL = "SELECT * "
SQL = SQL + "FROM Exits "
SQL = SQL + "WHERE RoomIndex = " + Trim$(r)
Set rs = EMDB.OpenRecordset(SQL, dbOpenDynaset)
If rs.RecordCount > 0 Then
Do Until rs.EOF
ed = rs!Destination
ek = rs!Key
el = rs!Locked
elmo = NoNulls(rs!LockedMessageOthers)
elms = NoNulls(rs!LockedMessageSelf)
emo = NoNulls(rs!ExitMessageOthers)
ems = NoNulls(rs!ExitMessageSelf)
en = NoNulls(rs!ExitName)
eoe = rs!ObviousExit
eb = rs!Blocked
g = EMDMain.Environment(r).ExitAdd(ed, ek, el, elmo,
elms, emo, ems, en, eoe, eb)
DoEvents
rs.MoveNext
Loop
End If
rs.Close
End If
If ((DateAdd("n", RoomResetIntervalInMinutes,
CVDate(EMDMain.Environment(r).LastReset)) <= Now) Or b) Then
EMDMain.Environment(r).LastReset = CDbl(Now)
s = Trim$(EMDMain.Environment(r).LoadOnReset)
If Len(s) > 0 Then
Do Until Len(s) = 0
f = False
If InStr(s, ":") > 0 Then
t = Left$(s, InStr(s, ":") - 1)
s = Right$(s, Len(s) - InStr(s, ":"))
Else
t = s
s = ""
End If
u = LCase(Left$(t, 1))
v = Val(Right$(t, Len(t) - 1))
If u = "o" Then
d = EMDMain.Environment(r).ObjectCount()
If d > 0 Then
For e = 0 To d - 1
If
EMDMain.Object(EMDMain.Environment(r).ObjectIndex(e)).ObjectIndex = v
Then
f = True
Exit For
End If
Next
End If
If Not f Then
l = (LastLoadedObject + 1)
LastLoadedObject = l
Load EMDMain.Object(l)
EMDAdmin.Objects.AddItem Trim$(l)
SQL = "SELECT * "
SQL = SQL + "FROM Objects "
SQL = SQL + "WHERE ObjectIndex = " + Trim$(v)
Set rs = EMDB.OpenRecordset(SQL,
dbOpenDynaset)
If rs.RecordCount > 0 Then
EMDMain.Object(l).ObjectIndex =
rs!ObjectIndex
EMDMain.Object(l).ObjectName =
Trim$(rs!ObjectName)
EMDMain.Object(l).ObjectID =
Trim$(rs!ObjectID)
EMDMain.Object(l).ObjectType =
rs!ObjectType
EMDMain.Object(l).CanBeMoved =
rs!CanBeMoved
EMDMain.Object(l).Description =
Trim$(rs!Description)
EMDMain.Object(l).ArmourClass =
rs!ArmourClass
EMDMain.Object(l).WeaponClass =
rs!WeaponClass
EMDMain.Object(l).DoubleWielded =
rs!DoubleWielded
EMDMain.Object(l).Value = rs!Value
End If
rs.Close
EMDMain.Environment(r).ObjectAdd = Trim$(l)
End If
End If
Loop
End If
If EMDMain.Environment(r).IsShop = True Then
ResetRoom 0, EMDMain.Environment(r).ShopStockRoom, False
End If
If i > 0 Then
EMDMain.Character(i).Send =
EMDMain.Environment(r).RoomName + " reset." + CR
End If
End If
End Sub
Sub Say(Index As Integer, Entry As String)
Dim i%, s$, t$, u$
On Error Resume Next
i = Index
s = Entry
t = Right$(s, 1)
If t = "!" Then
u = "exclaim"
ElseIf t = "?" Then
u = "ask"
Else
u = "say"
End If
SendToRoom EMDMain.Character(i).Environment,
EMDMain.Character(i).CharName + " " + u + "s, " + Chr$(34) + s +
"%^RESET%^" + Chr$(34) + CR, i, 0
EMDMain.Character(i).Send = "You " + u + ", " + Chr$(34) + s +
"%^RESET%^" + Chr$(34) + CR
End Sub
Sub Socket(Index As Integer, Entry As String)
Dim d%, i%, s$
On Error Resume Next
i = Index
s = Entry
d = FindPlayer(s)
If d > 0 Then
EMDMain.Character(i).Send = EMDMain.Character(d).CharName + ":
" + Trim$(d) + "." + CR
Else
EMDMain.Character(i).Send = "No charcter by that name online."
+ CR
End If
End Sub
Sub Tell(Index As Integer, Entry As String, IsReply As Boolean)
Dim d%, i%, r As Boolean, s$, u$
On Error Resume Next
i = Index
s = Entry
r = IsReply
If InStr(s, " ") = 0 And r = False Then
EMDMain.Character(i).Send = "Tell who, what?" + CR
Else
If r Then
u = EMDMain.Character(i).LastTellFrom
If Len(u) = 0 Then
EMDMain.Character(i).Send = "Reply to who?" + CR
Exit Sub
End If
Else
u = Left$(s, InStr(s, " ") - 1)
s = Trim$(Right$(s, Len(s) - InStr(s, " ")))
End If
If Len(s) > 0 Then
d = FindPlayer(u)
If d > 0 Then
If i <> d Then
If r Then
EMDMain.Character(i).Send = "%^RED%^You reply
to " + EMDMain.Character(d).CharName + ":%^WHITE%^ " + s + CR
EMDMain.Character(d).Send = "%^RED%^" +
EMDMain.Character(i).CharName + " replies to you:%^WHITE%^ " + s + CR
EMDMain.Character(d).LastTellFrom =
EMDMain.Character(i).CharName
Else
EMDMain.Character(i).Send = "%^RED%^You tell "
+ EMDMain.Character(d).CharName + ":%^WHITE%^ " + s + CR
EMDMain.Character(d).Send = "%^RED%^" +
EMDMain.Character(i).CharName + " tells you:%^WHITE%^ " + s + CR
EMDMain.Character(d).LastTellFrom =
EMDMain.Character(i).CharName
End If
Else
If r Then
EMDMain.Character(i).Send = "%^RED%^You reply
to yourself:%^WHITE%^ " + s + CR
Else
EMDMain.Character(i).Send = "%^RED%^You tell
yourself:%^WHITE%^ " + s + CR
End If
EMDMain.Character(i).LastTellFrom =
EMDMain.Character(i).CharName
End If
ElseIf LCase(u) = "me" Then
If r Then
EMDMain.Character(i).Send = "%^RED%^You reply to
yourself:%^WHITE%^ " + s + CR
Else
EMDMain.Character(i).Send = "%^RED%^You tell
yourself:%^WHITE%^ " + s + CR
End If
EMDMain.Character(i).LastTellFrom =
EMDMain.Character(i).CharName
Else
EMDMain.Character(i).Send = "No such character
online." + CR
End If
Else
If r Then
EMDMain.Character(i).Send = "Reply what?" + CR
Else
EMDMain.Character(i).Send = "Tell who, what?" + CR
End If
End If
End If
End Sub
Sub Unwield(Index As Integer, Entry As String)
Dim a&, c&, d&, e&, f%, i%, g%, j&, k&, s$, t$, w&, x As Boolean
On Error Resume Next
i = Index
s = Entry
s = Trim$(LCase(s))
If InStr(s, " ") > 0 Then
t = s
Do Until InStr(t, " ") = 0
t = Right$(t, Len(t) - InStr(t, " "))
If Val(t) > 0 Then
s = Trim$(Left$(s, Len(s) - Len(t)))
w = t
End If
Loop
End If
If w = 0 Then
w = 1
End If
s = ":" + s + ":"
d = EMDMain.Character(i).ObjectCount()
If d > 0 Then
For e = 0 To d - 1
a = EMDMain.Character(i).ObjectIndex(e)
t = Trim$(LCase(EMDMain.Object(a).ObjectID))
If InStr(t, s) > 0 Then
c = c + 1
If c = w Then
f = True
If EMDMain.Object(a).ObjectType = 0 Then
j = EMDMain.Character(i).LimbCount
If j > 0 Then
For k = 1 To j
If
EMDMain.Character(i).GetLimbWieldedWeapon(k) = a Then
x = True
g =
EMDMain.Character(i).SetLimbWieldedWeapon(k, 0)
End If
Next
End If
End If
Exit For
End If
End If
Next
End If
If Not f Then
EMDMain.Character(i).Send = "You don't have that!" + CR
ElseIf Not x Then
EMDMain.Character(i).Send = "You aren't wielding that!" + CR
Else
EMDMain.Character(i).Send = "You unwield %^CYAN%^" +
EMDMain.Object(a).ObjectName + "%^WHITE%^." + CR
SendToRoom EMDMain.Character(i).Environment,
EMDMain.Character(i).CharName + GenderParse(i, " unwields *his*
%^CYAN%^" + EMDMain.Object(a).ObjectName + "%^WHITE%^.") + CR, i, 0
End If
End Sub
Sub Wear(Index As Integer, Entry As String)
Dim a&, c&, cl&, d&, e&, f%, g%, i%, j&, k&, s$, t$, w&, x As
Boolean
On Error Resume Next
i = Index
s = Entry
s = Trim$(LCase(s))
If InStr(s, " ") > 0 Then
t = s
Do Until InStr(t, " ") = 0
t = Right$(t, Len(t) - InStr(t, " "))
If Val(t) > 0 Then
s = Trim$(Left$(s, Len(s) - Len(t)))
w = t
End If
Loop
End If
If w = 0 Then
w = 1
End If
s = ":" + s + ":"
d = EMDMain.Character(i).ObjectCount()
If d > 0 Then
For e = 0 To d - 1
a = EMDMain.Character(i).ObjectIndex(e)
t = Trim$(LCase(EMDMain.Object(a).ObjectID))
If InStr(t, s) > 0 Then
c = c + 1
If c = w Then
f = True
If EMDMain.Object(a).ObjectType = 1 Then
j = EMDMain.Character(i).LimbCount
If j > 0 Then
For k = 1 To j
If
EMDMain.Character(i).GetLimbWornArmour(k) = a Then
x = True
Exit For
End If
Next
End If
If x Then
EMDMain.Character(i).Send = "You're
already wearing that!" + CR
Else
g =
EMDMain.Character(i).SetLimbWornArmour(1, a)
EMDMain.Character(i).Send = "You wear
%^CYAN%^" + EMDMain.Object(a).ObjectName + "%^WHITE%^." + CR
SendToRoom
EMDMain.Character(i).Environment, EMDMain.Character(i).CharName + "
wears %^CYAN%^" + EMDMain.Object(a).ObjectName + "%^WHITE%^." + CR, i,
0
End If
Else
EMDMain.Character(i).Send = "You can't wear
that!" + CR
End If
Exit For
End If
End If
Next
End If
If Not f Then
EMDMain.Character(i).Send = "Wear what?" + CR
End If
End Sub
Sub Who(Index As Integer)
Dim d%, i%, s$, t$
On Error Resume Next
i = Index
If EMDAdmin.Users.ListCount > 0 Then
For d = 0 To EMDAdmin.Users.ListCount - 1
If
(EMDMain.Character(Val(EMDAdmin.Users.List(d))).LoginState = 1) Then
s = s +
Centre(EMDMain.Character(Val(EMDAdmin.Users.List(d))).Title) + CR
End If
Next
End If
If Len(s) > 0 Then
t =
"%^MAGENTA%^-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-"
+ CR
s = "%^YELLOW%^" + Centre(MudName) + CR + t + s + t +
"%^CYAN%^" + Centre(WhoX())
Else
s = WhoX()
End If
EMDMain.Character(i).Send = s + CR
End Sub
Function WhoX() As String
Dim d%, e%
On Error Resume Next
If EMDAdmin.Users.ListCount > 0 Then
For d = 0 To EMDAdmin.Users.ListCount - 1
If
(EMDMain.Character(Val(EMDAdmin.Users.List(d))).LoginState = 1) Then
e = e + 1
End If
Next
End If
If e = 1 Then
WhoX = "One character connected."
Else
WhoX = Trim(Str$(e)) + " characters connected."
End If
End Function
Sub Wield(Index As Integer, Entry As String)
Dim a&, c&, d&, e&, f%, g%, i%, j&, k&, l1&, l2&, s$, t$, u1$,
u2$, w&, x As Boolean
On Error Resume Next
i = Index
s = Entry
s = Trim$(LCase(s))
If InStr(s, "in") > 0 Then
u1 = Trim$(Right$(s, Len(s) - InStr(s, "in") - 2))
s = Trim$(Left$(s, InStr(s, "in") - 1))
If InStr(u1, " and ") > 0 Then
u2 = Trim$(Right$(u1, Len(u1) - InStr(u1, " and ") - 4))
u1 = Trim$(Left$(u1, InStr(u1, " and ") - 1))
End If
End If
If InStr(s, " ") > 0 Then
t = s
Do Until InStr(t, " ") = 0
t = Right$(t, Len(t) - InStr(t, " "))
If Val(t) > 0 Then
s = Trim$(Left$(s, Len(s) - Len(t)))
w = t
End If
Loop
End If
If w = 0 Then
w = 1
End If
s = ":" + s + ":"
d = EMDMain.Character(i).ObjectCount()
If d > 0 Then
For e = 0 To d - 1
a = EMDMain.Character(i).ObjectIndex(e)
t = Trim$(LCase(EMDMain.Object(a).ObjectID))
If InStr(t, s) > 0 Then
c = c + 1
If c = w Then
f = True
If EMDMain.Object(a).ObjectType = 0 Then
j = EMDMain.Character(i).LimbCount
If j > 0 Then
For k = 1 To j
If
EMDMain.Character(i).GetLimbWieldedWeapon(k) = a Then
x = True
Exit For
End If
Next
End If
If x Then
EMDMain.Character(i).Send = "You're
already wielding that!" + CR
Else
If ((EMDMain.Object(a).DoubleWielded =
False) And (Len(u2) > 0)) Then
EMDMain.Character(i).Send = "You can't
wield this weapon in more than one limb!" + CR
ElseIf ((EMDMain.Object(a).DoubleWielded =
True) And (Len(u1) > 0) And (Len(u2) = 0)) Then
EMDMain.Character(i).Send = "You have
to wield this weapon in more than one limb." + CR
Else
If Len(u1) > 0 Then
j = EMDMain.Character(i).LimbCount
If j > 0 Then
For k = 1 To j
If
Trim$(LCase(EMDMain.Character(i).GetLimbName(k))) = u1 Then
l1 = k
ElseIf
Trim$(LCase(EMDMain.Character(i).GetLimbName(k))) = u2 Then
l2 = k
End If
Next
End If
If
(EMDMain.Object(a).DoubleWielded = True) Then
If (u1 = u2) Then
EMDMain.Character(i).Send
= "You have to wield this weapon in more than one limb." + CR
ElseIf ((l1 = 0) Or (l2 = 0))
Then
If (l1 = 0) Then

EMDMain.Character(i).Send = "You can't wield that weapon in " + u1 +
"." + CR
Else

EMDMain.Character(i).Send = "You can't wield that weapon in " + u2 +
"." + CR
End If
ElseIf (l1 = l2) Then
EMDMain.Character(i).Send
= "You have to wield this weapon in more than one limb." + CR
Else
If
EMDMain.Character(i).GetLimbIsLimbWieldable(l1) = False Then

EMDMain.Character(i).Send = "You can't wield a weapon in your " + u1 +
"." + CR
ElseIf
EMDMain.Character(i).GetLimbIsLimbAttached(l1) = False Then

EMDMain.Character(i).Send = "Your " + u1 + " isn't attached!" + CR
ElseIf
EMDMain.Character(i).GetLimbWieldedWeapon(l1) > 0 Then

EMDMain.Character(i).Send = "You're already wielding a weapon in your
" + u1 + "!" + CR
ElseIf
EMDMain.Character(i).GetLimbIsLimbWieldable(l2) = False Then

EMDMain.Character(i).Send = "You can't wield a weapon in your " + u2 +
"." + CR
ElseIf
EMDMain.Character(i).GetLimbIsLimbAttached(l2) = False Then

EMDMain.Character(i).Send = "Your " + u2 + " isn't attached!" + CR
ElseIf
EMDMain.Character(i).GetLimbWieldedWeapon(l2) > 0 Then

EMDMain.Character(i).Send = "You're already wielding a weapon in your
" + u2 + "!" + CR
Else
g =
EMDMain.Character(i).SetLimbWieldedWeapon(l1, a)
g =
EMDMain.Character(i).SetLimbWieldedWeapon(l2, a)

EMDMain.Character(i).Send = "You wield %^CYAN%^" +
EMDMain.Object(a).ObjectName + "%^WHITE%^ in your " +
EMDMain.Character(i).GetLimbName(l1) + " and " +
EMDMain.Character(i).GetLimbName(l2) + "." + CR
SendToRoom
EMDMain.Character(i).Environment, EMDMain.Character(i).CharName + "
wields %^CYAN%^" + EMDMain.Object(a).ObjectName + "%^WHITE%^." + CR,
i, 0
End If
End If
Else
If (l2 > 0) Then
EMDMain.Character(i).Send
= "You can't wield this weapon in more than one limb!" + CR
ElseIf (l1 = 0) Then
EMDMain.Character(i).Send
= "You can't wield a weapon in " + u1 + "." + CR
Else
If
EMDMain.Character(i).GetLimbIsLimbWieldable(l1) = False Then

EMDMain.Character(i).Send = "You can't wield a weapon in your " + u1 +
"." + CR
ElseIf
EMDMain.Character(i).GetLimbIsLimbAttached(l1) = False Then

EMDMain.Character(i).Send = "Your " + u1 + " isn't attached!" + CR
ElseIf
EMDMain.Character(i).GetLimbWieldedWeapon(l1) > 0 Then

EMDMain.Character(i).Send = "You're already wielding a weapon in your
" + u1 + "!" + CR
Else
g =
EMDMain.Character(i).SetLimbWieldedWeapon(l1, a)

EMDMain.Character(i).Send = "You wield %^CYAN%^" +
EMDMain.Object(a).ObjectName + "%^WHITE%^ in your " +
EMDMain.Character(i).GetLimbName(l1) + "." + CR
SendToRoom
EMDMain.Character(i).Environment, EMDMain.Character(i).CharName + "
wields %^CYAN%^" + EMDMain.Object(a).ObjectName + "%^WHITE%^." + CR,
i, 0
End If
End If
End If
Else
j = EMDMain.Character(i).LimbCount
If j > 0 Then
For k = 1 To j
If
EMDMain.Character(i).GetLimbIsLimbWieldable(k) = True Then
If
EMDMain.Character(i).GetLimbIsLimbAttached(k) = True Then
If
EMDMain.Character(i).GetLimbWieldedWeapon(k) = 0 Then
If l1 = 0 Then
l1 = k
Else
l2 = k
Exit For
End If
End If
End If
End If
Next
End If
If
(EMDMain.Object(a).DoubleWielded = True) Then
If ((l1 = 0) Or (l2 = 0)) Then
EMDMain.Character(i).Send
= "You don't have enough free wieldable limbs!" + CR
Else
g =
EMDMain.Character(i).SetLimbWieldedWeapon(l1, a)
g =
EMDMain.Character(i).SetLimbWieldedWeapon(l2, a)
EMDMain.Character(i).Send
= "You wield %^CYAN%^" + EMDMain.Object(a).ObjectName + "%^WHITE%^ in
your " + EMDMain.Character(i).GetLimbName(l1) + " and " +
EMDMain.Character(i).GetLimbName(l2) + "." + CR
SendToRoom
EMDMain.Character(i).Environment, EMDMain.Character(i).CharName + "
wields %^CYAN%^" + EMDMain.Object(a).ObjectName + "%^WHITE%^." + CR,
i, 0
End If
Else
If (l1 = 0) Then
EMDMain.Character(i).Send
= "You don't have a free wieldable limb!" + CR
Else
g =
EMDMain.Character(i).SetLimbWieldedWeapon(l1, a)
EMDMain.Character(i).Send
= "You wield %^CYAN%^" + EMDMain.Object(a).ObjectName + "%^WHITE%^ in
your " + EMDMain.Character(i).GetLimbName(l1) + "." + CR
SendToRoom
EMDMain.Character(i).Environment, EMDMain.Character(i).CharName + "
wields %^CYAN%^" + EMDMain.Object(a).ObjectName + "%^WHITE%^." + CR,
i, 0
End If
End If
End If
End If
End If
Else
EMDMain.Character(i).Send = "You can't wield
that!" + CR
End If
Exit For
End If
End If
Next
End If
If Not f Then
EMDMain.Character(i).Send = "Wield what?" + CR
End If
End Sub

Driver.bas:

Option Explicit

Global AppPath As String
Global ChannelCount As Long
Global ChannelName() As String
Global ChannelSay() As String
Global ChannelEmote() As String
Global CR As String
Global CycleCount As Long
Global CyclesPerHeartbeat As Long
Global EMDB As Database
Global EMDLibrary As String
Global FullMudMessage As String
Global HeartbeatIntervalInMilliseconds As Long
Global HelpCount As Long
Global HelpBody() As String
Global HelpTopic() As String
Global LastLoadedObject As Long
Global LastLoadedRoom As Long
Global LeavingMessage As String
Global MaxConnections As Long
Global MessageOfTheDay As String
Global MudHeartBeat As Boolean
Global MudName As String
Global MudPort As Integer
Global RoomResetIntervalInMinutes As Long
Global Shutdown As Boolean
Global SoulCount As Long
Global SoulBridge() As String
Global SoulOthers() As String
Global SoulSelf() As String
Global SoulVerb() As String
Global WelcomeMessage As String
Global WS As Workspace

Type NOTIFYICONDATA
cbSize As Long
hWnd As Long
uId As Long
uFlags As Long
ucallbackMessage As Long
hIcon As Long
szTip As String * 64
End Type

Global TrayIcon As NOTIFYICONDATA

Global Const NIM_ADD = &H0
Global Const NIM_MODIFY = &H1
Global Const NIM_DELETE = &H2
Global Const WM_MOUSEMOVE = &H200
Global Const NIF_MESSAGE = &H1
Global Const NIF_ICON = &H2
Global Const NIF_TIP = &H4
Global Const WM_LBUTTONDBLCLK = &H203
Global Const WM_LBUTTONDOWN = &H201
Global Const WM_LBUTTONUP = &H202
Global Const WM_RBUTTONDBLCLK = &H206
Global Const WM_RBUTTONDOWN = &H204
Global Const WM_RBUTTONUP = &H205

Declare Function Shell_NotifyIcon Lib "shell32" Alias
"Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA)
As Boolean
Sub AddTrayIcon()
On Error Resume Next
Shell_NotifyIcon NIM_ADD, TrayIcon
End Sub
Function Centre(Entry As String) As String
Dim s$
On Error Resume Next
s = Entry
If Len(s) < 75 Then
Centre = Space$(Int((75 - Len(s)) / 2)) + s
Else
Centre = s
End If
End Function
Function CheckChannel(Index As Integer, VerbEntry As String,
VerbArgument) As Boolean
Dim d&, e%, f%, g%, i%, p%, s$, t$, u$, v$
i = Index
s = VerbEntry
t = VerbArgument
s = Trim$(LCase(s))
If Right$(s, 5) = "emote" Then
s = Left$(s, Len(s) - 5)
f = True
End If
If InStr(LCase(EMDMain.Character(i).UnsubscribedChannels), ":" + s
+ ":") > 0 Then
d = InStr(LCase(EMDMain.Character(i).UnsubscribedChannels),
":" + s + ":")
v = Left$(Right$(EMDMain.Character(i).UnsubscribedChannels,
Len(EMDMain.Character(i).UnsubscribedChannels) - d), Len(s))
EMDMain.Character(i).SubscribedChannels =
EMDMain.Character(i).SubscribedChannels + v + ":"
EMDMain.Character(i).UnsubscribedChannels =
Left$(EMDMain.Character(i).UnsubscribedChannels, d) +
Right$(EMDMain.Character(i).UnsubscribedChannels,
Len(EMDMain.Character(i).UnsubscribedChannels) - d - Len(s) - 1)
EMDMain.Character(i).Send = "Subscribing to channel
'%^YELLOW%^" + v + "%^WHITE%^'" + CR
If Len(t) = 0 Then
CheckChannel = True
Exit Function
End If
End If
If InStr(LCase(EMDMain.Character(i).SubscribedChannels), ":" + s +
":") = 0 Then
CheckChannel = False
Exit Function
End If
If Len(t) > 0 Then
If Len(s) > 0 Then
For d = 1 To ChannelCount
If LCase(ChannelName(d)) = s Then
If f Then
u = ChannelEmote(d)
If ((Left$(t, 1) = "'") Or (Left$(t, 2) =
"-c") Or (Left$(t, 2) = "-k")) Then
u = ReplaceString(u, "%N %A", "%N%A")
End If
Else
u = ChannelSay(d)
End If
u = ReplaceString(u, "%C", ChannelName(d))
u = ReplaceString(u, "%N",
EMDMain.Character(i).CharName)
u = ReplaceString(u, "%A", t)
If EMDAdmin.Users.ListCount > 0 Then
For e = 0 To EMDAdmin.Users.ListCount - 1
p = Val(EMDAdmin.Users.List(e))
If
InStr(LCase(EMDMain.Character(p).SubscribedChannels), ":" + s + ":") >
0 Then
EMDMain.Character(p).Send = u + CR
End If
Next
End If
CheckChannel = True
Exit Function
End If
Next
End If
CheckChannel = False
Else
d = InStr(LCase(EMDMain.Character(i).SubscribedChannels), ":"
+ s + ":")
v = Left$(Right$(EMDMain.Character(i).SubscribedChannels,
Len(EMDMain.Character(i).SubscribedChannels) - d), Len(s))
EMDMain.Character(i).UnsubscribedChannels =
EMDMain.Character(i).UnsubscribedChannels + v + ":"
EMDMain.Character(i).SubscribedChannels =
Left$(EMDMain.Character(i).SubscribedChannels, d) +
Right$(EMDMain.Character(i).SubscribedChannels,
Len(EMDMain.Character(i).SubscribedChannels) - d - Len(s) - 1)
EMDMain.Character(i).Send = "Unsubscribing from channel
'%^YELLOW%^" + v + "%^WHITE%^'" + CR
CheckChannel = True
End If
End Function
Sub Connect(Index As Integer, Entry As String)
Dim al$, cs$, cu$, d&, e%, f%, g%, fil As Boolean
Dim i%, ilw As Boolean, n$, s$, t$, SQL$
Dim rs As Recordset
On Error Resume Next
i = Index
s = Entry
If InStr(s, " ") > 0 Then
t = LCase(Right$(s, Len(s) - InStr(s, " ")))
s = LCase(Left$(s, InStr(s, " ") - 1))
If Len(t) > 0 Then
t = EMDMain.Crypt.Encrypt(s, t)
SQL = "SELECT * "
SQL = SQL + "FROM Characters "
SQL = SQL + "WHERE Charname = '" + s + "' "
SQL = SQL + "AND Password = '" + t + "'"
Set rs = EMDB.OpenRecordset(SQL, dbOpenDynaset)
If rs.RecordCount > 0 Then
f = True
EMDMain.Character(i).CharName = Trim$(rs!CharName)
EMDMain.Character(i).Title = Trim$(rs!Title)
EMDMain.Character(i).Description =
Trim$(rs!Description)
EMDMain.Character(i).Environment = rs!Environment
EMDMain.Character(i).BodyType = Trim$(rs!BodyType)
EMDMain.Character(i).Gender = Trim$(rs!Gender)
EMDMain.Character(i).CharStatus = rs!CharStatus
EMDMain.Character(i).HitPoints = rs!HitPoints
EMDMain.Character(i).MaxHitPoints = rs!MaxHitPoints
EMDMain.Character(i).LoginState = 1
If Len(EMDMain.Character(i).Title) = 0 Then
EMDMain.Character(i).Title =
EMDMain.Character(i).CharName
Else
EMDMain.Character(i).Title =
ReplaceString(EMDMain.Character(i).Title, "%N",
EMDMain.Character(i).CharName)
End If
If LCase(EMDMain.Character(i).CharName <> "guest")
Then
If EMDAdmin.Users.ListCount > 0 Then
For d = (EMDAdmin.Users.ListCount - 1) To 0
Step -1
e = Val(EMDAdmin.Users.List(d))
If i <> e Then
If EMDMain.Character(e).LoginState > 0
Then
If EMDMain.Character(e).CharName =
EMDMain.Character(i).CharName Then
EMDMain.Character(e).Send =
"Reconnected from %^YELLOW%^" + Trim$(EMDMain.Character(i).IPAddress)
+ "%^WHITE%^." + CR
Quit e, False
End If
End If
End If
Next
End If
End If
Logon i
Else
EMDMain.Character(i).Send = "Invalid
Charname/Password." + CR
End If
rs.Close
If f Then
cs = ":"
cu = ":"
SQL = "SELECT Channel, Subscribed "
SQL = SQL + "FROM ChannelSubscriptions "
SQL = SQL + "WHERE CharName = '" +
EMDMain.Character(i).CharName + "' "
Set rs = EMDB.OpenRecordset(SQL, dbOpenDynaset)
If rs.RecordCount > 0 Then
Do Until rs.EOF
If rs!Subscribed Then
cs = cs + Trim$(rs!Channel) + ":"
Else
cu = cu + Trim$(rs!Channel) + ":"
End If
rs.MoveNext
Loop
End If
rs.Close
EMDMain.Character(i).SubscribedChannels = cs
EMDMain.Character(i).UnsubscribedChannels = cu
SQL = "SELECT * "
SQL = SQL + "FROM BodyTypes "
SQL = SQL + "WHERE BodyName = '" +
EMDMain.Character(i).BodyType + "'"
Set rs = EMDB.OpenRecordset(SQL, dbOpenDynaset)
If rs.RecordCount > 0 Then
Do Until rs.EOF
n = NoNulls(rs!BodyLimb)
fil = rs!FatalIfLost
ilw = rs!IsLimbWieldable
al = NoNulls(rs!AttachedLimbs)
g = EMDMain.Character(i).LimbAdd(n, fil, True,
ilw, al)
DoEvents
rs.MoveNext
Loop
End If
rs.Close
End If
Else
EMDMain.Character(i).Send = "Invalid Charname/Password." +
CR
End If
Else
EMDMain.Character(i).Send = "Invalid Charname/Password." + CR
End If
End Sub
Function DateDifference(OldDate As Double, NewDate As Double) As
String
Dim d&, s$
On Error Resume Next
If CVDate(NewDate) > CVDate(OldDate) Then
d = DateDiff("n", CVDate(OldDate), CVDate(NewDate)): s = ""
Else
d = DateDiff("n", CVDate(NewDate), CVDate(OldDate)): s = ""
End If
If d >= 525600 Then s = s + Trim$(Str$(CLng(d / 525600))) + "y ":
d = d Mod 525600
If d >= 1440 Then s = s + Trim$(Str$(CLng(d / 1440))) + "d ": d =
d Mod 1440
If d >= 60 Then s = s + Trim$(Str$(CLng(d / 60))) + "h ": d = d
Mod 60
If d >= 0 Then s = s + Trim$(Str$(d)) + "m "
DateDifference = Trim$(s)
End Function
Function DateOutput(DateEntry As Double) As String
Dim s$
On Error Resume Next
s = Trim$(Str$(Hour(CVDate(DateEntry)))) + ":"
s = s + Right$("00" + Trim$(Str$(Minute(CVDate(DateEntry)))), 2) +
" on "
s = s + Choose(WeekDay(CVDate(DateEntry)), "Sunday", "Monday",
"Tuesday", "Wednesday", "Thursday", "Friday", "Saturday") + " "
s = s + Trim$(Str$(Day(CVDate(DateEntry))))
If ((Day(CVDate(DateEntry)) = 1) Or (Day(CVDate(DateEntry)) = 21)
Or (Day(CVDate(DateEntry)) = 31)) Then
s = s + "st "
ElseIf ((Day(CVDate(DateEntry)) = 2) Or (Day(CVDate(DateEntry)) =
22)) Then
s = s + "nd "
ElseIf ((Day(CVDate(DateEntry)) = 3) Or (Day(CVDate(DateEntry)) =
23)) Then
s = s + "rd "
Else
s = s + "th "
End If
s = s + Choose(Month(CVDate(DateEntry)), "January", "February",
"March", "April", "May", "June", "July", "August", "September",
"October", "November", "December") + ", "
s = s + Year(CVDate(DateEntry)) + "."
DateOutput = Trim$(s)
End Function
Function FindPlayer(Entry As String) As Integer
Dim d&, i%, s$, t$
On Error Resume Next
t = LCase(Trim$(Entry))
If EMDAdmin.Users.ListCount > 0 Then
For d = 0 To EMDAdmin.Users.ListCount - 1
i = Val(EMDAdmin.Users.List(d))
s = LCase(Trim$(EMDMain.Character(i).CharName))
If ((Len(s) > 0) And (s = t)) Then
FindPlayer = i
Exit Function
End If
Next
End If
FindPlayer = 0
End Function
Function GenderParse(Index As Integer, Entry As String) As String
Dim i%, s$, t$, u$, v$, w$, x$
On Error Resume Next
i = Index
s = Entry
t = LCase(EMDMain.Character(i).Gender)
If t = "male" Or t = "m" Then
u = "his"
v = "himself"
w = "him"
x = "he"
ElseIf t = "female" Or t = "f" Then
u = "her"
v = "herself"
w = "her"
x = "she"
Else
u = "its"
v = "itself"
w = "it"
x = "it"
End If
If InStr(s, "*his*") > 0 Then s = ReplaceString(s, "*his*", u)
If InStr(s, "*himself*") > 0 Then s = ReplaceString(s,
"*himself*", v)
If InStr(s, "*him*") > 0 Then s = ReplaceString(s, "*him*", w)
If InStr(s, "*he*") > 0 Then s = ReplaceString(s, "*he*", x)
GenderParse = s
End Function
Sub GuageLag(Index As Integer)
Dim c&, d%, e%, i%, s%, u%
i = Index
On Error Resume Next
c = CyclesPerHeartbeat
If EMDAdmin.Users.ListCount > 0 Then
For d = 0 To EMDAdmin.Users.ListCount - 1
e = Val(EMDAdmin.Users.List(d))
If EMDMain.Character(e).LoginState = 1 Then
u = u + 1
Else
s = s + 1
End If
Next
End If
EMDMain.Character(i).Send = "Cycles: " + Trim$(c) + "
Connections: " + Trim$(s) + " Online: " + Trim$(u) + " Cycles Per
User: " + Trim$(c / u) + CR
End Sub
Sub Main()
Dim d&, i%, s$
On Error Resume Next
AppPath = Trim$(App.Path)
If InStr(AppPath, "\") > 0 Then
Do Until Right$(AppPath, 1) = "\"
AppPath = Left$(AppPath, Len(AppPath) - 1)
Loop
AppPath = AppPath + "Library"
End If
If Right$(AppPath, 1) <> "\" Then
AppPath = AppPath + "\"
End If
CR = Chr$(13) + Chr$(10)
Shutdown = False
Load EMDAdmin
Load EMDMain
AddTrayIcon
Do Until Shutdown = True
If EMDMain.SocketConnection.State = sckListening Then
If EMDAdmin.Users.ListCount > 0 Then
For d = 0 To EMDAdmin.Users.ListCount - 1
i = Val(EMDAdmin.Users.List(d))
If ((EMDMain.Character(i).SocketState =
sckClosing) Or (EMDMain.Character(i).SocketState = sckClosed)) Then
Quit i, False
Else
s = EMDMain.Character(i).NextCommand
If Len(s) > 0 Then
Parse i, s
End If
End If
Next
End If
End If
CycleCount = CycleCount + 1
If MudHeartBeat Then
' Parse Val(EMDAdmin.Users.List(0)), "guagelag"
CyclesPerHeartbeat = CycleCount
CycleCount = 0
MudHeartBeat = False
End If
DoEvents
Loop
DoEvents
EMDB.Close
WS.Close
Unload EMDMain
Unload EMDAdmin
Unload MenuForm
DoEvents
End
End Sub
Function NoNulls(Entry) As String
Dim s$
On Error Resume Next
s = Entry
If IsNull(s) Then
NoNulls = ""
Else
NoNulls = s
End If
End Function
Sub ReadHelp(Index As Integer, Entry As String)
Dim d&, f%, i%, s$, t$
i = Index
s = Entry
s = Trim$(LCase(s))
If Len(s) > 0 Then
For d = 1 To HelpCount
If HelpTopic(d) = s Then
t = HelpBody(d)
If ((Right$(t, 2) <> CR) And Right$(t, 2) <> "\n")
Then
t = t + CR
End If
EMDMain.Character(i).Send = t
f = True
Exit For
End If
Next
If Not f Then
EMDMain.Character(i).Send = "No help available on that
topic." + CR
End If
Else
EMDMain.Character(i).Send = "Please enter a topic to be helped
with." + CR
End If
End Sub
Sub RefreshEMD(Index As Integer)
Dim d&, i%, s$, SQL$
Dim rs As Recordset
On Error Resume Next
i = Index
SQL = "SELECT * FROM Configuration"
Set rs = EMDB.OpenRecordset(SQL, dbOpenDynaset)
If rs.RecordCount > 0 Then
WelcomeMessage = Trim$(rs!WelcomeMessage)
LeavingMessage = Trim$(rs!LeavingMessage)
FullMudMessage = Trim$(rs!FullMudMessage)
MessageOfTheDay = Trim$(rs!MessageOfTheDay)
HeartbeatIntervalInMilliseconds =
rs!HeartbeatIntervalInMilliseconds
RoomResetIntervalInMinutes = rs!RoomResetIntervalInMinutes
End If
rs.Close
If HeartbeatIntervalInMilliseconds < 100 Then
HeartbeatIntervalInMilliseconds = 100
End If
EMDMain.UpdateHeartBeat.Interval = HeartbeatIntervalInMilliseconds
SQL = "SELECT * FROM Soul ORDER BY Verb"
Set rs = EMDB.OpenRecordset(SQL, dbOpenDynaset)
If rs.RecordCount > 0 Then
rs.MoveLast
rs.MoveFirst
SoulCount = rs.RecordCount
ReDim SoulVerb(SoulCount)
ReDim SoulSelf(SoulCount)
ReDim SoulBridge(SoulCount)
ReDim SoulOthers(SoulCount)
d = 1
Do Until rs.EOF
SoulVerb(d) = Trim$(NoNulls(rs!Verb))
SoulSelf(d) = Trim$(NoNulls(rs!Self))
SoulBridge(d) = Trim$(NoNulls(rs!Bridge))
SoulOthers(d) = Trim$(NoNulls(rs!Others))
d = d + 1
rs.MoveNext
Loop
End If
rs.Close
SQL = "SELECT * FROM ChannelDefinitions ORDER BY Channel"
Set rs = EMDB.OpenRecordset(SQL, dbOpenDynaset)
If rs.RecordCount > 0 Then
rs.MoveLast
rs.MoveFirst
ChannelCount = rs.RecordCount
ReDim ChannelName(ChannelCount)
ReDim ChannelSay(ChannelCount)
ReDim ChannelEmote(ChannelCount)
d = 1
Do Until rs.EOF
ChannelName(d) = Trim$(NoNulls(rs!Channel))
ChannelSay(d) = Trim$(NoNulls(rs!Say))
ChannelEmote(d) = Trim$(NoNulls(rs!Emote))
d = d + 1
rs.MoveNext
Loop
End If
rs.Close
SQL = "SELECT * FROM Help ORDER BY HelpTopic"
Set rs = EMDB.OpenRecordset(SQL, dbOpenDynaset)
If rs.RecordCount > 0 Then
rs.MoveLast
rs.MoveFirst
HelpCount = rs.RecordCount
ReDim HelpTopic(HelpCount)
ReDim HelpBody(HelpCount)
d = 1
Do Until rs.EOF
HelpTopic(d) = Trim$(NoNulls(rs!HelpTopic))
HelpBody(d) = Trim$(NoNulls(rs!HelpBody))
d = d + 1
rs.MoveNext
Loop
End If
rs.Close
If i > 0 Then
EMDMain.Character(i).Send = "EMD Refreshed." + CR
End If
End Sub
Sub RemoveTrayIcon()
On Error Resume Next
TrayIcon.cbSize = Len(TrayIcon)
TrayIcon.hWnd = MenuForm.PicHook.hWnd
TrayIcon.uId = 1&
Shell_NotifyIcon NIM_DELETE, TrayIcon
End Sub
Public Function ReplaceString(Entry As String, Target As String,
Replacement As String) As String
Dim a$, b$, d&, s$, t$
On Error Resume Next
s = Entry
a = Target
b = Replacement
t = "%^NULL%^"
Do Until InStr(s, a) = 0
d = InStr(s, a)
s = Left$(s, d - 1) + t + Right$(s, Len(s) - d - Len(a) + 1)
Loop
Do Until InStr(s, t) = 0
d = InStr(s, t)
s = Left$(s, d - 1) + b + Right$(s, Len(s) - d - Len(t) + 1)
Loop
ReplaceString = s
End Function
Sub SendToRoom(RoomIndex As Long, Entry As String, Exclusion1 As
Integer, Exclusion2 As Integer)
Dim d&, e&, f&, i&, s$, x1%, x2%
On Error Resume Next
i = RoomIndex
s = Entry
x1 = Exclusion1
x2 = Exclusion2
If i = 0 Then
Exit Sub
End If
d = EMDMain.Environment(i).CharacterCount()
If d > 0 Then
For e = 0 To d - 1
f = EMDMain.Environment(i).CharacterIndex(e)
If ((f <> x1) And (f <> x2)) Then
EMDMain.Character(f).Send = s
End If
Next
End If
End Sub
Function Soul(Index As Integer, Verb As String, Entry As String) As
Integer
Dim a$, b$, c&, d%, e%, f&, i%, s$, t$, u$, v$
Dim ToSelf$, ToVictim$, ToOthers$
On Error Resume Next
i = Index
s = Verb
a = Entry
t = LCase(Trim$(s))
For f = 1 To SoulCount
If LCase(Trim$(SoulVerb(f))) = t Then
c = f
Exit For
End If
Next
If c > 0 Then
Soul = True
If Right(s, 1) = "s" Then
t = t + "es"
Else
t = t + "s"
End If
If Len(a) > 0 Then
u = a
If InStr(a, " ") > 0 Then
u = Left$(a, InStr(s, " ") - 1)
Else
u = a
End If
d = FindPlayer(u)
If d > 0 Then
If InStr(a, " ") > 0 Then
a = Right$(a, Len(a) - InStr(a, " "))
Else
a = ""
End If
b = Trim$(SoulBridge(c))
If Len(b) > 0 Then
If d = i Then
ToSelf = "You " + s + " " + b + " " +
Trim$("yourself " + a)
ToVictim = ""
ToOthers = "*user* " + t + " " + b + " " +
Trim$("*himself* " + a)
Else
ToSelf = "You " + s + " " + b + " " +
Trim$(EMDMain.Character(d).CharName + " " + a)
ToVictim = "*user* " + t + " " + b + " " +
Trim$("you " + a)
ToOthers = "*user* " + t + " " + b + " " +
Trim$(EMDMain.Character(d).CharName + " " + a)
End If
Else
If d = i Then
ToSelf = "You " + s + " " + Trim$("yourself "
+ a)
ToVictim = ""
ToOthers = "*user* " + t + " " +
Trim$("*himself* " + a)
Else
ToSelf = "You " + s + " " +
Trim$(EMDMain.Character(d).CharName + " " + a)
ToVictim = "*user* " + t + " " + Trim$("you "
+ a)
ToOthers = "*user* " + t + " " +
Trim$(EMDMain.Character(d).CharName + " " + a)
End If
End If
Else
ToSelf = "You " + s + " " + a
ToVictim = ""
ToOthers = "*user* " + t + " " + a
End If
Else
ToSelf = "You " + Trim$(SoulSelf(c))
ToVictim = ""
ToOthers = Trim$("*user* " + Trim$(SoulOthers(c)))
End If
ToOthers = GenderParse(i, ToOthers)
ToVictim = ReplaceString(ToVictim, "*user*",
EMDMain.Character(i).CharName)
ToOthers = ReplaceString(ToOthers, "*user*",
EMDMain.Character(i).CharName)
If ((Right$(ToSelf, 1) <> ".") Or (Right$(ToSelf, 1) <> "!")
Or (Right$(ToSelf, 1) <> "?")) Then
ToSelf = ToSelf + "."
End If
If ((Right$(ToVictim, 1) <> ".") Or (Right$(ToVictim, 1) <>
"!") Or (Right$(ToVictim, 1) <> "?")) Then
ToVictim = ToVictim + "."
End If
If ((Right$(ToOthers, 1) <> ".") Or (Right$(ToOthers, 1) <>
"!") Or (Right$(ToOthers, 1) <> "?")) Then
ToOthers = ToOthers + "."
End If
EMDMain.Character(i).Send = ToSelf + CR
If ((d > 0) And (d <> i)) Then
SendToRoom EMDMain.Character(i).Environment, ToOthers +
CR, i, d
EMDMain.Character(d).Send = ToVictim + CR
Else
SendToRoom EMDMain.Character(i).Environment, ToOthers +
CR, i, 0
End If
Else
Soul = False
End If
End Function
Sub StartEMD(Entry As String)
Dim d&, f%, s$, SQL$
Dim rs As Recordset
On Error Resume Next
s = Entry
Err.Number = 0
If EMDMain.SocketConnection.State <> sckListening Then
Screen.MousePointer = 11
DoEvents
EMDLibrary = s
Set WS = CreateWorkspace("", "admin", "", dbUseJet)
Set EMDB = WS.OpenDatabase(AppPath + EMDLibrary + ".mdb",
False, False)
If Err.Number = 0 Then
SQL = "SELECT * FROM Configuration"
Set rs = EMDB.OpenRecordset(SQL, dbOpenDynaset)
If rs.RecordCount > 0 Then
MudName = Trim$(rs!MudName)
MudPort = rs!MudPort
MaxConnections = rs!MaxConnections
End If
rs.Close
If ((MaxConnections <= 0) Or (MaxConnections > 32000))
Then
MaxConnections = 50
End If
If MudPort = 0 Then
MudPort = 5000
End If
EMDMain.Configuration.Caption = Left$("Mud Name:" +
Space$(20), 20) + MudName + CR
EMDMain.Configuration.Caption =
EMDMain.Configuration.Caption + Left$("Port:" + Space$(20), 20) +
Trim$(MudPort) + CR
EMDMain.Configuration.Caption =
EMDMain.Configuration.Caption + Left$("Max Connections:" + Space$(20),
20) + Trim$(MaxConnections) + CR
App.Title = EMDLibrary
EMDMain.Caption = MudName + " - " + Trim$(Str$(MudPort))
DoEvents
TrayIcon.cbSize = Len(TrayIcon)
TrayIcon.hWnd = MenuForm.PicHook.hWnd
TrayIcon.uId = 1&
TrayIcon.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
TrayIcon.ucallbackMessage = WM_MOUSEMOVE
TrayIcon.hIcon = EMDMain.Icon
TrayIcon.szTip = EMDMain.Caption & Chr$(0)
App.TaskVisible = False
RefreshEMD 0
EMDMain.IconiseButton.Enabled = True
EMDMain.SocketConnection.LocalPort = MudPort
DoEvents
Err.Number = 0
EMDMain.SocketConnection.Listen
DoEvents
If Err.Number > 0 Then
MsgBox ("Fatal Stack Error: Socket In Use. Unable to
start daemon on port " + Trim$(MudPort) + "."), , "Information"
Shutdown = True
End If
Else
MsgBox ("Error opening EMDLib '" + EMDLibrary + "'" + CR +
CR + "Error Code: " + Trim$(Err.Number) + " (" +
Trim$(Err.Description) + ")"), , "Information"
End If
Screen.MousePointer = 0
Else
MsgBox ("Can't start new EMDLib." + CR + CR + "Already Running
EMDLib '" + EMDLibrary + "'."), , "Information"
End If
End Sub

EMDMain.frm:

Option Explicit
Private Sub AdministrationButton_Click()
EMDAdmin.Show
End Sub
Private Sub ExitButton_Click()
Unload MenuForm
Unload EMDMain
End Sub
Private Sub Form_Load()
Dim d&, s$
EMDMain.Left = (Screen.Width - EMDMain.Width) / 2
EMDMain.Top = (Screen.Height - EMDMain.Height) / 2
EMDFiles.Path = AppPath
EMDFiles.Refresh
DoEvents
Load MenuForm
If EMDFiles.ListCount > 0 Then
s = Trim$(EMDFiles.List(0))
If InStr(s, ".") > 0 Then
s = Left$(s, InStr(s, ".") - 1)
End If
StartEMD s
Else
MsgBox ("Unable to load. No libraries available in " +
Trim$(LCase(AppPath)) + "."), , "Information"
Shutdown = True
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
Shutdown = True
End Sub
Private Sub IconiseButton_Click()
EMDMain.Hide
AddTrayIcon
End Sub
Private Sub SocketConnection_ConnectionRequest(ByVal requestID As
Long)
Dim i%, r&
On Error Resume Next
r = requestID
If r > 32000 Then
Load Character(32001)
Character(32001).Accept = r
Character(32001).Send = "Non-Fatal Stack Error: Invalid Socket
Handle." + CR
Character(32001).Quit = True
Unload Character(32001)
Else
i = r
Load Character(i)
Character(i).Accept = i
Character(i).MudName = MudName
Init i
End If
End Sub
Private Sub UpdateHeartBeat_Timer()
MudHeartBeat = True
End Sub

EMDAdmin.frm:

Option Explicit
Private Sub Form_Load()
EMDAdmin.Left = (Screen.Width - EMDAdmin.Width) / 2
EMDAdmin.Top = (Screen.Height - EMDAdmin.Height) / 2
End Sub
Private Sub mnu_Hide_Click()
EMDAdmin.Hide
End Sub
Private Sub Objects_DblClick()
Dim d&
On Error Resume Next
If Objects.ListCount > 0 Then
d = Objects.ListIndex
If d >= 0 Then
MsgBox (EMDMain.Object(Val(Objects.List(d))).ObjectName),
, "Information"
End If
End If
End Sub
Private Sub Rooms_DblClick()
Dim d&
On Error Resume Next
If Rooms.ListCount > 0 Then
d = Rooms.ListIndex
If d >= 0 Then
MsgBox (EMDMain.Environment(Val(Rooms.List(d))).RoomName),
, "Information"
End If
End If
End Sub
Private Sub Users_DblClick()
Dim d&
On Error Resume Next
If Users.ListCount > 0 Then
d = Users.ListIndex
If d >= 0 Then
MsgBox (EMDMain.Character(Val(Users.List(d))).CharName), ,
"Information"
End If
End If
End Sub

MenuForm.frm:

Option Explicit
Private Sub Form_Unload(Cancel As Integer)
RemoveTrayIcon
End Sub
Private Sub mnu_Administer_Click()
EMDAdmin.Show
End Sub
Private Sub mnu_Exit_Click()
On Error Resume Next
Shutdown = True
End Sub
Private Sub mnu_Restore_Click()
RemoveTrayIcon
EMDMain.Show
End Sub
Private Sub PicHook_MouseMove(Button As Integer, Shift As Integer, x
As Single, Y As Single)
Static rec As Boolean, msg As Long
msg = x / Screen.TwipsPerPixelX
If rec = False Then
rec = True
Select Case msg
Case WM_LBUTTONDBLCLK:
mnu_Restore_Click
Case WM_LBUTTONDOWN:
Case WM_LBUTTONUP:
Case WM_RBUTTONDBLCLK:
Case WM_RBUTTONDOWN:
Case WM_RBUTTONUP:
PopupMenu mnuFile
End Select
rec = False
End If
End Sub

Character.ocx:

Public CharName As String
Public BodyType As String
Public CharStatus As Integer
Public Description As String
Public Environment As Long
Public HitPoints As Long
Public Gender As String
Public IPAddress As String
Public LastCommand As String
Public LastTellFrom As String
Public LimbCount As Long
Dim LimbName() As String
Dim LimbFatalIfLost() As Boolean
Dim LimbIsLimbAttached() As Boolean
Dim LimbIsLimbWieldable() As Boolean
Dim LimbAttachedLimbs() As String
Dim LimbWieldedWeapon() As Long
Dim LimbWornArmour() As Long
Public LoginState As Integer
Public MaxHitPoints As Long
Public Message As String
Public Mudname As String
Public SubscribedChannels As String
Public Title As String
Public UnsubscribedChannels As String
Public Property Let Accept(Index As Integer)
Dim i%
i = Index
SocketConnection.Accept i
IPAddress = Trim$(SocketConnection.RemoteHostIP)
End Property
Private Function AnsiParse(Entry As String) As String
Dim s$
s = Entry
s = ReplaceString(s, "%^RESET%^", Chr$(27) + "[0m" + Chr$(27) +
"[1m")
s = ReplaceString(s, "%^BLACK%^", Chr$(27) + "[30m")
s = ReplaceString(s, "%^RED%^", Chr$(27) + "[31m")
s = ReplaceString(s, "%^GREEN%^", Chr$(27) + "[32m")
s = ReplaceString(s, "%^ORANGE%^", Chr$(27) + "[33m")
s = ReplaceString(s, "%^BLUE%^", Chr$(27) + "[34m")
s = ReplaceString(s, "%^MAGENTA%^", Chr$(27) + "[35m")
s = ReplaceString(s, "%^CYAN%^", Chr$(27) + "[36m")
s = ReplaceString(s, "%^WHITE%^", Chr$(27) + "[37m")
s = ReplaceString(s, "%^YELLOW%^", Chr$(27) + "[1m" + Chr$(27) +
"[33m")
s = ReplaceString(s, "%^B_BLACK%^", Chr$(27) + "[40m")
s = ReplaceString(s, "%^B_RED%^", Chr$(27) + "[41m")
s = ReplaceString(s, "%^B_GREEN%^", Chr$(27) + "[42m")
s = ReplaceString(s, "%^B_ORANGE%^", Chr$(27) + "[43m")
s = ReplaceString(s, "%^B_BLUE%^", Chr$(27) + "[44m")
s = ReplaceString(s, "%^B_MAGENTA%^", Chr$(27) + "[45m")
s = ReplaceString(s, "%^B_CYAN%^", Chr$(27) + "[46m")
s = ReplaceString(s, "%^B_WHITE%^", Chr$(27) + "[47m")
s = ReplaceString(s, "%^B_YELLOW%^", Chr$(27) + "[1m" + Chr$(27) +
"[43m")
'
s = ReplaceString(s, Chr$(13) + Chr$(10), "\n")
s = ReplaceString(s, "\n", Chr$(27) + "[0m" + Chr$(27) + "[1m" +
Chr$(13) + Chr$(10))
'
s = ReplaceString(s, "%^CHARNAME%^", CharName)
s = ReplaceString(s, "%^LOCALHOST%^", IPAddress)
s = ReplaceString(s, "%^MUDNAME%^", Mudname)
s = ReplaceString(s, "%^ROSE%^", Chr$(27) + "[31m" + "@" +
Chr$(27) + "[32m" + "}-,-'-}---" + Chr$(27) + "[37m")
'
s = ReplaceString(s, "%^HP%^", Trim$(HitPoints))
s = ReplaceString(s, "%^MHP%^", Trim$(MaxHitPoints))
DoEvents
AnsiParse = s
End Function
Public Property Get LimbAdd(n As String, fil As Boolean, ila As
Boolean, ilw As Boolean, al As String) As Integer
Dim i&
i = LimbCount
i = i + 1
ReDim Preserve LimbName(i)
ReDim Preserve LimbFatalIfLost(i)
ReDim Preserve LimbIsLimbAttached(i)
ReDim Preserve LimbIsLimbWieldable(i)
ReDim Preserve LimbAttachedLimbs(i)
ReDim Preserve LimbWieldedWeapon(i)
ReDim Preserve LimbWornArmour(i)
LimbName(i) = n
LimbFatalIfLost(i) = fil
LimbIsLimbAttached(i) = ila
LimbIsLimbWieldable(i) = ilw
LimbAttachedLimbs(i) = al
LimbWieldedWeapon(i) = 0
LimbWornArmour(i) = 0
LimbCount = i
LimbAdd = True
End Property
Public Property Get GetLimbName(Index As Long) As String
Dim i&
i = Index
GetLimbName = LimbName(i)
End Property
Public Property Get GetLimbFatalIfLost(Index As Long) As Boolean
Dim i&
i = Index
GetLimbFatalIfLost = LimbFatalIfLost(i)
End Property
Public Property Get GetLimbIsLimbAttached(Index As Long) As Boolean
Dim i&
i = Index
GetLimbIsLimbAttached = LimbIsLimbAttached(i)
End Property
Public Property Get GetLimbIsLimbWieldable(Index As Long) As Boolean
Dim i&
i = Index
GetLimbIsLimbWieldable = LimbIsLimbWieldable(i)
End Property
Public Property Get GetLimbAttachedLimbs(Index As Long) As String
Dim i&
i = Index
GetLimbAttachedLimbs = LimbAttachedLimbs(i)
End Property
Public Property Get GetLimbWieldedWeapon(Index As Long) As Long
Dim i&
i = Index
GetLimbWieldedWeapon = LimbWieldedWeapon(i)
End Property
Public Property Get GetLimbWornArmour(Index As Long) As Long
Dim i&
i = Index
GetLimbWornArmour = LimbWornArmour(i)
End Property
Public Property Get NextCommand() As String
Dim s$, t$
s = Message
If InStr(s, Chr$(13)) > 0 Then
s = Left$(s, InStr(s, Chr$(13)) - 1)
Message = Right$(Message, Len(Message) - InStr(Message,
Chr$(13)))
s = ParseData(s)
If InStr(s, " ") > 0 Then
LastCommand = LCase(Left$(s, InStr(s, " "))) + Right$(s,
Len(s) - InStr(s, " "))
NextCommand = LastCommand
Else
If s = "!!" Then
NextCommand = LastCommand
Else
LastCommand = LCase(s)
NextCommand = LastCommand
End If
End If
Else
NextCommand = ""
End If
End Property
Public Property Let ObjectAdd(Index As Long)
Dim i&
i = Index
Objects.AddItem Trim$(i)
End Property
Public Property Get ObjectCount() As Long
Dim i&
i = Objects.ListCount
ObjectCount = i
End Property
Public Property Get ObjectIndex(Index As Long) As Long
Dim d&, i&
i = Index
If i < Objects.ListCount Then
d = CDbl(Objects.List(i))
Else
d = 0
End If
ObjectIndex = d
End Property
Public Property Let ObjectRemove(Index As Long)
Dim d&, i&
i = Index
For d = 0 To Objects.ListCount - 1
If i = CDbl(Objects.List(d)) Then
Objects.RemoveItem d
Exit Property
End If
Next
End Property
Private Function ParseData(Entry As String) As String
Dim d&, e%, s$, t$, u$
s = Entry
If Len(s) > 0 Then
For d = 1 To Len(s)
t = Right$(Left$(s, d), 1)
e = Asc(t)
If e > 31 And e < 129 Then
u = u & t
ElseIf e = 8 Then
If Len(u) > 0 Then
u = Left$(u, Len(u) - 1)
End If
End If
Next
End If
ParseData = u
End Function
Public Property Let Quit(Index As Integer)
Dim i%
i = Index
SocketConnection.Close
End Property
Public Function ReplaceString(Entry As String, Target As String,
Replacement As String) As String
Dim a$, b$, d&, s$, t$
On Error Resume Next
s = Entry
a = Target
b = Replacement
t = "%^NULL%^"
Do Until InStr(s, a) = 0
d = InStr(s, a)
s = Left$(s, d - 1) + t + Right$(s, Len(s) - d - Len(a) + 1)
Loop
Do Until InStr(s, t) = 0
d = InStr(s, t)
s = Left$(s, d - 1) + b + Right$(s, Len(s) - d - Len(t) + 1)
Loop
ReplaceString = s
End Function
Public Property Let Send(Entry As String)
Dim i%, s$
i = Index
s = Entry
s = AnsiParse(s)
SocketConnection.SendData s
DoEvents
End Property
Public Property Get SetLimbWieldedWeapon(Index As Long, Setting As
Long) As Integer
Dim a&, i&
i = Index
a = Setting
LimbWieldedWeapon(i) = a
SetLimbWieldedWeapon = True
End Property
Public Property Get SetLimbWornArmour(Index As Long, Setting As Long)
As Integer
Dim a&, i&
i = Index
a = Setting
LimbWornArmour(i) = a
SetLimbWornArmour = True
End Property
Private Sub SocketConnection_DataArrival(ByVal bytesTotal As Long)
Dim s$
On Error Resume Next
SocketConnection.GetData s, vbString
Message = Message & s
End Sub
Public Property Get SocketState() As Integer
Dim i%
i = SocketConnection.State
SocketState = i
End Property
Private Sub UserControl_Resize()
UserControl.Width = 430
UserControl.Height = 430
End Sub

Environment.ocx:

Public AllowDestruct As Boolean
Public Description As String
Public ExitCount As Long
Dim ExitDestination() As Long
Dim ExitKey() As Long
Dim ExitLocked() As Boolean
Dim ExitLockedMessageOthers() As String
Dim ExitLockedMessageSelf() As String
Dim ExitMessageOthers() As String
Dim ExitMessageSelf() As String
Dim ExitName() As String
Dim ExitObviousExit() As Boolean
Dim ExitBlocked() As Boolean
Public IsShop As Boolean
Public LastReset As Double
Public LoadOnReset As String
Public RoomName As String
Public ShopKeeper As String
Public ShopStockRoom As Long
Public Property Let CharacterAdd(Index As Long)
Dim i&
i = Index
Characters.AddItem Trim$(i)
End Property
Public Property Get CharacterCount() As Long
Dim i&
i = Characters.ListCount
CharacterCount = i
End Property
Public Property Get CharacterIndex(Index As Long) As Long
Dim d&, i&
i = Index
If i < Characters.ListCount Then
d = CDbl(Characters.List(i))
Else
d = 0
End If
CharacterIndex = d
End Property
Public Property Let CharacterRemove(Index As Long)
Dim d&, i&
i = Index
For d = 0 To Characters.ListCount - 1
If i = CDbl(Characters.List(d)) Then
Characters.RemoveItem d
Exit Property
End If
Next
End Property
Public Property Get ClearExits() As Integer
ReDim ExitDestination(0)
ReDim ExitLocked(0)
ReDim ExitLockedMessageOthers(0)
ReDim ExitLockedMessageSelf(0)
ReDim ExitMessageOthers(0)
ReDim ExitMessageSelf(0)
ReDim ExitName(0)
ReDim ExitObviousExit(0)
ExitCount = 0
ClearExits = True
End Property
Public Property Get ExitAdd(d As Long, k As Long, l As Boolean, lmo As
String, lms As String, mo As String, ms As String, n As String, oe As
Boolean, b As Boolean) As Integer
Dim i&
i = ExitCount
i = i + 1
ReDim Preserve ExitDestination(i)
ReDim Preserve ExitKey(i)
ReDim Preserve ExitLocked(i)
ReDim Preserve ExitLockedMessageOthers(i)
ReDim Preserve ExitLockedMessageSelf(i)
ReDim Preserve ExitMessageOthers(i)
ReDim Preserve ExitMessageSelf(i)
ReDim Preserve ExitName(i)
ReDim Preserve ExitObviousExit(i)
ReDim Preserve ExitBlocked(i)
ExitDestination(i) = d
ExitKey(i) = k
ExitLocked(i) = l
ExitLockedMessageOthers(i) = lmo
ExitLockedMessageSelf(i) = lms
ExitMessageOthers(i) = mo
ExitMessageSelf(i) = ms
ExitName(i) = n
ExitObviousExit(i) = oe
ExitBlocked(i) = b
ExitCount = i
ExitAdd = True
End Property
Public Property Get GetExitDestination(Index As Long) As Long
Dim i&
i = Index
GetExitDestination = ExitDestination(i)
End Property
Public Property Get GetExitKey(Index As Long) As Long
Dim i&
i = Index
GetExitKey = ExitKey(i)
End Property
Public Property Get GetExitLocked(Index As Long) As Boolean
Dim i&
i = Index
GetExitLocked = ExitLocked(i)
End Property
Public Property Get GetExitLockedMessageOthers(Index As Long) As
String
Dim i&
i = Index
GetExitLockedMessageOthers = ExitLockedMessageOthers(i)
End Property
Public Property Get GetExitLockedMessageSelf(Index As Long) As String
Dim i&
i = Index
GetExitLockedMessageSelf = ExitLockedMessageSelf(i)
End Property
Public Property Get GetExitMessageOthers(Index As Long) As String
Dim i&
i = Index
GetExitMessageOthers = ExitMessageOthers(i)
End Property
Public Property Get GetExitMessageSelf(Index As Long) As String
Dim i&
i = Index
GetExitMessageSelf = ExitMessageSelf(i)
End Property
Public Property Get GetExitName(Index As Long) As String
Dim i&
i = Index
GetExitName = ExitName(i)
End Property
Public Property Get GetExitObviousExit(Index As Long) As Boolean
Dim i&
i = Index
GetExitObviousExit = ExitObviousExit(i)
End Property
Public Property Get GetExitBlocked(Index As Long) As Boolean
Dim i&
i = Index
GetExitBlocked = ExitBlocked(i)
End Property
Public Property Let MonsterAdd(Index As Long)
Dim i&
i = Index
Monsters.AddItem Trim$(i)
End Property
Public Property Get MonsterCount() As Long
Dim i&
i = Monsters.ListCount
MonsterCount = i
End Property
Public Property Get MonsterIndex(Index As Long) As Long
Dim d&, i&
i = Index
If i < Monsters.ListCount Then
d = CDbl(Monsters.List(i))
Else
d = 0
End If
MonsterIndex = d
End Property
Public Property Let MonsterRemove(Index As Long)
Dim d&, i&
i = Index
For d = 0 To Monsters.ListCount - 1
If i = CDbl(Monsters.List(d)) Then
Monsters.RemoveItem d
Exit Property
End If
Next
End Property
Public Property Let ObjectAdd(Index As Long)
Dim i&
i = Index
Objects.AddItem Trim$(i)
End Property
Public Property Get ObjectCount() As Long
Dim i&
i = Objects.ListCount
ObjectCount = i
End Property
Public Property Get ObjectIndex(Index As Long) As Long
Dim d&, i&
i = Index
If i < Objects.ListCount Then
d = CDbl(Objects.List(i))
Else
d = 0
End If
ObjectIndex = d
End Property
Public Property Let ObjectRemove(Index As Long)
Dim d&, i&
i = Index
For d = 0 To Objects.ListCount - 1
If i = CDbl(Objects.List(d)) Then
Objects.RemoveItem d
Exit Property
End If
Next
End Property
Private Sub UserControl_Resize()
UserControl.Width = 430
UserControl.Height = 430
End Sub

Object.ocx:

Public ArmourClass As Long
Public CanBeMoved As Boolean
Public CoveredLimbs As String
Public Description As String
Public DoubleWielded As Boolean
Public ObjectID As String
Public ObjectIndex As Long
Public ObjectName As String
Public ObjectType As Long
Public Value As Long
Public WeaponClass As Long
Public Property Let ItemAdd(Index As Long)
Dim i&
i = Index
Items.AddItem Trim$(i)
End Property
Public Property Get ItemCount() As Long
Dim i&
i = Items.ListCount
ItemCount = i
End Property
Public Property Get ItemIndex(Index As Long) As Long
Dim d&, i&
i = Index
If i < Items.ListCount Then
d = CDbl(Items.List(i))
Else
d = 0
End If
ItemIndex = d
End Property
Public Property Let ItemRemove(Index As Long)
Dim d&, i&
i = Index
For d = 0 To Items.ListCount - 1
If i = CDbl(Items.List(d)) Then
Items.RemoveItem d
Exit Property
End If
Next
End Property
Private Sub UserControl_Resize()
UserControl.Width = 430
UserControl.Height = 430
End Sub

Encrypt.ocx:

Private Sub UserControl_Resize()
UserControl.Width = 430
UserControl.Height = 430
End Sub
Public Property Get Encrypt(CryptKey As String, Entry As String) As
String
Dim a%, b%, c$, d%, p$, s$, t$
On Error Resume Next
c = CryptKey
p = Entry
a = 1
For d = 1 To Len(p)
b = Asc(Mid$(c, a, 1))
a = a + 1
If a > Len(c) Then
a = 1
End If
Mid$(p, d, 1) = Chr$(Asc(Mid$(p, d, 1)) Xor b)
Next
s = ""
For d = 1 To Len(p)
t = Hex$(Asc(Mid$(p, d, 1)))
If Len(t) = 1 Then t = "0" + t
s = s + t
Next
Encrypt = s
End Property

Monster.ocx:

Public MonsterName As String
Public BodyType As String
Public Description As String
Public Environment As Long
Public HitPoints As Long
Public Gender As String
Public LimbCount As Long
Dim LimbName() As String
Dim LimbFatalIfLost() As Boolean
Dim LimbIsLimbAttached() As Boolean
Dim LimbIsLimbWieldable() As Boolean
Dim LimbAttachedLimbs() As String
Dim LimbWieldedWeapon() As Long
Public MaxHitPoints As Long
Public Title As String
Private Function AnsiParse(Entry As String) As String
Dim s$
s = Entry
s = ReplaceString(s, "%^RESET%^", "")
s = ReplaceString(s, "%^BLACK%^", "")
s = ReplaceString(s, "%^RED%^", "")
s = ReplaceString(s, "%^GREEN%^", "")
s = ReplaceString(s, "%^ORANGE%^", "")
s = ReplaceString(s, "%^BLUE%^", "")
s = ReplaceString(s, "%^MAGENTA%^", "")
s = ReplaceString(s, "%^CYAN%^", "")
s = ReplaceString(s, "%^WHITE%^", "")
s = ReplaceString(s, "%^YELLOW%^", "")
s = ReplaceString(s, "%^B_BLACK%^", "")
s = ReplaceString(s, "%^B_RED%^", "")
s = ReplaceString(s, "%^B_GREEN%^", "")
s = ReplaceString(s, "%^B_ORANGE%^", "")
s = ReplaceString(s, "%^B_BLUE%^", "")
s = ReplaceString(s, "%^B_MAGENTA%^", "")
s = ReplaceString(s, "%^B_CYAN%^", "")
s = ReplaceString(s, "%^B_WHITE%^", "")
s = ReplaceString(s, "%^B_YELLOW%^", "")
'
s = ReplaceString(s, Chr$(13) + Chr$(10), "\n")
s = ReplaceString(s, "\n", Chr$(27) + "[0m" + Chr$(27) + "[1m" +
Chr$(13) + Chr$(10))
'
s = ReplaceString(s, "%^CHARNAME%^", "")
s = ReplaceString(s, "%^LOCALHOST%^", "")
s = ReplaceString(s, "%^MUDNAME%^", "")
s = ReplaceString(s, "%^ROSE%^", "rose")
'
s = ReplaceString(s, "%^HP%^", Trim$(HitPoints))
s = ReplaceString(s, "%^MHP%^", Trim$(MaxHitPoints))
DoEvents
AnsiParse = s
End Function
Public Property Get LimbAdd(n As String, fil As Boolean, ila As
Boolean, ilw As Boolean, al As String) As Integer
Dim i&
i = LimbCount
i = i + 1
ReDim Preserve LimbName(i)
ReDim Preserve LimbFatalIfLost(i)
ReDim Preserve LimbIsLimbAttached(i)
ReDim Preserve LimbIsLimbWieldable(i)
ReDim Preserve LimbAttachedLimbs(i)
ReDim Preserve LimbWieldedWeapon(i)
LimbName(i) = n
LimbFatalIfLost(i) = fil
LimbIsLimbAttached(i) = ila
LimbIsLimbWieldable(i) = ilw
LimbAttachedLimbs(i) = al
LimbWieldedWeapon(i) = 0
LimbCount = i
LimbAdd = True
End Property
Public Property Get GetLimbName(Index As Long) As String
Dim i&
i = Index
GetLimbName = LimbName(i)
End Property
Public Property Get GetLimbFatalIfLost(Index As Long) As Boolean
Dim i&
i = Index
GetLimbFatalIfLost = LimbFatalIfLost(i)
End Property
Public Property Get GetLimbIsLimbAttached(Index As Long) As Boolean
Dim i&
i = Index
GetLimbIsLimbAttached = LimbIsLimbAttached(i)
End Property
Public Property Get GetLimbIsLimbWieldable(Index As Long) As Boolean
Dim i&
i = Index
GetLimbIsLimbWieldable = LimbIsLimbWieldable(i)
End Property
Public Property Get GetLimbAttachedLimbs(Index As Long) As String
Dim i&
i = Index
GetLimbAttachedLimbs = LimbAttachedLimbs(i)
End Property
Public Property Get GetLimbWieldedWeapon(Index As Long) As Long
Dim i&
i = Index
GetLimbWieldedWeapon = LimbWieldedWeapon(i)
End Property
Public Property Let ObjectAdd(Index As Long)
Dim i&
i = Index
Objects.AddItem Trim$(i)
End Property
Public Property Get ObjectCount() As Long
Dim i&
i = Objects.ListCount
ObjectCount = i
End Property
Public Property Get ObjectIndex(Index As Long) As Long
Dim d&, i&
i = Index
If i < Objects.ListCount Then
d = CDbl(Objects.List(i))
Else
d = 0
End If
ObjectIndex = d
End Property
Public Property Let ObjectRemove(Index As Long)
Dim d&, i&
i = Index
For d = 0 To Objects.ListCount - 1
If i = CDbl(Objects.List(d)) Then
Objects.RemoveItem d
Exit Property
End If
Next
End Property
Public Function ReplaceString(Entry As String, Target As String,
Replacement As String) As String
Dim a$, b$, d&, s$, t$
On Error Resume Next
s = Entry
a = Target
b = Replacement
t = "%^NULL%^"
Do Until InStr(s, a) = 0
d = InStr(s, a)
s = Left$(s, d - 1) + t + Right$(s, Len(s) - d - Len(a) + 1)
Loop
Do Until InStr(s, t) = 0
d = InStr(s, t)
s = Left$(s, d - 1) + b + Right$(s, Len(s) - d - Len(t) + 1)
Loop
ReplaceString = s
End Function
Public Property Let Send(Entry As String)
Dim i%, s$
i = Index
s = Entry
s = AnsiParse(s)
DoEvents
End Property
Public Property Get SetLimbWieldedWeapon(Index As Long, Setting As
Long) As Integer
Dim a&, i&
i = Index
a = Setting
LimbWieldedWeapon(i) = a
SetLimbWieldedWeapon = True
End Property
Private Sub UserControl_Resize()
UserControl.Width = 430
UserControl.Height = 430
End Sub

0 new messages