1,451
社区成员
发帖
与我相关
我的任务
分享如何突破winsock控件的瓶颈??
我在做的一个网络协议,使用到winsock控件,但是在支持多人连接的时候,就不行了,出现错误,说缓冲区溢出,没办法,特向各位求教>>
...全文
请发表友善的回复…
发表回复
守城小轩 2002-10-05
- 打赏
- 举报
up
xfyxq 2002-10-05
- 打赏
- 举报
呵
xfyxq@163.net
xfyxq@163.net
bcpl 2002-09-29
- 打赏
- 举报
用powertcp的winsock组件，支持多线程，使用也比较方便
拿棵草 2002-09-29
- 打赏
- 举报
高手！好代码，珍藏起来。
MarGo 2002-09-29
- 打赏
- 举报
第二部分：
Private Function RetrieveUser(UserName As String) As Integer
Dim X As Integer
'Check to see if nothing was selected
If UserName = "" Then
'OK, nothing selected, let's see how full
' the list is!
If lstUsers.ListCount = 0 Then
'Nothing in the list, so return -1
RetrieveUser = -1
Exit Function
End If
'If there is something in the list, send it to
' the first one =)
UserName = lstUsers.List(0)
End If
' Count through the users
For X = 0 To 100
'Check username to see if it is the right one
If Users(X) = UserName Then
'Ok, this is our man, so let's return his
' winsock index
RetrieveUser = X
Exit Function
End If
Next X
RetrieveUser = -1
End Function
Private Sub txtSendMessage_KeyPress(KeyAscii As Integer)
'Let's get rid of the annoying beep =)
If KeyAscii = 13 Then KeyAscii = 0
End Sub
Private Sub wsArray_Close(Index As Integer)
' Let's cycle through the list, looking for their
' name
For X = 0 To lstUsers.ListCount - 1
' Check to see if it matches
If lstUsers.List(X) = Users(Index) Then
' It matches, so let's remove it form the
' list and the array
Users(Index) = ""
lstUsers.RemoveItem X
Exit For
End If
Next X
End Sub
Private Sub wsArray_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim Data As String, CtrlChar As String
wsArray(Index).GetData Data
' Our format for our messages is this:
' CtrlChar & chr(1) & <info>
If InStr(1, Data, Chr(1)) <> 2 Then
' If the 2nd char isn't chr(1), we know we have a prob
MsgBox "Unknown Data Format: " & vbCrLf & _
Data, vbCritical, "Error receiving"
' Make sure to leave the sub so it doesn't
' try to process the invalid info!
Exit Sub
End If
'Retrieve First Character
CtrlChar = Left(Data, 1)
'Make sure to trim it, and chr(1), off
Data = Mid(Data, 3)
' Check what it is, without regard to case
Select Case LCase(CtrlChar)
'This is to display a msgbox.
' I didn't enable the ability on the clients --
' for obvious reasons ;)
Case "m"
MsgBox Data, vbInformation, "Msg from client"
'This is to change the caption.
' I didn't enable the ability on the clients --
' for obvious reasons ;)
Case "c"
Me.Caption = "Server - " & Data
'This is their "login" key
Case "u"
'Add their name to the list
lstUsers.AddItem Data
'Add their name to the array
Users(Index) = Data
' We need to remember that both
' the winsock index and the user array
' index correspond. So you can find a
' users name by going "Users(<winsock index>)"
' or you can find the winsock index with
' a text name by cycling through the array.
' That's what the function "RetrieveUser"
' does - gets their winsock index from their
' username
' If all else fails, print it to output =)
Case Else
txtReceived.SelStart = Len(txtReceived.Text)
txtReceived.SelText = Data & vbCrLf
End Select
End Sub
Private Sub wsArray_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)
' This sets the "cursor" to the end of the textbox
txtErrors.SelStart = Len(txtErrors.Text)
' This inserts the error message at the "cursor"
txtErrors.SelText = "wsArray(" & Index & ") - " & Number & " - " & Description & vbCrLf
' Close it =)
wsArray(Index).Close
End Sub
Private Sub wsListen_ConnectionRequest(ByVal requestID As Long)
Index = FindOpenWinsock
' Accept the request using the created winsock
wsArray(Index).Accept requestID
End Sub
Private Sub wsListen_Error(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)
' This sets the "cursor" to the end of the textbox
txtErrors.SelStart = Len(txtErrors.Text)
' This inserts the error message at the "cursor"
txtErrors.SelText = "wsListen - " & Number & " - " & Description & vbCrLf
End Sub
Private Function FindOpenWinsock()
Static LocalPorts As Integer ' Static keeps the
' variable's state
For X = 0 To wsArray.UBound
If wsArray(X).State = 0 Then
' We found one that's state is 0, which
' means "closed", so let's use it
FindOpenWinsock = X
' make sure to leave function
Exit Function
End If
Next X
' OK, none are open so let's make one
Load wsArray(wsArray.UBound + 1)
' Let's make sure we don't get conflicting local ports
LocalPorts = LocalPorts + 1
wsArray(wsArray.UBound).LocalPort = wsArray(wsArray.UBound).LocalPort + LocalPorts
' and then let's return it's index value
FindOpenWinsock = wsArray.UBound
End Function
Private Function RetrieveUser(UserName As String) As Integer
Dim X As Integer
'Check to see if nothing was selected
If UserName = "" Then
'OK, nothing selected, let's see how full
' the list is!
If lstUsers.ListCount = 0 Then
'Nothing in the list, so return -1
RetrieveUser = -1
Exit Function
End If
'If there is something in the list, send it to
' the first one =)
UserName = lstUsers.List(0)
End If
' Count through the users
For X = 0 To 100
'Check username to see if it is the right one
If Users(X) = UserName Then
'Ok, this is our man, so let's return his
' winsock index
RetrieveUser = X
Exit Function
End If
Next X
RetrieveUser = -1
End Function
Private Sub txtSendMessage_KeyPress(KeyAscii As Integer)
'Let's get rid of the annoying beep =)
If KeyAscii = 13 Then KeyAscii = 0
End Sub
Private Sub wsArray_Close(Index As Integer)
' Let's cycle through the list, looking for their
' name
For X = 0 To lstUsers.ListCount - 1
' Check to see if it matches
If lstUsers.List(X) = Users(Index) Then
' It matches, so let's remove it form the
' list and the array
Users(Index) = ""
lstUsers.RemoveItem X
Exit For
End If
Next X
End Sub
Private Sub wsArray_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim Data As String, CtrlChar As String
wsArray(Index).GetData Data
' Our format for our messages is this:
' CtrlChar & chr(1) & <info>
If InStr(1, Data, Chr(1)) <> 2 Then
' If the 2nd char isn't chr(1), we know we have a prob
MsgBox "Unknown Data Format: " & vbCrLf & _
Data, vbCritical, "Error receiving"
' Make sure to leave the sub so it doesn't
' try to process the invalid info!
Exit Sub
End If
'Retrieve First Character
CtrlChar = Left(Data, 1)
'Make sure to trim it, and chr(1), off
Data = Mid(Data, 3)
' Check what it is, without regard to case
Select Case LCase(CtrlChar)
'This is to display a msgbox.
' I didn't enable the ability on the clients --
' for obvious reasons ;)
Case "m"
MsgBox Data, vbInformation, "Msg from client"
'This is to change the caption.
' I didn't enable the ability on the clients --
' for obvious reasons ;)
Case "c"
Me.Caption = "Server - " & Data
'This is their "login" key
Case "u"
'Add their name to the list
lstUsers.AddItem Data
'Add their name to the array
Users(Index) = Data
' We need to remember that both
' the winsock index and the user array
' index correspond. So you can find a
' users name by going "Users(<winsock index>)"
' or you can find the winsock index with
' a text name by cycling through the array.
' That's what the function "RetrieveUser"
' does - gets their winsock index from their
' username
' If all else fails, print it to output =)
Case Else
txtReceived.SelStart = Len(txtReceived.Text)
txtReceived.SelText = Data & vbCrLf
End Select
End Sub
Private Sub wsArray_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)
' This sets the "cursor" to the end of the textbox
txtErrors.SelStart = Len(txtErrors.Text)
' This inserts the error message at the "cursor"
txtErrors.SelText = "wsArray(" & Index & ") - " & Number & " - " & Description & vbCrLf
' Close it =)
wsArray(Index).Close
End Sub
Private Sub wsListen_ConnectionRequest(ByVal requestID As Long)
Index = FindOpenWinsock
' Accept the request using the created winsock
wsArray(Index).Accept requestID
End Sub
Private Sub wsListen_Error(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)
' This sets the "cursor" to the end of the textbox
txtErrors.SelStart = Len(txtErrors.Text)
' This inserts the error message at the "cursor"
txtErrors.SelText = "wsListen - " & Number & " - " & Description & vbCrLf
End Sub
Private Function FindOpenWinsock()
Static LocalPorts As Integer ' Static keeps the
' variable's state
For X = 0 To wsArray.UBound
If wsArray(X).State = 0 Then
' We found one that's state is 0, which
' means "closed", so let's use it
FindOpenWinsock = X
' make sure to leave function
Exit Function
End If
Next X
' OK, none are open so let's make one
Load wsArray(wsArray.UBound + 1)
' Let's make sure we don't get conflicting local ports
LocalPorts = LocalPorts + 1
wsArray(wsArray.UBound).LocalPort = wsArray(wsArray.UBound).LocalPort + LocalPorts
' and then let's return it's index value
FindOpenWinsock = wsArray.UBound
End Function
MarGo 2002-09-29
- 打赏
- 举报
看一下这个：
是服务器端的程序：
他是使用空间数组，但有个问题，当连接短开后不能很好的释放该空间：
' We'll limit it to 101 users at a time! ;)
Dim Users(0 To 100) As String
Private Sub cmdCaption_Click()
Dim User As Integer
' Get Username to send to
User = RetrieveUser(lstUsers.Text)
If User = -1 Then
MsgBox "Invalid User!", vbCritical, "Error"
Exit Sub
End If
wsArray(User).SendData "c" & Chr(1) & InputBox("What do you want to have their caption set to?", "Alter Caption", "Hi!")
End Sub
Private Sub cmdMsgBox_Click()
Dim User As Integer
' Get Username to send to
User = RetrieveUser(lstUsers.Text)
If User = -1 Then
MsgBox "Invalid User!", vbCritical, "Error"
Exit Sub
End If
wsArray(RetrieveUser(lstUsers.Text)).SendData "m" & Chr(1) & InputBox("What do you want to have displayed on their machine?", "Popup MsgBox", "Hi!")
End Sub
Private Sub Form_Load()
wsListen.Listen ' make it listen
End Sub
Private Sub txtSendMessage_KeyDown(KeyCode As Integer, Shift As Integer)
Dim User As Integer
'First, check to make sure someone's logged in
If lstUsers.ListCount = 0 And KeyCode = 13 Then
'Display popup
MsgBox "Nobody to send to!", vbExclamation, "Cannot send"
'Clear input
txtSendMessage.Text = ""
Exit Sub
End If
' If it was enter and shift wasn't pressed, then...
If KeyCode = 13 And Shift = 0 Then
' Get Username to send to
User = RetrieveUser(lstUsers.Text)
' RetrieveUser returns -1 if the user wasn't found
If User = -1 Then
Exit Sub
End If
' format the message
wsArray(User).SendData "t" & Chr(1) & txtSendMessage.Text
' Blank the input
txtSendMessage.Text = ""
ElseIf KeyCode = 13 And Shift = 1 Then
' Loop through the users.
' There's better ways of doing this
For X = 0 To 100
' If there's a username listed for them
If Users(X) <> "" Then
'Send the message
wsArray(X).SendData "t" & Chr(1) & txtSendMessage.Text
' Don't know why this needs to be
' in here to work - someone tell me?
DoEvents
End If
Next X
txtSendMessage.Text = ""
End If
End Sub
是服务器端的程序：
他是使用空间数组，但有个问题，当连接短开后不能很好的释放该空间：
' We'll limit it to 101 users at a time! ;)
Dim Users(0 To 100) As String
Private Sub cmdCaption_Click()
Dim User As Integer
' Get Username to send to
User = RetrieveUser(lstUsers.Text)
If User = -1 Then
MsgBox "Invalid User!", vbCritical, "Error"
Exit Sub
End If
wsArray(User).SendData "c" & Chr(1) & InputBox("What do you want to have their caption set to?", "Alter Caption", "Hi!")
End Sub
Private Sub cmdMsgBox_Click()
Dim User As Integer
' Get Username to send to
User = RetrieveUser(lstUsers.Text)
If User = -1 Then
MsgBox "Invalid User!", vbCritical, "Error"
Exit Sub
End If
wsArray(RetrieveUser(lstUsers.Text)).SendData "m" & Chr(1) & InputBox("What do you want to have displayed on their machine?", "Popup MsgBox", "Hi!")
End Sub
Private Sub Form_Load()
wsListen.Listen ' make it listen
End Sub
Private Sub txtSendMessage_KeyDown(KeyCode As Integer, Shift As Integer)
Dim User As Integer
'First, check to make sure someone's logged in
If lstUsers.ListCount = 0 And KeyCode = 13 Then
'Display popup
MsgBox "Nobody to send to!", vbExclamation, "Cannot send"
'Clear input
txtSendMessage.Text = ""
Exit Sub
End If
' If it was enter and shift wasn't pressed, then...
If KeyCode = 13 And Shift = 0 Then
' Get Username to send to
User = RetrieveUser(lstUsers.Text)
' RetrieveUser returns -1 if the user wasn't found
If User = -1 Then
Exit Sub
End If
' format the message
wsArray(User).SendData "t" & Chr(1) & txtSendMessage.Text
' Blank the input
txtSendMessage.Text = ""
ElseIf KeyCode = 13 And Shift = 1 Then
' Loop through the users.
' There's better ways of doing this
For X = 0 To 100
' If there's a username listed for them
If Users(X) <> "" Then
'Send the message
wsArray(X).SendData "t" & Chr(1) & txtSendMessage.Text
' Don't know why this needs to be
' in here to work - someone tell me?
DoEvents
End If
Next X
txtSendMessage.Text = ""
End If
End Sub
PM0115 2002-09-29
- 打赏
- 举报
我也要一份，非常感谢！pm-kgb@163.net
trytryba 2002-09-29
- 打赏
- 举报
我要一份，谢谢，mazibin@163.com
win98ddk 2002-09-29
- 打赏
- 举报
各位老大,我一开始没有讲清楚,我的程序主要是实现socks5代理的(就是QQ用的那一个了),我确实使用了控件数组,可以动态的加载卸载,但是载测试的时候,发现同时有140个连接的时候(有时80多个就不行了),就会出现缓冲区不足的现象,跑出来一个"运行时错误"的信息.现在我的做法是出错之后,就将所有的winsock()关闭,重新等待连接.这样真的是无奈得很呀...................
各位老大有什么新的见解给我吗??
等我写好这个socks5模块后我想把它公开,需要的赶快报名!!
各位老大有什么新的见解给我吗??
等我写好这个socks5模块后我想把它公开,需要的赶快报名!!
dyshadow 2002-09-27
- 打赏
- 举报
以下是我写的基于TELNET的聊天程序：
Dim intUserNum As Integer
Private Type UserInfo
UserName As String
UserWords As String
UserWordsByte As String
End Type
Dim aryUser(32767) As UserInfo
Private Sub Form_Load()
sckListen.LocalPort = 23
sckListen.Listen
Show
lstMain.AddItem sckListen.LocalIP
End Sub
Private Sub sckListen_ConnectionRequest(ByVal requestID As Long)
intUserNum = intUserNum + 1
Load sckServer(intUserNum)
sckServer(intUserNum).Accept requestID
sckServer(intUserNum).SendData "CHEATING TOOL VER 1.0 Beta" & vbCrLf & "输入文字，按下回车后文字就被显示给在线用户。如果您的文字在输入时被其他人的信息打搅，请重新输入一边。这是TELNET的缺陷，不是本程序的漏洞！输入文字时，注意不要用“退格键”（BACKSPACE）！" & vbCrLf & vbCrLf & "请输入您的姓名（昵称）！这将成为您话语的标识。" & vbCrLf & ":>"
End Sub
Private Sub sckServer_Close(Index As Integer)
With aryUser(Index)
.UserName = ""
.UserWords = ""
.UserWordsByte = ""
End With
End Sub
Private Sub sckServer_DataArrival(Index As Integer, ByVal bytesTotal As Long)
On Error Resume Next
sckServer(Index).GetData aryUser(Index).UserWordsByte
sckServer(Index).SendData aryUser(Index).UserWordsByte
aryUser(Index).UserWords = aryUser(Index).UserWords & aryUser(Index).UserWordsByte
If InStr(aryUser(Index).UserWords, vbCrLf) = 0 Then Exit Sub
aryUser(Index).UserWords = Replace(aryUser(Index).UserWords, vbCrLf, "")
If Trim(aryUser(Index).UserName) = "" Then
For i = 1 To intUserNum
If Trim(aryUser(i).UserName) = Trim(aryUser(Index).UserWords) Then
sckServer(Index).SendData "您的昵称已被使用，请换一个！" & vbCrLf & ":>"
aryUser(Index).UserWords = ""
Exit Sub
End If
Next
aryUser(Index).UserName = aryUser(Index).UserWords
sckServer(Index).SendData "收到！输入文字吧！" & vbCrLf & ":>"
aryUser(Index).UserWords = ""
Else
For i = 1 To intUserNum
If Trim(aryUser(i).UserName) = Trim(aryUser(Index).UserName) Then
sckServer(i).SendData "你说：" & aryUser(Index).UserWords & vbCrLf & ":>"
Else
With aryUser(Index)
sckServer(i).SendData vbCrLf & .UserName & " 说：" & .UserWords & vbCrLf & ":>"
lstMain.AddItem .UserName & .UserWords
lstMain.ListIndex = lstMain.ListCount - 1
End With
End If
DoEvents
Next
For i = 1 To intUserNum
aryUser(Index).UserWords = ""
Next
End If
End Sub
Dim intUserNum As Integer
Private Type UserInfo
UserName As String
UserWords As String
UserWordsByte As String
End Type
Dim aryUser(32767) As UserInfo
Private Sub Form_Load()
sckListen.LocalPort = 23
sckListen.Listen
Show
lstMain.AddItem sckListen.LocalIP
End Sub
Private Sub sckListen_ConnectionRequest(ByVal requestID As Long)
intUserNum = intUserNum + 1
Load sckServer(intUserNum)
sckServer(intUserNum).Accept requestID
sckServer(intUserNum).SendData "CHEATING TOOL VER 1.0 Beta" & vbCrLf & "输入文字，按下回车后文字就被显示给在线用户。如果您的文字在输入时被其他人的信息打搅，请重新输入一边。这是TELNET的缺陷，不是本程序的漏洞！输入文字时，注意不要用“退格键”（BACKSPACE）！" & vbCrLf & vbCrLf & "请输入您的姓名（昵称）！这将成为您话语的标识。" & vbCrLf & ":>"
End Sub
Private Sub sckServer_Close(Index As Integer)
With aryUser(Index)
.UserName = ""
.UserWords = ""
.UserWordsByte = ""
End With
End Sub
Private Sub sckServer_DataArrival(Index As Integer, ByVal bytesTotal As Long)
On Error Resume Next
sckServer(Index).GetData aryUser(Index).UserWordsByte
sckServer(Index).SendData aryUser(Index).UserWordsByte
aryUser(Index).UserWords = aryUser(Index).UserWords & aryUser(Index).UserWordsByte
If InStr(aryUser(Index).UserWords, vbCrLf) = 0 Then Exit Sub
aryUser(Index).UserWords = Replace(aryUser(Index).UserWords, vbCrLf, "")
If Trim(aryUser(Index).UserName) = "" Then
For i = 1 To intUserNum
If Trim(aryUser(i).UserName) = Trim(aryUser(Index).UserWords) Then
sckServer(Index).SendData "您的昵称已被使用，请换一个！" & vbCrLf & ":>"
aryUser(Index).UserWords = ""
Exit Sub
End If
Next
aryUser(Index).UserName = aryUser(Index).UserWords
sckServer(Index).SendData "收到！输入文字吧！" & vbCrLf & ":>"
aryUser(Index).UserWords = ""
Else
For i = 1 To intUserNum
If Trim(aryUser(i).UserName) = Trim(aryUser(Index).UserName) Then
sckServer(i).SendData "你说：" & aryUser(Index).UserWords & vbCrLf & ":>"
Else
With aryUser(Index)
sckServer(i).SendData vbCrLf & .UserName & " 说：" & .UserWords & vbCrLf & ":>"
lstMain.AddItem .UserName & .UserWords
lstMain.ListIndex = lstMain.ListCount - 1
End With
End If
DoEvents
Next
For i = 1 To intUserNum
aryUser(Index).UserWords = ""
Next
End If
End Sub
lionqun 2002-09-27
- 打赏
- 举报
先建一个winsockclient(0)
然后，在创建一个winsockserver专门用于监听
有AcceptRequest的时候就
currentnumber=currentnumber+1
Load winsockclient(currentnumber)
winsockclient(currentnumber).accept requestID
就可以建立多重连接了！
然后，在创建一个winsockserver专门用于监听
有AcceptRequest的时候就
currentnumber=currentnumber+1
Load winsockclient(currentnumber)
winsockclient(currentnumber).accept requestID
就可以建立多重连接了！
chllhc 2002-09-27
- 打赏
- 举报
用数组，我测试过支持21路并发
KaKaMo 2002-09-27
- 打赏
- 举报
当然要用控件数组了。
================================================================
================================================================
jisheng 2002-09-27
- 打赏
- 举报
咦，控件数组倒是一个好注意～～
mingqing 2002-09-27
- 打赏
- 举报
我也正在做这个项目，想了5天都没有解决
我是准备一个局域网中编写一个聊天程序，
我是在服务器和客户机上都只用了两个winsock，一个用来接收，一个用来
发送，
一个客户机向另一个客户机发送时，需经服务器中转（所有信息传送都要经服务器中转）
问题1
就出在当服务器向所有客户机发送同一消息时，要长时间占用用于发送
的winsock。（因为winsock只有在结束一个过程时，才向对方发送信息，这样就只有通过定时器，而定时器最快也要50ms才触发一次事件）
想来想去，我就想在服务器上增加一个专门用来向所有客户机发送消息的
winsock，而原来的发送winsock只用来发送客户机对客户机程序
另外，在服务器程序里建两个队列，一个队列存放客户机对客户机的消息
另一个存放客户机对所有客户机的消息
我是准备一个局域网中编写一个聊天程序，
我是在服务器和客户机上都只用了两个winsock，一个用来接收，一个用来
发送，
一个客户机向另一个客户机发送时，需经服务器中转（所有信息传送都要经服务器中转）
问题1
就出在当服务器向所有客户机发送同一消息时，要长时间占用用于发送
的winsock。（因为winsock只有在结束一个过程时，才向对方发送信息，这样就只有通过定时器，而定时器最快也要50ms才触发一次事件）
想来想去，我就想在服务器上增加一个专门用来向所有客户机发送消息的
winsock，而原来的发送winsock只用来发送客户机对客户机程序
另外，在服务器程序里建两个队列，一个队列存放客户机对客户机的消息
另一个存放客户机对所有客户机的消息
goujianling 2002-09-27
- 打赏
- 举报
winsock控件数组
jisheng 2002-09-27
- 打赏
- 举报
关注
antshome 2002-09-27
- 打赏
- 举报
使用winsock控件数组,一对一处理
