I am trying to communicate with the syringe pump from PC through rs232.
I want to send a string "02DC;50803" to the pump for establishing the communication and pump should reply "C".
I am using MSComm1.Output="02DC;50803" to send the command and Text1.Text=Text1.Text+MSComm1.Input for receiving. When MSComm1.Output executes I am able to see a LED blinking on the end device but there is no reply using MSComm1.input.
Please help me out with this problem and if I put these instruction under MSComm() control, it seems to be dead.
There could be a number of problems here.
For example:
your cable could be broken
your serial port may not be functioning - I see that a lot
Your command is malformed
the pump simply doesn't expect to reply to the command you are sending
Those last 2 might be unlikely, the pump will probably reply to everything you fire at it - all the ones I have here sure answer back.
Really need a lot more information to help you.
What make/model pump?
Manual for the pump so that your commands can be checked.
Have you connected to the pump with an existing software package? - if there is one.
P.S. My software won't support your pump; I don't recognize those commands.
To continue the list from timb:
Are you using the correct baudrate?
What are the settings of .RThreshold and .SThreshold?
Are the other comport settings correct (usually N,8,1 but there are exceptions)?
Did you try the command using hyperterminal and get the expected reply?
Where in your code do you read MSComm1.Input? in Which event?
Does the device have a led as well which blinks it is when sending data? does it blink?
Does the command need an end-char like vbCrLf or vbCr of anything else?
Please post the complete code of the function/sub where you send the command, and please post the complete code of the function/sub where you read MSCOmm1.Input
Have a look at the following testproject in which I send the "AT" command to my modem which is connected to commport 1 and with which I communicate at baudrate 9600:
'1 form with:
' 1 textbox control : name=Text1
' 1 command button : name=Command1
' 1 MSComm control : name=MSComm1
Option Explicit
Private Sub Command1_Click()
MSComm1.Output = "at" & vbCrLf
End Sub
Private Sub Form_Load()
With MSComm1
If .PortOpen Then .PortOpen = False
.Settings = "9600,n,8,1"
.CommPort = 1
.RThreshold = 1 'read data per char
.SThreshold = 0 'send all data at once
.PortOpen = True
End With 'MSComm1
End Sub
Private Sub Form_Resize()
Dim sngWidth As Single
Dim sngCmdHeight As Single
Dim sngTxtHeight As Single
sngWidth = ScaleWidth
sngCmdHeight = 315
sngTxtHeight = ScaleHeight - sngCmdHeight
Text1.Move 0, 0, sngWidth, sngTxtHeight
Command1.Move 0, sngTxtHeight, sngWidth, sngCmdHeight
End Sub
Private Sub MSComm1_OnComm()
Dim strData As String
With MSComm1
Select Case .CommEvent
Case comEvReceive
strData = .Input
ShowData strData
End Select
End With 'MSComm1
End Sub
Private Sub ShowData(strData As String)
With Text1
.SelStart = Len(.Text)
.SelText = strData
End With 'Text1
End Sub
When I click on Command1 it will send "AT" & vbCrLf and the modem replies with "OK" which is shown in Text1.
Related
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
Whenever I hit an error with my script, the focus turns to the VBA code and the offending line. I fix it, and hit save. Then I notice that the script is no longer running, even after I make sure that it's not paused.
For example, right now I'm using a Form_Timer() event to do some testing (interval set to 1000ms). To test the script again, I just set it to a minute in the future (e.g. if the current time is 8:54:00 AM I set it to fire at 8:55:00 AM). But this stops working after an error. Does anyone know why this is? I don't want to have to tell my users to close and re-open their copies of the Access DB just to make the script work again.
Code:
Private Sub Form_Timer()
On Error GoTo ErrorHandler
current_date_time = Now
If current_date_time = #6/28/2016 8:52:00 AM# Then
MsgBox ("the current_date_time variable holds: " & current_date_time)
'Declare objects
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim qdf As DAO.QueryDef
Dim oApp As Outlook.Application
Dim oMail As Outlook.MailItem
Dim mail_body As String
'Set objects
Set dbs = CurrentDb
Set qdf = dbs.QueryDefs("qry_BMBFLoc")
Set rst = qdf.OpenRecordset
Set oApp = New Outlook.Application
Set oMail = oApp.CreateItem(olMailItem)
mail_body = "The following jobs do not have the special BF location set in Job Orders: " & vbCrLf
If Not (rst.EOF And rst.BOF) Then
rst.MoveFirst
Do Until rst.EOF = True
mail_body = mail_body & rst!job & "-" & rst!suffix & vbCrLf
rst.MoveNext
Loop
'Email contents
oMail.Body = mail_body
oMail.Subject = "Blah"
oMail.To = "someone#something.com"
oMail.Send
'Close stuff
rst.Close
dbs.Close
Set rst = Nothing
Set oMail = Nothing
Set oApp = Nothing
End If
End If
Exit Sub
ErrorHandler:
Dim msg As String
If Err.Number <> 0 Then
msg = "email Form Timer Error #" & Str(Err.Number) & " error Line: " & Erl & Chr(13) & Err.Description
MsgBox msg, , "Error", Err.HelpFile, Err.HelpContext
End If
Exit Sub
End Sub
In order to reactivate the code, you could close the form when the error is triggered. The user would then have to reload the form to complete the action.
However, without any intervention the error is likely to occur again.
Edit: Or you could write a Function to automatically close, and re-open the offending form. Calling it in the on error command.
When there is an error in access form, the timer will stop working, you don't need to close and reopen the whole database, only the form to start the timer again. Otherwise you can add a button called "refresh" and bind macro to it which will turn the timer on again.
Yeah this sucks. I am writing a vba script for outlook and so the only way to debug is to close and reopen outlook after every error.
So I know that my code below works. The purpose is to create a tcp Ethernet connection between a scale and computer, so that when a weight is read on the scale, the value is displayed on the computer at the push of a button. I copied this code to a new lab machine that was just imaged for me. As for the winsock, I dynamically created it at run-time by adding it to the references. I understand that this is not what I am supposed to do (see: https://support.microsoft.com/en-us/kb/313984).
With a breakpoint at the CFixPicture_Initialize function, the code hits "set tcpC = new Winsock" line and breaks with error 429: avtiveX componenet can't create object. Does anybody have any ideas as to how I can get this license/get this Winsock control to work? Thanks!
Option Explicit
Private WithEvents tcpC As Winsock
Private Sub CFixPicture_Close()
Set tcpC = Nothing
End Sub
Private Sub CFixPicture_Initialize()
Set tcpC = New Winsock
tcpC.LocalPort = 0
tcpC.Connect "192.168.0.1", 8000
End Sub
Private Sub CommandButton1_click()
On Error GoTo errHandler
tcpC.SendData "S" & vbCrLf
Exit Sub
errHandler:
MsgBox "error:" & Err.Description
End Sub
Private Sub tcpC_DataArrival(ByVal bytesTotal As Long)
Dim strData As String
Dim strDataString As String
tcpC.GetData strData
strDataTrim = Mid(strData, 11)
Text1.Caption = "Weight: " & vbCrLf
The control is not present or is present but not registered on the new machine.
Copy over mswinsck.ocx from your *system directory to the new machines *system directory
Open a console as admnistrator and run regsvr32.exe c:\whatever\mswinsck.ocx
*\System32 or \SysWoW64 on 64 bit Windows.
As there was no license for the Winsock, I found a license online. I simply ran this program and voila! The Winsock worked. Thanks!
http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=4860&lngWId=1
I need to send a file to some electronic device and execute it.
I couldn't find any information online regarding MS Comms and I didn't find Documentation on the Microsoft (https://msdn.microsoft.com/en-us/library/aa231237(v=vs.60).aspx) any useful :
' Send Byte array data
MSComm1.Output = Out
Would be great if you guys could give me some pointers and help me to solve my problem. The problem that I am experiencing is an infinite loop at Loop Until MSComm1.OutBufferCount = 0, when I return "MSComm1.OutBufferCount" between Do and Loop "MSComm1.OutBufferCount" is 0 and files dont seem to be sent over to the device.
Closest function I got to at the present moment is below:
Function SendFile(tmp$)
Dim temp$
Dim hsend, bsize, LF&
' Open file
Open tmp$ For Binary Access Read As #2
' Check size on Mscomm1 OutBuffer
bsize = MSComm1.OutBufferSize
' Check file length
LF& = LOF(2)
' This code makes tiny pieces of data (Buffer sized)
' And send's it
Do Until EOF(2)
If LF& - Loc(2) <= bsize Then
bsize = LF& - Loc(2) + 1
End If
' Make room for some data
temp$ = Space$(bsize)
' Put the data piece in the Temp$ string
Get #2, , temp$
MSComm1.Output = temp$
Do
' Wait until the buffer is empty
Loop Until MSComm1.OutBufferCount = 0
Loop
' close file
Close #2
End Function
Have a look at the RThreshold and SThreshold properties
Below is a simple example project :
'1 form with :
' 1 label control : name=Label1
' 1 textbox control : name=Text1
' 1 command button : name=Command1
Option Explicit
Private Sub Command1_Click()
'send command
MSComm1.Output = Text1.Text & vbCr
End Sub
Private Sub Form_Load()
'config mscomm control and open connection
With MSComm1
.Settings = "9600,N,8,1"
.RThreshold = 1
.SThreshold = 0
.CommPort = 1
.PortOpen = True
End With 'MSComm1
End Sub
Private Sub Form_Resize()
'position controls
Dim sngWidth As Single, sngHeight As Single
Dim sngCmdWidth As Single, sngCmdHeight As Single
Dim sngTxtWidth As Single
Dim sngLblHeight As Single
sngWidth = ScaleWidth
sngHeight = ScaleHeight
sngCmdWidth = 1215
sngCmdHeight = 495
sngLblHeight = sngHeight - sngCmdHeight
sngTxtWidth = sngWidth - sngCmdWidth
Label1.Move 0, 0, sngWidth, sngLblHeight
Text1.Move 0, sngLblHeight, sngTxtWidth, sngCmdHeight
Command1.Move sngTxtWidth, sngLblHeight, sngCmdWidth, sngCmdHeight
End Sub
Private Sub MSComm1_OnComm()
'process received data
Dim strInput As String
Select Case MSComm1.CommEvent
Case comEvReceive
strInput = MSComm1.Input
Label1.Caption = Label1.Caption & strInput
End Select
End Sub
In Command1_Click I add a carriage return to the command from Text1 as most devices require the command to be finished by that
In MSComm1_OnComm I just print the received data to the label, but you might want to add the received data to a global variable, and then process the contents of that variable, as all data might not be received at once
I'm trying to use Winsock to download some files and save them.
In my case, I have a MSHFlexGrid with 2 columns: one with URL and the other with the "path+filename" (where the file is going to be saved).
I'm iterating through all rows calling the next function:
Public Function DownloadSock(ArqURL As String, ArqDestino As String) As Boolean
'ArqURL is the file URL
'ArqDestino is where the downloaded file is going to be stored, in my hard disc
Dim arquivo() As Byte
Dim ficheiroID As Integer
ficheiroID = FreeFile
On Error GoTo Trata_erro
Open ArqDestino For Binary Access Write As #ficheiroID
Me.Winsock1.Connect ArqURL, 80
Me.Winsock1.GetData arquivo()
Put #ficheiroID, , arquivo()
Close #ficheiroID
DownloadSock = True
Exit Function
Trata_erro:
MDIForm1.Text1 = MDIForm1.Text1 & "Error! " & Err.Number & Err.Description & " - " & Err.Source & " - URL: " & ArqURL & " - Destino: " & ArqDestino & vbNewLine
DownloadSock = False
End Function
I'm getting this error
40006: Wrong protocol or connection
state for the requested transaction or
request
What am I doing wrong?
Have you checked out this Microsoft Support page? It indicates there's a bug in the Winsock control and the hotfix may be helpful.
Another thing to try is to make sure your winsock connection is open before trying to read/send data, and if it is closed, reopen a new connection:
if winsock.state=9 ' error state
winsock.close
while winsock.state<>0 ' closed state
doEvents
wend ' you need a while loop, because it doesn't close "immediately".
end if
' now you reopen it, or do whatever else you need
You might also consider changing your connection code to something like:
With Winsock1
If .State <> sckClosed Then .Close
.RemoteHost = ArqURL
.RemotePort = 80
.Connect
End With
One last thing. Check out this post on using the Winsock control.
I think you have overestimated the power of the Winsock control. You can't just use the Winsock's GetData method to reach out and grab a file. There has to be an active connection between your client application and some other application on the server side. After a connection is established, this server application will feed data to your application, the Winsock's DataArrival event will fire, and then you can use the GetData method to retrieve it. Your code should look more like this:
Public Sub DownloadSock(ArqURL As String)
Dim arquivo() As Byte
Dim ficheiroID As Integer
ficheiroID = FreeFile
Me.Winsock1.Connect ArqURL, 80
End Function
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim ArqDestino As String
Dim arquivo() As Byte
Dim ficheiroID As Integer
ficheiroID = FreeFile
Open ArqDestino For Binary Access Write As #ficheiroID
Me.Winsock1.GetData arquivo()
Put #ficheiroID, , arquivo()
Close #ficheiroID
End Sub
This is far from complete however (nor is it guaranteed to be syntactically correct, consider it pseudo code). After making the connection, you then have to implement some mechanism to tell the server to begin sending the file. If the file is large enough it will take many DataArrival events to get it all, so it will have to be held in an accumulator while the data comes across. There's more to this than you think.
I would take a look at some tutorials and/or sample code (look for a VB6 project that uses the Winsock control on CodeProject, like this one).