VB6 winsock server and multiple arduino clients issue - vb6

Right now i am developing a tool that will allow me to measure the delay between network connections using VB6 and a arduino UNO with ethernet shield.
Now i am facing some issues with the Server code (the VB6 program).
I have 2 winsocks with both different ports and they are both listening for the arduino client to connect. Now if i have only one active connection nothing goes wrong and everything works fine, but as soon as the second client connects the entire server starts going crazy. Suddenly it reports that the first client that connected lost it connection, so in short the server just doesn't want 2 clients connected at a time but i really do need it :/ What is going wrong?
I'll quickly explain what sertain command do that are send over the winsock to or from the server.
"SERVER_SLEEP" Is a command that the server sends to all clients that will tell them to enter a power saving mode.
"SERVER_REQUESTS_DATA" Is a command that the server sends to a specific client and forces the client to send information like Device name and firmware version.
"RESPOND_MESSAGE" Is a command that the server sends to all clients and the client is forced to respond to see if we still have an connection.
"DEVICE_NAME=" Is a command that the client sends to the server when it just connects, It is required before we show that we have an connection by putting it into the listbox. (after the = comes the device name)
"DEVICE_NAME_REP=" Is a command that the client sends to the server when the server requests information about the client, the reason i have 2 of them is because i couldn't reuse the previous one since then it would become way to complicated. (after the = comes the device name)
"DEVICE_FIRMWARE=" Is a command that the client sends to the server when the server requests information about the client. (after the = comes the device firmware version)
"DEVICE_OK=" Is a command that the client sends to the server when the server requests an answer to check if we still have an connection. (after the = comes the device name)
"DEVICE_REBOOTING" Is a command that the client sends to the server when it goes out of sleep mode (it goes out of that mode when the server comes back online again after it was closed) After the client send that message it immediately closes the connection again and the device is forced to reboot to make sure nothing goes wrong.
My code:
Dim DeviceIP1 As String
Dim DeviceIP2 As String
Dim UpdateListStatus As Integer
Private Sub Command1_Click()
MsgBox Socket1.State
MsgBox Socket2.State
End Sub
Private Sub Command3_Click()
If Dir(App.Path & "\TH.exe") <> "" Then 'Traceroute Helper application i wrote before, Works 100% and is not relevant for the issue i am facing
Shell App.Path & "\TH.exe " & DeviceIP, vbNormalFocus
Else
MsgBox "Missing file!" & vbNewLine & "File TH.exe is required for the requested operation!", vbCritical + vbSystemModal, "Missing file"
End If
End Sub
Private Sub Form_Load()
Socket1.Listen
Socket2.Listen
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Dim msg As VbMsgBoxResult
msg = MsgBox("Are you sure you want to exit?" & vbNewLine & "All the clients will be put into sleep mode.", vbYesNo + vbQuestion + vbSystemModal, "Quit")
If msg = vbYes Then
Form3.Show
Cancel = True
Form1.Visible = False
Else
Cancel = True
End If
End Sub
Private Sub List1_Click()
On Error GoTo errhandler
Dim ClientFound As Boolean
DeviceIP = Mid(List1.Text, InStr(List1.Text, "-") + 1)
DeviceIP = LTrim(DeviceIP)
DeviceIPLabel.Caption = "Device IP: " & DeviceIP
Form2.Show
If Socket1.RemoteHostIP = DeviceIP Then
Socket1.SendData ("SERVER_REQUESTS_DATA")
ElseIf Socket2.RemoteHostIP = DeviceIP Then
Socket2.SendData ("SERVER_REQUESTS_DATA")
End If
Exit Sub
errhandler:
If Err.Number = 40006 Then
MsgBox "Socket error!" & vbNewLine & "The requested device might be offline.", vbCritical + vbSystemModal, "Socket error"
Unload Form2
End If
End Sub
Private Sub UpdateList_Timer()
On Error Resume Next
If List1.ListCount > 0 Then
If UpdateListStatus = 0 Then
TempList.Clear
Socket1.SendData ("RESPOND_MESSAGE")
Socket2.SendData ("RESPOND_MESSAGE")
UpdateListStatus = 1
UpdateList.Interval = 5000
ElseIf UpdateListStatus = 1 Then
List1.Clear
For x = 0 To TempList.ListCount
List1.AddItem (TempList.List(x))
Next x
For X2 = 0 To List1.ListCount
If List1.List(X2) = "" Then 'Check if we have any items that are nothing
List1.RemoveItem (X2)
End If
Next X2
Label1.Caption = "Connected clients: " & List1.ListCount
UpdateListStatus = 0
UpdateList.Interval = 10000
End If
End If
End Sub
Private Sub Socket1_DataArrival(ByVal bytesTotal As Long)
On Error Resume Next
Dim TempString As String
Dim TempString2 As String
Dim position As Integer
Socket1.GetData TempString, vbString
position = InStr(1, TempString, "DEVICE_NAME=")
If position > 0 Then 'It is a device name command from a client
TempString2 = Mid(TempString, InStr(TempString, "=") + 1)
List1.AddItem (TempString2 + " - " + Socket1.RemoteHostIP)
Label1.Caption = "Connected clients: " & List1.ListCount
TempString2 = ""
End If
position = 0
position = InStr(1, TempString, "DEVICE_NAME_REP=")
If position > 0 Then 'It is a device name command from a client
TempString2 = Mid(TempString, InStr(TempString, "=") + 1)
DeviceNameLabel.Caption = "Device name: " & TempString2
TempString2 = ""
End If
position = 0
position = InStr(1, TempString, "DEVICE_FIRMWARE=")
If position > 0 Then 'It is a device firmware command from a client
TempString2 = Mid(TempString, InStr(TempString, "=") + 1)
DeviceFirmwareLabel.Caption = "Firmware version: " & TempString2
Unload Form2 'Since this is the last piece we will be receiving we can close this window
TempString2 = ""
End If
position = 0
position = InStr(1, TempString, "DEVICE_OK=")
If position > 0 Then 'It is a device respond command from a client
TempString2 = Mid(TempString, InStr(TempString, "=") + 1)
TempList.AddItem (TempString2 + " - " + Socket1.RemoteHostIP)
Label1.Caption = "Connected clients: " & List1.ListCount
TempString2 = ""
End If
position = 0
position = InStr(1, TempString, "DEVICE_REBOOTING")
If position > 0 Then 'It is a device respond command from a client
Socket1.Close
TempString2 = ""
End If
Text1.Text = Text1.Text & TempString & vbNewLine
TempString = ""
position = 0
TempString2 = ""
End Sub
Private Sub Socket2_DataArrival(ByVal bytesTotal As Long)
On Error Resume Next
Dim TempString As String
Dim TempString2 As String
Dim position As Integer
Socket2.GetData TempString, vbString
position = InStr(1, TempString, "DEVICE_NAME=")
If position > 0 Then 'It is a device name command from a client
TempString2 = Mid(TempString, InStr(TempString, "=") + 1)
List1.AddItem (TempString2 + " - " + Socket2.RemoteHostIP)
Label1.Caption = "Connected clients: " & List1.ListCount
TempString2 = ""
End If
position = 0
position = InStr(1, TempString, "DEVICE_NAME_REP=")
If position > 0 Then 'It is a device name command from a client
TempString2 = Mid(TempString, InStr(TempString, "=") + 1)
DeviceNameLabel.Caption = "Device name: " & TempString2
TempString2 = ""
End If
position = 0
position = InStr(1, TempString, "DEVICE_FIRMWARE=")
If position > 0 Then 'It is a device firmware command from a client
TempString2 = Mid(TempString, InStr(TempString, "=") + 1)
DeviceFirmwareLabel.Caption = "Firmware version: " & TempString2
Unload Form2 'Since this is the last piece we will be receiving we can close this window
TempString2 = ""
End If
position = 0
position = InStr(1, TempString, "DEVICE_OK=")
If position > 0 Then 'It is a device respond command from a client
TempString2 = Mid(TempString, InStr(TempString, "=") + 1)
TempList.AddItem (TempString2 + " - " + Socket2.RemoteHostIP)
Label1.Caption = "Connected clients: " & List1.ListCount
TempString2 = ""
End If
position = 0
position = InStr(1, TempString, "DEVICE_REBOOTING")
If position > 0 Then 'It is a device respond command from a client
Socket2.Close
TempString2 = ""
End If
Text1.Text = Text1.Text & TempString & vbNewLine
TempString = ""
position = 0
TempString2 = ""
End Sub
Private Sub Socket1_ConnectionRequest(ByVal requestID As Long)
If Socket1.State <> sckClosed Then
Socket1.Close
' Accept the request with the requestID
' parameter.
Socket1.Accept requestID
End If
End Sub
Private Sub Socket2_ConnectionRequest(ByVal requestID As Long)
If Socket2.State <> sckClosed Then
Socket2.Close
Socket2.Accept requestID 'Allow the connection
End If
End Sub
`

There's a lot there to dig through (You probably want to try to create a MCVE of the problem just to make your own debugging easier), but at first glance those ConnectionRequest event handlers seem suspect to me. The Winsock Control ConnectionRequest Event documentation says to "Use the Accept method (on a new control instance) to accept an incoming connection." You're trying to somehow use the same control instance, which maybe there's a way to do but isn't the standard approach.
If memory serves (it's been forever since I've dealt with this), you want to create a Control Array of Winsock Controls, and load a new instance at run time to handle each new connection (and unload it when the connection is complete). The "listening" control and the "handling a current connection" control need to be different instances. That way, each instance handles its own connection with its own state, and the listener is available to handle any new incoming connections.

Okay so i was able to find a very good example code for a multi-client server
And also i was able to figure out that the time out delay i created was WAY too short so that was why it was disappearing from the list. Sometimes it takes 10 seconds to receive a response and the time out was set to only 5 seconds MAX.
But still thanks for trying to help me :)
The link to the example code :LINK

Related

vb6 multiplayer server using playit.gg kindly assist

I am new to this. am not sure if anybody used game ranger before and I am trying to create something more simple.
client and server connection, the client connects to the server pc over the internet using the
playit.gg provided ip:port and it connects ok.
now I wonder if there is anything else needed for the game to detect other ips in-game multiplayer screen?.
I have a multi-connection server and IP vb6 source. simple using Winsock.
were you see the server:port is inputted from
.RemoteHost = "write-mechanical.at.playit.gg"
.RemotePort = "55224"
chat client side to connect
Option Explicit
Private Sub cmdConnect_Click()
'Check input.
txtServer.Text = Trim$(txtServer.Text)
txtPort.Text = Trim$(txtPort.Text)
txtNickname.Text = Trim$(txtNickname.Text)
If Len(txtServer.Text) = 0 Or Len(txtPort.Text) = 0 Or _
Len(txtNickname.Text) = 0 Then
MsgBox "Please fill in all fields!", vbCritical
Exit Sub
ElseIf Not IsNumeric(txtPort.Text) Then
MsgBox "Invalid port value!", vbCritical
Exit Sub
End If
'Done with that...
strMyNickname = txtNickname.Text
With frmChat.sckClient
.Close
bolRecon = False
.RemoteHost = txtServer.Text
.RemotePort = txtPort.Text
.Connect
End With
Me.Hide
frmChat.Show
AddStatusMessage frmChat.rtbChat, RGB(128, 128, 128), "> Connecting to " & txtServer.Text & ":" & txtPort.Text & "..."
End Sub
Private Sub txtPort_KeyPress(KeyAscii As Integer)
'Number only.
If Not IsNumeric(Chr$(KeyAscii)) And Not KeyAscii = 8 Then KeyAscii = 0
End Sub
and server-side to accept
With frmChat
.sckServer(0).Close
.sckServer(0).LocalPort = CInt(txtPort.Text)
.sckServer(0).Listen 'Opens the winsock control.
End With
Dim strNotify
Dim strPacket As String
Option Explicit
'JUST USED FOR FORM RESIZING.
Private Type RECT
rctLeft As Long
rctTop As Long
rctRight As Long
rctBottom As Long
End Type
'JUST USED FOR FORM RESIZING.
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
'JUST USED FOR FORM RESIZING.
Private udtMyRect As RECT
Private Sub sckServer_Close(Index As Integer)
sckServer(Index).Close
Dim strPacket As String
strPacket = "LEA" & Chr$(2) & udtUsers(Index).strNickname & Chr$(4)
SendGlobalData strPacket
AddUserEntersLeaves rtbChat, udtUsers(Index).strNickname, False
RemoveListItem lstUsers, udtUsers(Index).strNickname
With udtUsers(Index)
.strBuffer = vbNullString
.strIP = vbNullString
.strNickname = vbNullString
End With
End Sub
'A client is attempting to connect.
'----------------------------------
'Another computer is trying to connect to the server.
'Find a socket we can use to handle the connection.
'Then load a slot in the udtUsers() array for this user.
Private Sub sckServer_ConnectionRequest(Index As Integer, ByVal requestID As Long)
Dim intNext As Integer
intNext = ModChat.NextOpenSocket
If intNext > 0 Then
'Found a socket to use; accept connection.
sckServer(intNext).Accept requestID
'Check if there is a slot open for this connection
'in the users array.
If UBUsers < intNext Then
'There isn't, load one.
ReDim Preserve udtUsers(intNext) As CHAT_USER
End If
'(Re)set this client's info.
With udtUsers(intNext)
.strIP = sckServer(intNext).RemoteHostIP
.strNickname = vbNullString
End With
'We haven't received the user's nickname yet.
'That will happen in the DataArrival event :)
'Once it does, we will need to let everyone know that this person joined the room.
AddStatusMessage rtbChat, RGB(0, 0, 128), "> " & sckServer(intNext).RemoteHostIP & " connected!"
End If
End Sub
Private Sub sckServer_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim strData As String, strPackets() As String
Dim strTrunc As String, bolTrunc As Boolean
Dim lonLoop As Long, lonTruncStart As Long
Dim lonUB As Long
'Get the received data.
sckServer(Index).GetData strData, vbString, bytesTotal
With udtUsers(Index)
'Append it to the buffer.
.strBuffer = .strBuffer & strData
strData = vbNullString
'Check if the last byte is the packet delimiter (Chr$(4)).
'If it is, there are no truncated packets.
'If it isn't, the last packet got split up. >:(
If Right$(.strBuffer, 1) <> Chr$(4) Then
'Get all data to the right of the last Chr$(4) which is the truncated packet.
bolTrunc = True
'Find position of last packet delimiter.
lonTruncStart = InStrRev(.strBuffer, Chr$(4))
'Check if it was found.
If lonTruncStart > 0 Then
'Extract out the truncated part.
strTrunc = Mid$(.strBuffer, lonTruncStart + 1)
End If
End If
'We checked if the data was truncated.
'If it was, we put that part away for now and set the Truncated flag to TRUE (bolTrunc).
'Split up the data buffer into individual packets
'in case we received more than 1 at a time.
'Process them individually.
If InStr(1, .strBuffer, Chr$(4)) > 0 Then
strPackets() = Split(.strBuffer, Chr$(4))
'Now all of the individual packets are in strPackets().
'Loop through all of them.
lonUB = UBound(strPackets) 'Get number of packets.
'If the data is truncated, don't process the last one
'because it isn't complete.
If bolTrunc Then lonUB = lonUB - 1
'Start looping through all packets.
For lonLoop = 0 To lonUB
'Check length of packet.
'Each packet has a command/header,
'the packet must be at least that length.
'In this example, all headers are 3 bytes/characters long.
If Len(strPackets(lonLoop)) > 3 Then
'Look at the header and process the packet accordingly.
Select Case Left$(strPackets(lonLoop), 3)
'Packet is a chat message.
Case "MSG"
'Process message.
ParseChatMessage Index, strPackets(lonLoop)
'User is connecting (sending nickname).
Case "CON"
'Process connection.
ParseConnection Index, strPackets(lonLoop)
'Add your own here! :)
'Case "XXX"
'Do something.
'Case "YYY"
'Do something.
End Select
End If
Next lonLoop
End If
'We're done processing all packets.
Erase strPackets
'Now we can erase all the data we just processed from the buffer.
'Otherwise, it will just keep growing in size and the same data
'will be processed over and over (which might actually be kinda cool?).
.strBuffer = vbNullString
If bolTrunc Then
'Still have a piece of a packet left over because the data was truncated.
'Erase the buffer then put just the truncated part back in.
.strBuffer = strTrunc
End If
strTrunc = vbNullString
End With
End Sub
just a quote from my comment laying out what I want to do.
the server is in my computer running and they connect to me from
another house over the internet using the ip and port provided by
playitt.gg ok so now that i know they are connected to my machine via
the server app. now i want to know is will multiplayer games be able
to detect those ips even we got same game same version installed

Ping function makes the whole excel table slow/unresponsive

I have a function that pings computers from an excel list and gets the ping value of them.
While the script was running, the excel was completely unresponsive. I could fix this with DoEvents, this made it a bit more responsive.
However, the problem starts when the function gets to an offline computer. While it waits for the response of the offline PC, Excel freezes again and the script does not jump to the next PC until it gets the "timeout" from the actual one.
As the default ping timeout value is 4000ms, if I have 100 computers in my list, and 50 of them are turned off, that means I have to wait an extra 3,3 minutes for the script to finish, and also blocks the entire Excel, making it unusable for the duration.
My question is, if is there any way to make this faster or more responsive or smarter?
The actual code:
Function:
Function sPing(sHost) As String
Dim oPing As Object, oRetStatus As Object
Set oPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery _
("select * from Win32_PingStatus where address = '" & sHost & "'")
DoEvents
For Each oRetStatus In oPing
DoEvents
If IsNull(oRetStatus.StatusCode) Or oRetStatus.StatusCode <> 0 Then
sPing = "timeout" 'oRetStatus.StatusCode <- error code
Else
sPing = sPing & vbTab & oRetStatus.ResponseTime
End If
Next
End Function
Main:
Sub pingall_Click()
Dim c As Range
Dim p As String
Dim actives As String
actives = ActiveSheet.Name
StopCode = False
Application.EnableCancelKey = xlErrorHandler
On Error GoTo ErrH:
DoEvents
For Each c In Sheets(actives).UsedRange.Cells
If StopCode = True Then
Exit For
End If
DoEvents
If Left(c, 7) = "172.21." Then
p = sPing(c)
[...]
End If
Next c
End Sub
As already noted in the comments, to prevent this from blocking after each call, you need to invoke your pings asynchronously from your function. The way I would approach this would be to delegate your sPing(sHost) function to a VBScript that you create on the fly in a temp folder. The script would look something like this, and it takes the IP address as a command line argument and outputs the result to a file:
Dim args, ping, status
Set ping = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery _
("select * from Win32_PingStatus where address = '" & Wscript.Arguments(0) & "'")
Dim result
For Each status In ping
If IsNull(status.StatusCode) Or status.StatusCode <> 0 Then
result = "timeout"
Else
result = result & vbTab & status.ResponseTime
End If
Next
Dim fso, file
Set fso = CreateObject("Scripting.FileSystemObject")
Set file = fso.CreateTextFile(Wscript.Arguments(0), True)
file.Write result
file.Close
You can create a Sub to write this to a path something like this:
Private Sub WriteScript(path As String)
Dim handle As Integer
handle = FreeFile
Open path & ScriptName For Output As #handle
Print #handle, _
"Dim args, ping, status" & vbCrLf & _
"Set ping = GetObject(""winmgmts:{impersonationLevel=impersonate}"").ExecQuery _" & vbCrLf & _
" (""select * from Win32_PingStatus where address = '"" & Wscript.Arguments(0) & ""'"")" & vbCrLf & _
"Dim result" & vbCrLf & _
"For Each status In ping" & vbCrLf & _
" If IsNull(status.StatusCode) Or status.StatusCode <> 0 Then" & vbCrLf & _
" result = ""timeout""" & vbCrLf & _
" Else" & vbCrLf & _
" result = result & vbTab & status.ResponseTime" & vbCrLf & _
" End If" & vbCrLf & _
"Next" & vbCrLf & _
"Dim fso, file" & vbCrLf & _
"Set fso = CreateObject(""Scripting.FileSystemObject"")" & vbCrLf & _
"Set file = fso.CreateTextFile(Wscript.Arguments(0), True)" & vbCrLf & _
"file.Write result" & vbCrLf & _
"file.Close"
Close #handle
End Sub
After that, it's pretty straightforward - create a new directory in the user's temp directory, plop the script in there, and then use the Shell command to run each ping in its own process. Wait for the length of your timeout, then read the results from the files:
Private Const TempDir = "\PingResults\"
Private Const ScriptName As String = "ping.vbs"
'Important - set this to the time in seconds of your ping timeout.
Private Const Timeout = 4
Sub pingall_Click()
Dim sheet As Worksheet
Set sheet = ActiveSheet
Dim path As String
'Create a temp folder to use.
path = Environ("Temp") & TempDir
MkDir path
'Write your script to the temp folder.
WriteScript path
Dim results As Dictionary
Set results = New Dictionary
Dim index As Long
Dim ip As Variant
Dim command As String
For index = 1 To sheet.UsedRange.Rows.Count
ip = sheet.Cells(index, 1)
If Len(ip) >= 7 Then
If Left$(ip, 1) = "172.21." Then
'Cache the row it was in.
results.Add ip, index
'Shell the script.
command = "wscript " & path & "ping.vbs " & ip
Shell command, vbNormalFocus
End If
End If
Next index
Dim completed As Double
completed = Timer + Timeout
'Wait for the timeout.
Do While Timer < completed
DoEvents
Loop
Dim handle As String, ping As String, result As String
'Loop through the resulting files and update the sheet.
For Each ip In results.Keys
result = Dir$(path & ip)
If Len(result) <> 0 Then
handle = FreeFile
Open path & ip For Input As #handle
ping = Input$(LOF(handle), handle)
Close #handle
Kill path & ip
Else
ping = "timeout"
End If
sheet.Cells(results(ip), 2) = ping
Next ip
'Clean up.
Kill path & "*"
RmDir path
End Sub
Note that this has exactly zero error handling for the file operations, and doesn't respond to your StopCode flag. It should give the basic gist of it though. Also note that if you need to allow the user to cancel it, you won't be able to remove the temp directory because it will still be in use. If that is the case, only create it if it isn't already there and don't remove it when you're done.
You might be able to implement something like this, but I haven't tried it with multiple servers
if your network is fast you can reduce the timeout to 500 ms or less:
.
Public Function serverOk(ByVal dbSrvrNameStr As String) As Boolean
Const PINGS As Byte = 1
Const PING_TIME_OUT As Byte = 500
Const PING_LOCATION As String = "C:\Windows\System32\"
Dim commandResult As Long, serverIsActive As Boolean
commandResult = 1
serverIsActive = False
If Len(dbSrvrNameStr) > 0 Then
Err.Clear
With CreateObject("WScript.Shell")
commandResult = .Run("%comspec% /c " & PING_LOCATION & "ping.exe -n " & PINGS & " -w " & PING_TIME_OUT & " " & dbSrvrNameStr & " | find ""TTL="" > nul 2>&1", 0, True)
commandResult = .Run("%comspec% " & PING_LOCATION & "/c ping.exe -n " & PINGS & " -w " & PING_TIME_OUT & " " & dbSrvrNameStr, 0, True)
serverIsActive = (commandResult = 0)
End With
If serverIsActive And Err.Number = 0 Then
'"DB Server - valid, Ping response: " & commandResult
Else
'"Cannot connect to DB Server, Error: " & Err.Description & ", Ping response: " & commandResult
End If
Err.Clear
End If
serverOk = serverIsActive
End Function
.
Link to "Run Method (Windows Script Host)" from Microsoft:
https://msdn.microsoft.com/en-us/library/d5fk67ky(VS.85).aspx
The 3rd parameter of this command can be overlooked: "bWaitOnReturn" - allows you to execute it asynchronously from VBA

How to retrieve data from external device through Winsock to Microsoft Visual Basic (VB6)

I need to make an application that needs to retrieve data from an external terminal booking device to my application, with a telnet connection and show it on the txtOutput textbox.
I am pretty new in VB and used some time to learn the basics of the language.
First I created a Standard EXE project and added the Winsock control to the form.
I made a ping-request to the IP address I wanted to have connection too and it works.
Then I want to send a command to the external device. I want the booking-terminal to give me feedback to the txtOutput for me to read.
I made the connection and as much as I can see, I do send my messages to the terminal. But I don't get any responses from it! Nothing from it is viewed on my txtOutput.
How can that be?
Here is my code:
Dim IPAddress As String
Dim PortNum As Integer
Private Sub cmdConnect_Click()
Winsock.Close
Winsock.RemoteHost = txtIpaddress.Text
IPAddress = Winsock.RemoteHost
PortNum = CStr(txtPortnr.Text)
If (Val(PortNum) > 65535) Then
Winsock.RemotePort = (Val(PortNum) - 65535)
PortNum = Winsock.RemotePort
Else
Winsock.RemotePort = Val(PortNum)
PortNum = Winsock.RemotePort
End If
Winsock.Connect
Module1.send_to_buffer ("Attempting connection to: " & IPAddress & ":" & CStr(PortNum))
Call wsock_status
End Sub
Private Sub Winsock_Connect()
Module1.send_to_buffer ("Succeeded connection to: " & IPAddress & ":" & CStr(PortNum))
txtSend.SetFocus
End Sub
Private Sub cmdSend_Click()
Dim strSData As String
Dim message_to_send As String
If (Winsock.State = 0) Then
Module1.send_to_buffer ("You need to connect first!")
txtSend.Text = ""
Else
strSData = txtSend.Text
Winsock.SendData strSData & vbCrLf
message_to_send = txtSend.Text
If (message_to_send <> "") Then
Winsock.SendData message_to_send & vbCrLf
Module1.send_to_buffer_norm (txtSend.Text)
txtSend.Text = ""
txtSend.SetFocus
Else
Module1.send_to_buffer ("Nothing to send!")
txtSend.Text = ""
txtSend.SetFocus
End If
End If
End Sub
Private Sub terminalConnector_DataArrival(ByVal bytesTotal As Long)
Dim strData As String
Winsock.GetData strData
If (Len(txtOutput.Text) = 0) Then
txtOutput.Text = strData & vbCrLf
Else
txtOutput.Text = txtOutput.Text & strData & vbCrLf
End If
End Sub
Private Sub cmdDisconnect_Click()
Dim Counter As Long
If (Winsock.State <> 0) Then
Winsock.Close
Call wsock_status
Module1.send_to_buffer ("Connection to " & IPAddress & ":" & CStr(PortNum) & " closed.")
End If
End Sub
Private Sub Winsock_Close()
Module1.send_to_buffer ("Disconnected from: " & IPAddress & ":" & CStr(PortNum))
Winsock.Close
End Sub
and Module1 code:
Public Function send_to_buffer(text_to_display As String)
If (Len(terminalConnector.txtOutput.Text) = 0) Then
terminalConnector.txtOutput.Text = "*** " & text_to_display
Else
terminalConnector.txtOutput.Text = terminalConnector.txtOutput.Text & vbCrLf & "*** " & text_to_display & vbCrLf & vbCrLf
End If
End Function
Public Function send_to_buffer_norm(text_to_input As String)
If (Len(terminalConnector.txtOutput.Text) = 0) Then
terminalConnector.txtOutput.Text = "> " & text_to_input & vbCrLf
Else
terminalConnector.txtOutput.Text = terminalConnector.txtOutput.Text & "> " & text_to_input & vbCrLf
End If
End Function
Thanks in advance
The DataArrival event is named wrongly :
in your code it is :
Private Sub terminalConnector_DataArrival(ByVal bytesTotal As Long)
but it should be the name of your winsock control :
Private Sub Winsock_DataArrival(ByVal bytesTotal As Long)
You can always select the controlname in the combobox on the left above your code window in the IDE and then select the eventname in the combobox on the right above your code window in the IDE, which will put the outlines of the event code in your code window.
Or you can double-click the control on the design window in the IDE, which will bring you to the code window and put the outlines of an event code in your code window .. you can then select the event you want in the combobox on the right above your code window
A side comment : Winsock might is not the best name for a winsock control, it is best to give it a more unique same, which could be as simple as wskConnection or wskTerminal
When you download MZ-tools you can "Review Source Code" which will show you any procedures and variables that will not be called or used in your program ... this will often give an extra hint to misnamed variables or procedures
You Send routine is wrong :
Private Sub cmdSend_Click()
Dim strSData As String
txtSend.Text = strSData
Winsock.SendData strSData
End Sub
You are showing strSata in txtSend ... while strSData is still an empty string .. after that you send the empty string via the Winsock control
you probably meant :
Private Sub cmdSend_Click()
Dim strSData As String
strSData = txtSend.Text
Winsock.SendData strSData
End Sub
Which reads txtSend.Text into your string variable, and then sends that via the Winsock control
The server probably wants some special character at the end of your string, so dont forget to add that ... usually you have to add a cariage return :
strSData = strSData & vbCr

Recordset Operation is Not allowed when object is closed VBS

In the code bellow I get an error on the line reading recset.Close.
Char: 5
Error: Operation is not allowed when the object is closed.
Code: 800A0E78
Source: ADODB.Recordset
If the program reaches the line PQ_ID_number = InputBox("Enter PQ Database ID number, Do not use / ? < > \ : * | !", "PQ ID Number", "Replace Text") it seems to work fine (taking manual input) but when it tries to get the ID from the URL of a browser (automaticaly) it gives the error.
valid_name = 0
Dim objInstances, objIE, counterTab
Do While valid_name = 0 'Flag to exit the loop if the Id number has content in the SQL Database'
'-----------------------------------------------------------------------------------------'
Set objInstances = CreateObject("Shell.Application").windows
If objInstances.Count > 0 Then '/// make sure we have IE instances open.
'Loop through each tab.'
For Each objIE In objInstances
'Split the url of current tab using /'
splitURL = Split(objIE.LocationURL,"/")
'Count how many sub strings are in the URL when split'
counter = UBound(splitURL)
if counter = 7 Then
lastSplit = Split(splitURL(7),".")
lastURL = splitURL(0) & "//" & splitURL(2) & "/" & splitURL(3) & "/" & splitURL(4) & "/" & splitURL(5) & "/" & splitURL(6) & "/" & lastSplit(0)
if lastURL = "URL" Then
Set IE = objIE
counterTab = counterTab + 1
end if
end if
'End if
Next
Else
'If no internet explorer window is open.'
MsgBox "No Internet Explorer window found."
wscript.quit
End if
'Check if no [] is open in internet explorer'
if IsObject(IE) Then
url = Split(IE.LocationURL,"=")
url2 = Split(url(1),"&")
PQ_ID_number = url2(0)
else
MsgBox "No incident found."
wscript.quit
end if
'counterTab counts how many [] are open. If there is more than 1, ask for confirmation of last [] number.'
if counterTab > 1 Then
confirm = msgbox("Please confirm Incident ID: " & incidentID,vbYesNo,"Confirmation")
'If no is pressed, ask for manual entry.'
if confirm = vbNo Then
PQ_ID_number = InputBox("Enter PQ Database ID number, Do not use / ? < > \ : * | !", "PQ ID Number", "Replace Text")
On Error Resume Next
If PQ_ID_number = False Then
wscript.quit
End If
end if
end if
'-----------------------------------------------------------------------------------------'
'Open connection in Database'
dbConnectStr = "connection string"
Set con = CreateObject("ADODB.Connection")
Set recset = CreateObject("ADODB.Recordset")
con.Open dbConnectStr
'Get PQ Database title and status of incident number provided.
SQL_String = "Select title, status_id from incident_TBL where incident_ID = " & PQ_ID_number
recset.Open SQL_String, con
title = recset.Fields(0).Value
incidentStatus = recset.Fields(1).Value
con.Close
recset.Close
If title = False Then 'check if PQ_ID given has content in SQL Database
wscript.echo "Invalid PQ Database ID number, please type correct number"
valid_name = 0
Else
valid_name = 1
End If
Loop
Thanks for the help!
you need close Recordset first and only after that close connection
con.Close
recset.Close
change to:
recset.Close
con.Close

Need to add functionality in winsock control

I'm creating a application which include client & proxy server application.Both application uses winsock control.I 'm connecting client to the server by using IP address.I'm having problem with server application.It only shows the internal IP address which I don't want,what I want is external IP address i.e.Wan IP address.Is it possible with winsock?If you have a sample code please provide.Also I need one functionality server which will choose client connected to the server in list box & it will disconnect that client from the server..Please provide code.Also Once Connected to Server, If user use Internet, or any other programs, IP will show as Server's IP (Like Proxy Server).
Here is the code for the server.
Option Explicit
Dim iSockets As Integer
Dim sServerMsg As String
Dim sRequestID As String
Private Sub Form_Load()
Form1.Show
lblHostID.Caption = Socket(0).LocalHostName
lblAddress.Caption = Socket(0).LocalIP
Socket(0).LocalPort = 1007
sServerMsg = "Listening to port: " & Socket(0).LocalPort
List1.AddItem (sServerMsg)
Socket(0).Listen
End Sub
Private Sub socket_Close(Index As Integer)
sServerMsg = "Connection closed: " & Socket(Index).RemoteHostIP
List1.AddItem (sServerMsg)
Socket(Index).Close
Unload Socket(Index)
iSockets = iSockets - 1
lblConnections.Caption = iSockets
End Sub
Private Sub socket_ConnectionRequest(Index As Integer, ByVal requestID As Long)
sServerMsg = "Connection request id " & requestID & " from " & Socket(Index).RemoteHostIP
If Index = 0 Then
List1.AddItem (sServerMsg)
sRequestID = requestID
iSockets = iSockets + 1
lblConnections.Caption = iSockets
Load Socket(iSockets)
Socket(iSockets).LocalPort = 1007
Socket(iSockets).Accept requestID
End If
End Sub
I use the following code to show which clients are connected to my server
Private Sub wskServer_ConnectionRequest(ByVal requestID As Long)
With wskServer
If .State <> sckClosed Then
.Close
End If
.Accept requestID
ShowData "Connection from " & .RemoteHostIP & vbCrLf, True, vbBlack
End With 'wskServer
End Sub
In my case the showdata function shows the text in a monitoring form, but you might write the text to file or a simple msgbox

Resources