home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 3_2004-2005.ISO / Data / Zips / Dark_Windo1785088232004.psc / Form1.frm < prev    next >
Text File  |  2004-08-23  |  9KB  |  346 lines
  1. VERSION 5.00
  2. Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
  3. Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
  4. Begin VB.Form Form1 
  5.    BackColor       =   &H00000000&
  6.    BorderStyle     =   4  'Fixed ToolWindow
  7.    Caption         =   "Black Window 0.1 BETA"
  8.    ClientHeight    =   1725
  9.    ClientLeft      =   11430
  10.    ClientTop       =   1425
  11.    ClientWidth     =   1320
  12.    Icon            =   "Form1.frx":0000
  13.    LinkTopic       =   "Form1"
  14.    MaxButton       =   0   'False
  15.    MinButton       =   0   'False
  16.    ScaleHeight     =   1725
  17.    ScaleWidth      =   1320
  18.    Begin MSComCtl2.Animation Anim 
  19.       Height          =   975
  20.       Left            =   120
  21.       TabIndex        =   0
  22.       Top             =   120
  23.       Width           =   1095
  24.       _ExtentX        =   1931
  25.       _ExtentY        =   1720
  26.       _Version        =   393216
  27.       Center          =   -1  'True
  28.       BackColor       =   0
  29.       FullWidth       =   73
  30.       FullHeight      =   65
  31.    End
  32.    Begin MSWinsockLib.Winsock Accept 
  33.       Index           =   0
  34.       Left            =   240
  35.       Top             =   600
  36.       _ExtentX        =   741
  37.       _ExtentY        =   741
  38.       _Version        =   393216
  39.    End
  40.    Begin MSWinsockLib.Winsock Listen 
  41.       Left            =   720
  42.       Top             =   600
  43.       _ExtentX        =   741
  44.       _ExtentY        =   741
  45.       _Version        =   393216
  46.    End
  47.    Begin VB.Label Label2 
  48.       BackStyle       =   0  'Transparent
  49.       BeginProperty Font 
  50.          Name            =   "Arial"
  51.          Size            =   8.25
  52.          Charset         =   0
  53.          Weight          =   700
  54.          Underline       =   0   'False
  55.          Italic          =   0   'False
  56.          Strikethrough   =   0   'False
  57.       EndProperty
  58.       ForeColor       =   &H00FFFF00&
  59.       Height          =   255
  60.       Left            =   120
  61.       TabIndex        =   2
  62.       Top             =   1440
  63.       Width           =   1095
  64.    End
  65.    Begin VB.Label Label1 
  66.       BackStyle       =   0  'Transparent
  67.       Caption         =   "Server Active"
  68.       BeginProperty Font 
  69.          Name            =   "Arial"
  70.          Size            =   8.25
  71.          Charset         =   0
  72.          Weight          =   700
  73.          Underline       =   0   'False
  74.          Italic          =   0   'False
  75.          Strikethrough   =   0   'False
  76.       EndProperty
  77.       ForeColor       =   &H00FFFF00&
  78.       Height          =   255
  79.       Left            =   120
  80.       TabIndex        =   1
  81.       Top             =   1200
  82.       Width           =   1215
  83.    End
  84. End
  85. Attribute VB_Name = "Form1"
  86. Attribute VB_GlobalNameSpace = False
  87. Attribute VB_Creatable = False
  88. Attribute VB_PredeclaredId = True
  89. Attribute VB_Exposed = False
  90. Dim UserInfo(1 To 25) As String
  91. Dim SocketStatus(1 To 25) As Integer
  92. Dim ReceivedInfo(1 To 25) As String
  93. Dim WordNo As Integer
  94. Dim theWords(0 To 2) As String
  95.  
  96. Sub SendtoAll(stuff As String)
  97. For a = 1 To 25
  98.  
  99. If SocketStatus(a) = 1 And UserInfo(a) <> "" Then
  100. Accept(a).SendData stuff
  101. DoEvents
  102.  
  103. End If
  104.         
  105.         
  106. Next a
  107. End Sub
  108.  
  109. Private Sub Accept_Close(Index As Integer)
  110. SocketStatus(Index) = 0
  111. UserInfo(Index) = ""
  112. Accept(Index).Close
  113. DoEvents
  114. End Sub
  115.  
  116. Private Sub Accept_DataArrival(Index As Integer, ByVal bytesTotal As Long)
  117. Dim tmp As String
  118. Dim tmp2 As String
  119.  
  120. Accept(Index).GetData tmp
  121. DoEvents
  122. Accept(Index).SendData tmp ' ECHOS WHAT IS WRITTEN
  123. DoEvents
  124.  
  125. If tmp = vbCrLf Or tmp = Chr$(13) Then
  126.  
  127. If UserInfo(Index) = "" Then
  128.  
  129. z = 10
  130.  
  131. If Len(ReceivedInfo(Index)) < z Then z = Len(ReceivedInfo(Index))
  132.  
  133. tmp2 = Trim(Mid$(ReceivedInfo(Index), 1, z))
  134. tmp2 = Replace(tmp2, " ", "")
  135.  
  136.      
  137.     tmp3$ = Trim(ReceivedInfo(Index))
  138.     
  139.     For y = 1 To 25
  140.     If UCase$(tmp3$) = UCase$(UserInfo(y)) Then
  141.     Accept(Index).SendData vbCrLf + "This name is already in use." + vbCrLf + "Please enter another: " + vbCrLf
  142.     DoEvents
  143.     ReceivedInfo(Index) = ""
  144.     GoTo skippy
  145.     End If
  146.     Next y
  147.  
  148.     Call SendtoAll(vbCrLf + "Screen Name: " + tmp2 + " has joined the conversation" + vbCrLf)
  149.     
  150.     UserInfo(Index) = tmp2
  151.     
  152.     Accept(Index).SendData vbCrLf + "Welcome to the conversation." + vbCrLf + "Your screen name is: " + tmp2 + vbCrLf
  153.     DoEvents
  154.     
  155.     Call UserLIST(Index)
  156.      
  157.     
  158. ReceivedInfo(Index) = ""
  159.         
  160.         Else
  161.  
  162. '==========EXTRA CHAT COMMANDS. USERLISTING, DESCRIPTIONS, ETC, ETC, ET============
  163. '==========COULD ALSO INCLUDE SERVER COMMANDS FOR DATA TRANSFER AND THE LIKE=======
  164.  
  165.  
  166. Select Case UCase$(ReceivedInfo(Index))
  167.  
  168. Case "/USERS"
  169.  
  170. Call UserLIST(Index)
  171.  
  172. Case "/QUIT"
  173.  
  174. Call QUITCHAT(Index)
  175.  
  176.  
  177. Case Else
  178.  
  179. If Mid$(Trim(UCase$(ReceivedInfo(Index))), 1, 8) = "/PRIVATE" Then Call PrivateMessage(Index, ReceivedInfo(Index)): GoTo skippy
  180.  
  181.  
  182. Call SendtoAll(vbCrLf + UserInfo(Index) + ": " + ReceivedInfo(Index) + vbCrLf)
  183.  
  184. skippy:
  185.  
  186. End Select
  187.  
  188.  
  189.  
  190. '==================================================================================
  191.  
  192.  
  193. ReceivedInfo(Index) = ""
  194.  
  195. End If
  196.  
  197. Else
  198.  
  199. ReceivedInfo(Index) = ReceivedInfo(Index) + tmp
  200.  
  201. End If
  202.  
  203.  
  204. End Sub
  205.  
  206. Sub PrivateMessage(ff As Integer, info As String)
  207.  
  208. Call WordCount(info)
  209.  
  210. If WordNo < 2 Then Accept(ff).SendData vbCrLf + "Syntax Error: /PRIVATE <SCREEN NAME> <MESSAGE>" + vbCrLf: DoEvents: GoTo skip
  211.  
  212. For i = 1 To 25
  213. If UCase$(theWords(1)) = UCase$(UserInfo(i)) Then
  214. Accept(i).SendData vbCrLf + "[Prv.Msg] " + UserInfo(i) + ": " + theWords(2) + vbCrLf
  215. DoEvents
  216. GoTo skip
  217. Else
  218. End If
  219. Next i
  220. Accept(ff).SendData vbCrLf + "Data Error: User specified does not exist" + vbCrLf
  221. DoEvents
  222.  
  223. skip:
  224. End Sub
  225. Private Sub Accept_Error(Index As Integer, ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
  226.  
  227. SocketStatus(Index) = 0
  228. UserInfo(Index) = ""
  229. Accept(Index).Close
  230. DoEvents
  231. End Sub
  232.  
  233. Sub QUITCHAT(x As Integer)
  234.  
  235. Accept(x).SendData vbCrLf + "Good-bye " + UserInfo(x) + vbCrLf
  236. DoEvents
  237. SocketStatus(x) = 0
  238. SendtoAll (vbCrLf + "Screen name: " + UserInfo(x) + " has left." + vbCrLf)
  239. Accept(x).Close
  240. DoEvents
  241. End Sub
  242.  
  243. Sub UserLIST(x As Integer)
  244. Accept(x).SendData vbCrLf + "Participating characters:" + vbCrLf
  245.     DoEvents
  246.     
  247.     For a = 1 To 25
  248.  
  249.         If SocketStatus(a) = 1 Then
  250.         Accept(x).SendData UserInfo(a) + vbCrLf
  251.         DoEvents
  252.         End If
  253.     Next a
  254. End Sub
  255.  
  256. Private Sub Form_Load()
  257. Dim Port As Integer
  258. '===COMMAND LINE PORTION==============================
  259. 'DarkWindow.exe <Port>
  260. If Command$ = "" Then Port = 33: GoTo 20
  261. Call WordCount(Command$)
  262. If WordNo > 0 And Int(theWords(0)) > 0 Then Port = Int(theWords(0)) Else Port = 33
  263. 20
  264.  
  265. Anim.Open CurDir$ + "\smile.avi" 'Change this in development environment or it can't find file
  266. Anim.AutoPlay = True
  267.  
  268. '========================================================
  269.  
  270. '==LOAD LISTENING WINSOCK and load ACCEPTING ARRAY=======
  271. For a = 1 To 25
  272. Load Accept(a)
  273. Next a
  274.  
  275. Label2.Caption = "PORT:" + Str$(Port)
  276. Listen.LocalPort = Port
  277. Listen.Listen
  278. '========================================================
  279.  
  280.  
  281.  
  282. End Sub
  283.  
  284. Private Sub Form_Unload(Cancel As Integer)
  285. Close
  286. End Sub
  287.  
  288. Private Sub Listen_ConnectionRequest(ByVal requestID As Long)
  289. Dim UseSocket As Integer
  290.  
  291. For a = 1 To 25
  292. If SocketStatus(a) = 0 Then UseSocket = a: SocketStatus(a) = 1: GoTo Accepting
  293. Next a
  294. Listen.Close
  295. DoEvents
  296. Listen.Listen
  297. DoEvents
  298. GoTo 30
  299.  
  300. Accepting:
  301.  
  302. Accept(UseSocket).Accept requestID
  303. DoEvents
  304. Accept(UseSocket).SendData vbCrLf + "Welcome to Black Window v0.1 BETA" + vbCrLf
  305. DoEvents
  306. Accept(UseSocket).SendData "Emulation supported: ASCII" + vbCrLf
  307. DoEvents
  308. Accept(UseSocket).SendData "Please enter your desired nickname" + vbCrLf + "(No more than 10 characters): "
  309. DoEvents
  310. 30
  311.  
  312. End Sub
  313.  
  314. Sub WordCount(text As String)
  315.  
  316. Dim count As Integer
  317. Dim keepsafe(0 To 2) As String
  318. count = 0
  319. WordNo = 0
  320. spacecount = 0
  321. For a = 0 To 2
  322. theWords(a) = ""
  323. Next a
  324. If Trim(text) = "" Then GoTo 10
  325.  
  326.  
  327. message = Trim(text)
  328.  
  329. For a = 1 To Len(message)
  330.  
  331. If Mid$(message, a, 1) = " " Then spacecount = spacecount + 1: GoTo SkipALL
  332. If count = 2 Then theWords(2) = Mid$(message, a - 1, (Len(message) - a + 2)): GoTo BreakLoop
  333. If Mid$(message, a, 1) <> " " And spacecount > 0 Then count = count + 1: spacecount = 0
  334.  
  335. theWords(count) = theWords(count) + Mid$(message, a, 1)
  336.  
  337. SkipALL:
  338.  
  339. Next a
  340. BreakLoop:
  341. WordNo = count + 1
  342.  
  343. 10
  344. End Sub
  345.  
  346.