Winsock1.Connect "mail.website.com", 110
Do Until received: DoEvents: Loop
If sckError Then MsgBox "An error occured trying to connect to server": Exit Sub
sendMsg "USER username" ' Send UserName
If sckError Then MsgBox "Error with username": Exit Sub
sendMsg "PASS password" ' Send Password
If sckError Then MsgBox "Error with password": Exit Sub
' Get Number of Messages and total size in bytes
sendMsg "STAT"
x = InStr(Message$, " "): b = InStrRev(Message$, " ")
messages = Val(Mid$(Message$, x + 1, b - x))
Size = Val(Mid$(Message$, b + 1))
If messages = "0" Then
MsgBox "no new messages"
GoTo l
End If
For a = 1 To messages
Winsock1.Tag = "RETR"
Open "C:\Windows\Temp\eMail-" & a & ".eml" For Binary Access Write As #1
sendMsg "RETR " & a
List1.AddItem "eMail-" & a & ".eml"
Next
Winsock1.Tag = ""
Next
l:
Winsock.Close
When i run this the first time it works perfectly, but when i try to run it a second time w/o closing the app, it gives me the 40009 error. I'm thinking im trying to send data before its connected. is there a way to see if winsock is connected? somthing like
if winsock1.state = true then...
You didn't list all of the code, but I'm guessing that the variable received is not reset, causing you to fall through directly to the sendMsg "USER username" code early. You have to let the cinnection actually happen/complete before you can start writing to the socket.
Related
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
I have this file that makes a computer say something. I want it to loop with a VbCancel function. I get this error. Code so far:
Do
Dim Message, Speak
Message=InputBox("Enter text","Speak")
Set Speak=CreateObject("sapi.spvoice")
MsgBox ("You entered: " & Speak)
Speak.Speak Message
If Len(Speak) = 0 Then
MyMessageBox = MsgBox("Click Yes if you mean to Cancel." & vbCrLf & _
"If you mean to enter a zero length string, click No.", vbYesNo, "DO YOU MEAN TO CANCEL?")
If MyMessageBox = vbYes Then
MsgBox "Operation Cancelled"
Exit Sub
End If
Loop
BTW the error is Invalid exit statement
I'm working on Windows 7
Dim Message, Speak
Do
Message=InputBox("Enter text","Speak")
Set Speak=CreateObject("sapi.spvoice")
MsgBox ("You entered: " & Message)
Speak.Speak Message
If Len(Message) = 0 Then
MyMessageBox = MsgBox("Click Yes if you mean to Cancel." & vbCrLf & _
"If you mean to enter a zero length string, click No.", vbYesNo, "DO YOU MEAN TO CANCEL?")
If MyMessageBox = vbYes Then
MsgBox "Operation Cancelled"
Exit Do
End If
End If
Loop
You had several issues here
Exit Sub is for subroutines. You were trying to exit a Do loop
Speak is an object. I dont know if it has a string property but it is not itself a string. Both Len(Speak) and "You entered: " & Speak has Speak changed to Message.
You were missing an End If
I moved the Dim statements out of the loop. No point recreating the object over and over again.
Dim Message, Speak
Do
Message=InputBox("Enter text","Speak")
Set Speak=CreateObject("sapi.spvoice")
MsgBox ("You entered: " & Message)
Speak.Speak Message
If Len(Message) = 0 Then
MyMessageBox = MsgBox("Click Yes if you mean to Cancel." & vbCrLf & _
"If you mean to enter a zero length string, click No.", vbYesNo, "DO YOU MEAN TO CANCEL?")
If MyMessageBox = vbYes Then
MsgBox "Operation Cancelled"
Exit Do
End If
End If
Loop
For some reason i can't get the dlookup to function correctly i keep getting errors. The error for this is data type mismatch.
Option Compare Database
Private Sub Command131_Click()
DoCmd.SetWarnings False
If (Nz(DLookup("LetterSent1Bool", "dbo_T_Volunteers", _
"VolunteerID = '" & Me![VolunteerID] & "'"))) > 0 Then
MsgBox "ERROR ! This Volunteer has already received this Letter ,"
Else
DoCmd.OpenQuery "ProduceLettersSixToTwelve", , acReadOnly
If DCount("*", "dbo_T_SixToTwelveWeeks") > 0 Then
MsgBox "SUCCESS ! Please Open The Mail Merge Template"
Else
MsgBox "ERROR ! No Records Found"
End If
End If
End Sub
Figured it out, i need to remove quotes around & Me![VolunteerID]
Option Compare Database
Private Sub Command131_Click()
DoCmd.SetWarnings False
If (Nz(DLookup("LetterSent1Bool", "dbo_T_Volunteers", _
"VolunteerID = " & Me![VolunteerID]))) > 0 Then
MsgBox "ERROR ! This Volunteer has already received this Letter ,"
Else
DoCmd.OpenQuery "ProduceLettersSixToTwelve", , acReadOnly
If DCount("*", "dbo_T_SixToTwelveWeeks") > 0 Then
MsgBox "SUCCESS ! Please Open The Mail Merge Template"
Else
MsgBox "ERROR ! No Records Found"
End If
End If
End Sub
I'm changing some crufty old printing code to use the Visual Basic Print Dialog Control to pass printer information to a CrystalReport object. It works great except for one thing - the page selection box is consistently disabled no matter what flags I pass the object. Here is my code:
Public Enum PrintDialogFlags
NoFlag = 0
DisablePagesButton = 1
LoadIntoPrnObject = 2
AutoStartPrint = 4
End Enum
Public Function ShowPrintDialogCR(ByVal hwnd As Long, ByRef cr As CrystalReport, _
Optional PrintFlags As Long = 0) As Boolean
//this function assumes cr is a valid report object
On Error GoTo ShowPrintDialogCR_Error
Dim PD As New vbprndlglib.PrinterDlg
//load default settings
PD.PrinterName = Printer.DeviceName
PD.DriverName = Printer.DriverName
PD.Port = Printer.Port
PD.PaperBin = Printer.PaperBin
PD.CancelError = True
PD.flags = (vbprndlglib.cdlPDNoSelection Or vbprndlglib.cdlPDHidePrintToFile)
// commented the line below out to see if it was something with my logic
// Still disables page selection without this line
//If PrintFlags And DisablePagesButton Then PD.flags = PD.flags Or vbprndlglib.cdlPDNoPageNums
Printer.TrackDefault = False
PD.ShowPrinter (hwnd)
cr.PrinterPort = PD.Port
cr.PrinterDriver = PD.DriverName
cr.PrinterName = PD.PrinterName
cr.CopiesToPrinter = PD.Copies
If PD.flags And vbprndlglib.cdlPDPageNums Then
cr.PrinterStartPage = PD.FromPage
cr.PrinterStopPage = PD.ToPage
End If
If PrintFlags And PrintDialogFlags.LoadIntoPrnObject Then
//copy these settings to the printer object
Dim prn As Printer
For Each prn In Printers
If prn.DeviceName = PD.PrinterName Then
Set Printer = prn
Exit For
End If
Next prn
Printer.PaperBin = PD.PaperBin
Printer.PaperSize = PD.PaperSize
Printer.Duplex = PD.Duplex
Printer.Copies = PD.Copies
Printer.ColorMode = PD.ColorMode
Printer.Orientation = PD.Orientation
Printer.PrintQuality = PD.PrintQuality
End If
Set PD = Nothing
If PrintFlags And PrintDialogFlags.AutoStartPrint Then cr.Action = 1
ShowPrintDialogCR = True
Printer.TrackDefault = True
Exit Function
ShowPrintDialogCR_Error:
If Err.Number = 20545 Then //request cancelled by user
MsgBox "The print request was cancelled after being submitted to the print spooler." & vbNewLine & _
"If you cancelled a print to file dialog, this is a normal message. " & vbNewLine & _
"Otherwise, this message could mean your printer is not accepting print requests from us at this time." _
, vbOKOnly + vbExclamation, "Print Request Cancelled"
ErrorLogger Err, "ShowPrintDialogCR"
ElseIf Err.Number <> 32755 Then
//something else besides clicking cancel, show the error
MsgBox "Error " & Err.Number & " - " & Err.Description & vbNewLine & "Source: " & _
Err.Source & vbNewLine & vbNewLine & "Document not printed.", vbOKOnly + vbCritical, "Print Failure"
ErrorLogger Err, "ShowPrintDialogCR"
End If
Err.Clear
ShowPrintDialogCR = False
Printer.TrackDefault = False
End Function
I don't see what I'm doing wrong here. I've passed several combinations of unrelated flags just to see if the box would enable itself with no success. I've encountered VB6 quirks before and I'm really hoping this isn't one of them. Any help is much appreciated!
I found this in the KB article you linked to:
To enable the Select Pages portion of
the Print dialog box, Max must be set
to a number that is larger than Min.
So, at the very least, you need to set the Min and Max properties on the print dialog object to something reasonable before you set the flags:
PD.CancelError = True
'Set Min and Max to enable page selection'
PD.Min = 1
PD.Max = 32767 'Or any large number really'
PD.flags = (vbprndlglib.cdlPDNoSelection Or vbprndlglib.cdlPDHidePrintToFile)
In my own experimenting I also found out the following few things:
If you just set Min and Max, the page selection will default both the "To" and "From" fields to 1.
If you set Min to 1 and Max to -1, and also set FromPage to 1 and ToPage to -1, the "From" field will default 1 and the "To" field will be empty. It's interesting that this works since the documentation states that Max must be larger than Min, but it looks like -1 is treated more like an "empty" or "null" value.
If you set the vbPrnDlg.cdlPageNums flag, the Print Dialog will default to the Pages radio button when it's displayed. If you omit the vbPrnDlg.cdlPageNums flag, the dialog will default to the All radio button.
I am changing document template macros. The one thing I can't find out how to do is to customize error messages. For example an error message in a document is
"Error! No table of figures entries found"
I would like to change this to display something else. Is it possible to do this with Word VBA or VBScript?
Is it possible to put this in some
kind of global error handler? – Craig
It is possible. Here is a very rough example.
In a standard module:
Sub HandleErr(ErrNo As Long)
Select Case ErrNo
Case vbObjectError + 1024
MsgBox "No table of figures entries found.", vbOKOnly + vbCritical
Case vbObjectError + 1034 To vbObjectError + 4999
MsgBox "Still no table of figures entries found.", vbOKOnly + vbCritical
Case Else
MsgBox "I give up.", vbOKOnly + vbCritical, _
"Application Error"
End Select
End Sub
Some code:
Sub ShowError()
Dim i As Integer
On Error GoTo Proc_Err
'VBA Error
i = "a"
'Custom error
If Dir("C:\Docs\TableFigs.txt") = "" Then
Err.Raise vbObjectError + 1024
End If
Exit_Here:
Exit Sub
Proc_Err:
If Err.Number > vbObjectError And Err.Number < vbObjectError + 9999 Then
HandleErr Err.Number
Else
MsgBox Err.Description
End If
End Sub
If you want to trap a specific error type in VBA, one method is to use On Error Resume Next then test for an error message on the line following the action to trap, e.g.:
On Error Resume Next
' try action
If Err.Number <> 0 Then
' handle w/ custom message
Err.Clear
End If
If you know the exact error number (If Err.Number = N Then), that would be better of course.
Well if you are talking about having a custom message box - that's easy.
Look up 'msgbox' in VBA help for better info.
Msgbox("Error! No table of figures entries found",16,"Error")
The 16 makes it a 'criticial' message.
If you're talking about error trapping then you'll need code like this:
On Error Resume Next
n = 1 / 0 ' this causes an error
If Err.Number <> 0 Then
n = 1
if Err.Number = 1 Then MsgBox Err.Description
End If
When an error is thrown, a number and description are given to the Err object.