极语言7-2 全任务端及源码

//game.vbsc
Dim Play(),Pets(),Uid(),MEXP(150),Mon,UsZH,UsNM
Dim Drop,Sel,Kof,Tsk,Stn,Opn,Dtc,VOM,Mov,Mpc,ITM
Dim Npc,Nps(),Nid,Tem(),Tmd,Pos,Gtm,Ggb,Ggs,Rat
Dim Pid,mvds,Nul,CkNm,Pw(3),PwZ,PwX,PwT,Drs
Dim Jys,Lps,Jqs,Wps,Rws,PKs,TZs,FQs,lns
Const WPL = 36
Const GBD = 500
Const NHD = 1000
Const NPD = 10000
Const MGD = 10000000
Const GMD = 100000000
Const MMY = 1000000000
Const YKTS="秒后开始异口同声活动，输入 /爱我中华 可获得意外奖励!"
'初始化事件
Sub Init
Gtm=0
Ggs=0
ReDim Play(10)
ReDim Uid(10)
ReDim Nps(0)
ReDim Tem(0)
ReDim Pets(0)
Set UsNM = Server.Dict
Set UsZH = Server.Dict
Set Nid = Server.Coll
Set Tmd = Server.Coll
Set Pid = Server.Coll
Set Drs = Server.Dict
Set Npc = Server.Dict
Nul=String(WPL,ChrB(0))
Server.Opd "driver={SQLite3 ODBC Driver};Database=game.db"
Reini
ReLEV
ReMap
ReMon
ReDrop
ReOpen
ReKof
ReTsk
ReStn
ReVOM
ReMov
ReMpc
ReRat
ReSel
ReITM
VerIP
SerLine
LoadMap 101
Server.SetTime 0,1000
mvds=Split("15,30,45,60,65,70,75,80",",")
Set Tem(0) = New TEAMINFO
End Sub
Sub OnLine(id,ty,bs)
Select Case ty
Case 0 '登陆
l=bs.Rdat(2,4)
if l+10>bs.Lent then
Reply id,23, "信息错误",bs
else
user=bs.RStr(l)
s=bs.Rdat(2)
pass=bs.RStr(s)
Set rs = Server.Execute("select * from account where 账号='" & user & "'")
If rs.EOF Then
Reply id,9, user,bs
ElseIf pass <> rs("密码") Then
Reply id,10, pass,bs
ElseIf rs("分区") = 0 Then
Reply id,23, "分区不正确",bs
Else
Uid(id)=user
if UsZH.Exists(user) then
i=UsZH(user)
if IsNumeric(i) then
QuitPlay i
Server.OFF i
end if
end if
UsZH(user)=rs("性别")&"#"
Reply id,0, user,bs
Server.AddMsg user & ":登陆成功。"
End If
rs.Close
Set rs = Nothing
end if
Case 12
SendIP id,bs
Case 22
Server.Send id,Uid(0)
End Select
End Sub
Sub Gmdat(id,bs)
Select Case bs.Rdat(2,7)
Case &H1606
Case &H1607
FaXn id,bs.Rdat(1,11), bs.Rdat(1,13)
Case &H1610, &H1630
DYCS id,bs
Case &H1616
HUAN id,bs
Case &H1640
Case &H1642
Case &H161E
GTCG id,bs
Case &H1720, &H1722
YBFH id,bs
Case &H1724
bs.Wdat 37,1, 7
Server.Send id,bs.Rdat
CSWZ id,bs
Case &H1750
bs.Wdat 81,1,7
bs.Wdat 1,1,23
bs.Wdat 159,1,31
SendP id, bs.Rdat
Case &H18C0
NpcDH id,2
CSDT id, bs.Rdat(4,11)
Case &H2014
ReDat 4,&H2015,id,bs
Server.Send id, bs.Rdat
End Select
End Sub

Sub OnTimer(id)
if id > NPD then
NTimer id-NPD
elseif id>0 then
PTimer id
else
Timer1
end if
End Sub
Sub OnMsg(str)
if str="quit" then
For Each id in UsNM
QuitPlay id
Next
Server.Quit
end if
End Sub

Sub OffLine(id)
if Uid(id)<>"" then
QuitPlay id
Uid(id)=""
Server.AddMsg Uid(id) & ":断开连接。"
end if
End Sub

Sub Timer1
On Error Resume Next
Gtm = Gtm + 1
If Gtm Mod 255 = 0 Then
SendMsg 0,8,Pos(1).Value, Pos(2).Value
If Pos.EOF Then
Pos.MoveFirst
Else
Pos.MoveNext
End If
End If
For Each m In Drs.Items
if Gtm>m(1) then DelBW m
Next
End Sub

Sub Nmb(bs,ptr,wp)
Randomize
bs.Wdat Rnd * MGD,4, ptr
bs.Wdat DateDiff("s", "2016-01-01", Now),4
if wp>0 then
bs.Wdat wp,4
bs.Wdat 1,4
end if
End Sub
Sub Reply(id,ty,msg,bs)
bs.Lent=8
bs.Wdat 32769
l= bs.LenS(msg)
bs.Wdat l + 4
bs.Wdat ty
bs.Wdat l
if l > 0 then bs.Wdat msg,0
bs.Denc MiMa,1
Server.Send id,bs.Rdat
End Sub

Sub SendIP(id,bs)
s=bs.Rdat(1,4)
l=bs.Rdat(1,8)
if Uid(id)="" then
Reply id,23, "请重新登陆",bs
else
UsZH(Uid(id))=UsZH(Uid(id))& l
Uid(id)=""
SNM=lns(s-1)
bs.Lent=6
la = bs.LenS(SIP)
lb = bs.LenS(SNM)
bs.Wdat 32868
bs.Wdat la + lb + 4
bs.Wdat la
bs.Wdat SIP,0
bs.Wdat SPt
bs.Wdat lb
bs.Wdat SNM,0
bs.Denc MiMa,1
Server.Send id,bs.Rdat
end if
End Sub

Sub Reini
FQs=Server.ini("游戏","分区")
Jys=Server.ini("游戏","经验")
Lps=Server.ini("游戏","历练")
Jqs=Server.ini("游戏","金钱")
Wps=Server.ini("游戏","物品")
Rws=Server.ini("游戏","任务")
PKs=Server.ini("游戏","切磋")
TZs=Server.ini("游戏","挑战")
Server.AddMsg "重读配置文件完成。"
End Sub
Sub SerLine
svn=Server.ini("游戏","名称")
Set bs=Server.BinCls
bs.Wdat 32791,4
bs.Wdat 1
bs.Wdat 1
bs.Wdat bs.LenS(svn)
bs.Wdat svn,0
lns=Split(Server.ini("分区"), vbNullChar)
ns=Ubound(lns)
bs.Wdat 1,4
bs.Wdat 1
bs.Wdat ns+1
For j = 0 To ns
bs.Wdat j + 1
bs.Wdat bs.LenS(lns(j))
bs.Wdat lns(j),0
la=Server.ini("分区",lns(j))
bs.Wdat la
Next
bs.Wdat bs.Lent-4,2,2
bs.Denc MiMa,1
Uid(0)=bs.Rdat
Set bs=Nothing
Server.AddMsg "重读线路列表完成。"
End Sub

Class PlayInfo
Dim id,pnam,mpid,mpnm,mplv,mpic,mfz,pda,gg,hp,mp,sp,mh,mm,zl,fz,sf,Pet,pt,lz,bl,xc,rx,vip
Dim zx,lv,zz,zy,fac,clr,hir,snd,sex,x,y,dt,dx,dy,ds,tm,tj,ts,zn,zt,zts,ztid,olt,zd,sd,wp,bh
Dim wk,wx,se,ep,lp,lj,bf,bs,cb,fn,wq,jf,js,jq,qz,qc,qg,jn,ad,pd,au,zb,ck,qk,zh,wg,fj,tl,yj,rw,wc
Dim xn,ti,li,sn,at,df,mz,hb,at1,at2,zs,wl,wf,gj,fy,mj,hj,sj,nj,tz(30),jl(30),sit,dp,pw,pk,sz,gs
End Class

Class PETINFO
Dim id,pnm,X,Y,dt,hp,mp,mh,mm,ep,zc,zl,lv,bs,zz,zy,zs,wg,wf,at1,at2,df,mz,hb,jn,zb
End Class

Class ITMInfo
Dim mc,ts,zx,zy,lv,cd,zs,xb,ty,zl,at1,at2,df,jq,sx(4)
End Class

Class NPCINFO
Dim ad,ats,id,nd,dt,hp,X,Y,sh,zt
End Class

Class TEAMINFO
Dim sl,md,lv,rx,sx,cy(7)
End Class