In which event or how can i check for internet connections while program is running? Scenario: program is running and suddenly internet connection goes off and a dialog opens "No internet access, changing connection string to central database". I tried this function, but im not sure in which event should i put so that it works all the time.
function TFK_Lib.CheckInternet: boolean;
begin
ConnectedState := INTERNET_CONNECTION_MODEM;
Result := InternetGetConnectedState(#ConnectedState, 0);
end;
You can use a timer to check (at a time period) the connection and show the dialog (as a modal so you can't do anything else).
You can do a practical test and ping google.com.
If I understood your question correctly I thinks its not a bad option.
Code example:
class function TAuthUserFunctions.CheckInternet: boolean;
var
idtcp : TIdTCPClient;
begin
try
idtcp := TIdTCPClient.Create(Nil);
try
idtcp.ReadTimeout := 2000;
idtcp.ConnectTimeout := 2000;
idtcp.Port := 80;
idtcp.Host := 'google.com';
idtcp.Connect;
idtcp.Disconnect;
Result := True;
finally
idtcp.Free;
end;
except
Result := False;
end;
end;
Related
My tethering app sometimes does not get internet access. In these cases Windows will not ask whether the app has permission to use the internet. My app generates no errors but of course will not tether.
How can I test whether my Delphi app has access to the internet sufficient for tethering?
The following code should work on all platforms:
uses IdTCPClient;
function CheckInternet : Boolean;
var TCPClient : TIdTCPClient;
begin
TCPClient := TIdTCPClient.Create (NIL);
try
try
TCPClient.ReadTimeout := 2000;
TCPClient.ConnectTimeout := 2000;
TCPClient.Port := 80;
TCPClient.Host := 'google.com';
TCPClient.Connect;
TCPClient.Disconnect;
Result := true;
except
Result := false;
end; { try / except }
finally
TCPClient.Free;
end; { try / finally }
end;
Source: www.fmxexpress.com
A library to check for an Internet connection on mobile devices can be found at www.delphiworlds.com
I wrote a serial port class that I developed and for simplicity I used blocking/synchronous/non-overlapped. I went through all MSDN documentations and it was strait forward for me.
I don't have any problem with Opening, Transmitting or Receiving Bytes from the port. All operations are synchronous and there is no-threading complexity.
function TSerialPort.Open: Boolean;
var
h: THandle;
port_timeouts: TCommTimeouts;
dcb: TDCB;
begin
Result := False;
if Assigned(FHandleStream) then
begin
// already open
Exit(True);
end;
h := CreateFile(PChar('\\?\' + FComPort),
GENERIC_WRITE or GENERIC_READ, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
// RaiseLastOSError();
if h <> INVALID_HANDLE_VALUE then
begin
{
REMARKS at https://learn.microsoft.com/en-us/windows/desktop/api/winbase/ns-winbase-_commtimeouts
If an application sets ReadIntervalTimeout and ReadTotalTimeoutMultiplier to MAXDWORD and
sets ReadTotalTimeoutConstant to a value greater than zero and less than MAXDWORD, one
of the following occurs when the ReadFile function is called:
* If there are any bytes in the input buffer, ReadFile returns immediately with the bytes in the buffer.
* If there are no bytes in the input buffer, ReadFile waits until a byte arrives and then returns immediately.
* If no bytes arrive within the time specified by ReadTotalTimeoutConstant, ReadFile times out.
}
FillChar(port_timeouts, Sizeof(port_timeouts), 0);
port_timeouts.ReadIntervalTimeout := MAXDWORD;
port_timeouts.ReadTotalTimeoutMultiplier := MAXDWORD;
port_timeouts.ReadTotalTimeoutConstant := 50; // in ms
port_timeouts.WriteTotalTimeoutConstant := 2000; // in ms
if SetCommTimeOuts(h, port_timeouts) then
begin
FillChar(dcb, Sizeof(dcb), 0);
dcb.DCBlength := sizeof(dcb);
if GetCommState(h, dcb) then
begin
dcb.BaudRate := FBaudRate; // baud rate
dcb.ByteSize := StrToIntDef(FFrameType.Chars[0], 8); // data size
dcb.StopBits := ONESTOPBIT; // 1 stop bit
dcb.Parity := NOPARITY;
case FFrameType.ToUpper.Chars[1] of
'E': dcb.Parity := EVENPARITY;
'O': dcb.Parity := ODDPARITY;
end;
dcb.Flags := dcb_Binary or dcb_Parity or dcb_ErrorChar or
(DTR_CONTROL_ENABLE shl 4) or (RTS_CONTROL_ENABLE shl 12);
dcb.ErrorChar := '?'; // parity error will be replaced with this char
if SetCommState(h, dcb) then
begin
FHandleStream := THandleStream.Create(h);
Result := True;
end;
end;
end;
if not Result then
begin
CloseHandle(h);
end;
end;
end;
function TSerialPort.Transmit(const s: TBytes): Boolean;
var
len: NativeInt;
begin
Result := False;
len := Length(s);
if Assigned(FHandleStream) and (len > 0) then
begin
// total timeout to transmit is 2sec!!
Result := (FHandleStream.Write(s, Length(s)) = len);
end;
end;
function TSerialPort.Receive(var r: Byte): Boolean;
begin
Result := False;
if Assigned(FHandleStream) then
begin
// read timeout is 50ms
Result := (FHandleStream.Read(r, 1) = 1);
end;
end;
My problem starts at closing the port.
After all my communications, when I try to close the serial port, my Application totally hangs at CloseHandle() API. And that happens randomly. Which is meaningless to me since I use synchronous mode, there can not be any pending operations. When I request a close, It must simply close the handle.
I searched the problem on the google and stack-overflow. There are many people who faced the similar problems but most of them are related with .NET serial port driver and their asynchronous mode operations which I don't have.
And also some people forgot to set timeouts properly and they faced blocking issue at ReadFile and WriteFile API that is fully normal. But again this is not my problem, I've set CommTimeouts as it is indicated in MSDN remarks.
function TSerialPort.Close: Boolean;
var
h: THandle;
begin
Result := True;
if Assigned(FHandleStream) then
begin
h := FHandleStream.Handle;
FreeAndNil(FHandleStream);
if h <> INVALID_HANDLE_VALUE then
begin
//PurgeComm(h, PURGE_TXABORT or PURGE_RXABORT or PURGE_TXCLEAR or PURGE_RXCLEAR); // didn't help
//ClearCommError(h, PDWORD(nil)^, nil); // didn't help
//CancelIO(h); // didn't help
Result := CloseHandle(h); <------------ hangs here
end;
end;
end;
Some people on Microsoft forum, suggest calling CloseHandle() in different thread. I have tried that as well. But that time it hangs while trying to free AnonymousThread that I created. Even I left FreeOnTerminate:=true as default, it hangs and I get memory leakage report by Delphi.
Another bothering problem when it hangs, I have to close Delphi IDE fully and reopen. Otherwise I can't compile the code again since exe is still used.
function TSerialPort.Close: Boolean;
var
h: THandle;
t: TThread;
Event: TEvent;
begin
Result := True;
if Assigned(FHandleStream) then
begin
h := FHandleStream.Handle;
FreeAndNil(FHandleStream);
if h <> INVALID_HANDLE_VALUE then
begin
PurgeComm(h, PURGE_TXABORT or PURGE_RXABORT or PURGE_TXCLEAR or PURGE_RXCLEAR);
Event := TEvent.Create(nil, False, False, 'COM PORT CLOSE');
t := TThread.CreateAnonymousThread(
procedure()
begin
CloseHandle(h);
If Assigned(Event) then Event.SetEvent();
end);
t.FreeOnTerminate := False;
t.Start;
Event.WaitFor(1000);
FreeAndNil(t); // <---------- that time it hangs here, why??!!
FreeAndNil(Event);
end;
end;
end;
In my notebook I'm using USB to Serial Port converters from FTDI. Some people said that it is because of FTDI driver. But I'm using all microsoft drivers that is signed by Microsoft Windows Hardware Compatibility Publisher. There is no third party driver in my system. But when I disconnect the USB adapter, CloseHandle API unfreeze itself. Some people reports that, even native Serial Ports that are build in their motherboards have same issue.
So far I couldn't solve the problem. Any help or workaround highly appreciated.
Thanks.
This issue is with the FTDI USB-Serial converter driver. It doesn't handle the hardware flow control properly and on occasion will hang in CloseHandle call.
To get around the issue, implement hardware flow control manually. In C++ (not sure how it would be done in Delphi) set up these DCB structure fields in order to allow manual control of the RTS line:
// Assuming these variables are defined in the header
HANDLE m_hComm; // Comm port handle.
DCB m_dcb; // DCB comm port settings.
// Put these settings in the DCB structure.
m_dcb.fRtsControl = RTS_CONTROL_ENABLE;
m_dcb.fOutxCtsFlow = TRUE;
Then use
EscapeCommFunction(m_hComm, CLRRTS); // Call this before calling WriteFile.
And
EscapeCommFunction(m_hComm, SETRTS); // Call this after Write is complete.
In your case, because its synchronous - you can just wrap every call to WriteFile with these 2 calls. If using asynchronous (like in my case), call the one with SETRTS after you get the completion event from the ovelapped structure in your WriteFile call.
Used to freeze all the time before we implemented this as we were using 12 serial ports, and only way to unlock the port would be restarting the computer.
Now works like a charm with manual control, hasn't frozen once since.
One thing to keep in mind, some USB-Serial devices (or even different versions of FTDI) may invert the RTS line! So if the above doesn't work, try using SETRTS to set the line low and CLRRTS to set it high.
Edit: If you have access to a Windows XP machine, use portmon tool to see what is happening with the RTS line, this way you will know if it is inverted or not or if it is getting the commands at all.
The following code always returns True on my system:
uses
WinInet;
function CheckInternetConnection() : Boolean;
var
dwConnectionTypes: Integer;
begin
dwConnectionTypes := (
INTERNET_CONNECTION_MODEM +
INTERNET_CONNECTION_LAN +
INTERNET_CONNECTION_PROXY); // "dwConnectionTypes" now "7"
if (InternetGetConnectedState(#dwConnectionTypes, 0)) then
Result := True // Always hit, "dwConnectionTypes" now "18"
else
Result := False; // Never reaches here!
end;
I've tried:
* unplugging the network cable
* stopped "Wireless Zero Configuration" service
* disabled all connections in Control Panel > Network Connections
* definitely confirmed no internet connection in a web browser
What am I missing?
UPDATE
I've confirmed that dynamically loading wininet.dll and using GetProcAddress to find the method "InternetGetConnectedState" gives exactly the same result with the internet disconnected (returns True and the parameter is set to "18").
If you want to know if you are connected to the Internet, there is no other way that contacting a host on the internet.
Correct technically then you only know if that host is online, but that's often good enough, since if your program requires internet access it's because you need to cantact a host on the internet.
One way of doing that is using a TIdHTTP from Indy:
uses
IdHTTP;
uses
IdHTTP;
function HasInternet: Boolean;
begin
with TIdHTTP.Create(nil) do
try
try
HandleRedirects := True;
Result := Get('http://www.Google.com/') <> '';
except
Result := false;
end;
finally
free;
end;
end;
And then use it :
procedure TForm1.FormCreate(Sender: TObject);
begin
Caption := BoolToStr(HasInternet, True);
end;
But it would be bettet to try to contact you host.
I need to set custom timeout for TTcpClient. I think the default timeout time is about 20-25 seconds but I need to change it to 500ms. Is it possible And How?
procedure TForm1.Button1Click(Sender: TObject);
begin
TcpClient2.RemoteHost := '192.168.1.1';
TcpClient2.RemotePort := '23';
TcpClient2.Connect;
tcpclient2.Receiveln();
tcpclient2.Sendln('admin');
tcpclient2.Receiveln;
end;
I tried non-blocking option but the software returns an error after I click on button And I have to do it again 4-5 times. Any help?
Thanks :)
Winsock has no connect timeout, but this can be overcomed.
You have several options:
Without threads:
Using non-blocking mode: call Connect, then wait using Winsock select function (encapsulated in TBaseSocket Select method inherited by TTcpClient).
Using blocking mode: changing temporarily to non-blocking mode and proceeding as in the previous case.
With threads: see Remy Lebeau's answer to How to control the connect timeout with the Winsock API?.
Use Indy.
Blocking vs non-blocking
Using blocking or non-blocking mode is a very important design decision that will affect many of your code and which you can't easily change afterward.
For example, in non-blocking mode, receive functions (as Receiveln), will not wait until there is enough input available and could return with an empty string. This can be an advantage if is this what you need, but you need to implement some strategy, such as waiting using TcpClient.WaitForData before calling the receive function (in your example, the Receiveln-Sendln-Receiveln will not work as is).
For simple tasks, blocking mode is easier to deal with.
Non-blocking mode
The following function will wait until the connection is successful or the timeout elapses:
function WaitUntilConnected(TcpClient: TTcpClient; Timeout: Integer): Boolean;
var
writeReady, exceptFlag: Boolean;
begin
// Select waits until connected or timeout
TcpClient.Select(nil, #writeReady, #exceptFlag, Timeout);
Result := writeReady and not exceptFlag;
end;
How to use:
// TcpClient.BlockMode must be bmNonBlocking
TcpClient.Connect; // will return immediately
if WaitUntilConnected(TcpClient, 500) then begin // wait up to 500ms
... your code here ...
end;
Also be aware of the following drawbacks/flaws in TTcpClient's non-blocking mode design:
Several functions will call OnError with SocketError set to WSAEWOULDBLOCK (10035).
Connected property will be false because is assigned in Connect.
Blocking mode
Connection timeout can be achieved by changing to non-blocking mode after socket is created but before calling Connect, and reverting back to blocking mode after calling it.
This is a bit more complicated because TTcpClient closes the connection and the socket if we change BlockMode, and also there is not direct way of creating the socket separately from connecting it.
To solve this, we need to hook after socket creation but before connection. This can be done using either the DoCreateHandle protected method or the OnCreateHandle event.
The best way is to derive a class from TTcpClient and use DoCreateHandle, but if for any reason you need to use TTcpClient directly without the derived class, the code can be easily rewriten using OnCreateHandle.
type
TExtendedTcpClient = class(TTcpClient)
private
FIsConnected: boolean;
FNonBlockingModeRequested, FNonBlockingModeSuccess: boolean;
protected
procedure Open; override;
procedure Close; override;
procedure DoCreateHandle; override;
function SetBlockModeWithoutClosing(Block: Boolean): Boolean;
function WaitUntilConnected(Timeout: Integer): Boolean;
public
function ConnectWithTimeout(Timeout: Integer): Boolean;
property IsConnected: boolean read FIsConnected;
end;
procedure TExtendedTcpClient.Open;
begin
try
inherited;
finally
FNonBlockingModeRequested := false;
end;
end;
procedure TExtendedTcpClient.DoCreateHandle;
begin
inherited;
// DoCreateHandle is called after WinSock.socket and before WinSock.connect
if FNonBlockingModeRequested then
FNonBlockingModeSuccess := SetBlockModeWithoutClosing(false);
end;
procedure TExtendedTcpClient.Close;
begin
FIsConnected := false;
inherited;
end;
function TExtendedTcpClient.SetBlockModeWithoutClosing(Block: Boolean): Boolean;
var
nonBlock: Integer;
begin
// TTcpClient.SetBlockMode closes the connection and the socket
nonBlock := Ord(not Block);
Result := ErrorCheck(ioctlsocket(Handle, FIONBIO, nonBlock)) <> SOCKET_ERROR;
end;
function TExtendedTcpClient.WaitUntilConnected(Timeout: Integer): Boolean;
var
writeReady, exceptFlag: Boolean;
begin
// Select waits until connected or timeout
Select(nil, #writeReady, #exceptFlag, Timeout);
Result := writeReady and not exceptFlag;
end;
function TExtendedTcpClient.ConnectWithTimeout(Timeout: Integer): Boolean;
begin
if Connected or FIsConnected then
Result := true
else begin
if BlockMode = bmNonBlocking then begin
if Connect then // will return immediately, tipically with false
Result := true
else
Result := WaitUntilConnected(Timeout);
end
else begin // blocking mode
// switch to non-blocking before trying to do the real connection
FNonBlockingModeRequested := true;
FNonBlockingModeSuccess := false;
try
if Connect then // will return immediately, tipically with false
Result := true
else begin
if not FNonBlockingModeSuccess then
Result := false
else
Result := WaitUntilConnected(Timeout);
end;
finally
if FNonBlockingModeSuccess then begin
// revert back to blocking
if not SetBlockModeWithoutClosing(true) then begin
// undesirable state => abort connection
Close;
Result := false;
end;
end;
end;
end;
end;
FIsConnected := Result;
end;
How to use:
TcpClient := TExtendedTcpClient.Create(nil);
try
TcpClient.BlockMode := bmBlocking; // can also be bmNonBlocking
TcpClient.RemoteHost := 'www.google.com';
TcpClient.RemotePort := '80';
if TcpClient.ConnectWithTimeout(500) then begin // wait up to 500ms
... your code here ...
end;
finally
TcpClient.Free;
end;
As noted before, Connected doesn't work well with non-blocking sockets, so I added a new IsConnected property to overcome this (only works when connecting with ConnectWithTimeout).
Both ConnectWithTimeout and IsConnected will work with both blocking and non-blocking sockets.
Is there a more elegant way of checking if a TCP port is available with Delphi other than catching a netstat call?
I guess you can use Indy's components to do that. For instance a TIdHTTPServer will raise an exception if a port is in use when it is being opened.
So basically you could create such component, bind it to localhost:<yourport> and if an exception is raised ( catch it and check it ) then the port is probably in use, else it is free.
I guess other indy components can tell if a port is open or not, but I can't look at it right now.
This was just to give you an approach.
#Mattl, if Available means open for you, you can use this code.
program CheckTCP_PortOpen;
{$APPTYPE CONSOLE}
uses
Winsock; //Windows Sockets API Unit
function PortTCPIsOpen(dwPort : Word; ipAddressStr:string) : boolean;
var
client : sockaddr_in;//sockaddr_in is used by Windows Sockets to specify a local or remote endpoint address
sock : Integer;
begin
client.sin_family := AF_INET;
client.sin_port := htons(dwPort);//htons converts a u_short from host to TCP/IP network byte order.
client.sin_addr.s_addr := inet_addr(PChar(ipAddressStr)); //the inet_addr function converts a string containing an IPv4 dotted-decimal address into a proper address for the IN_ADDR structure.
sock :=socket(AF_INET, SOCK_STREAM, 0);//The socket function creates a socket
Result:=connect(sock,client,SizeOf(client))=0;//establishes a connection to a specified socket.
end;
var
ret : Integer;
wsdata : WSAData;
begin
Writeln('Init WinSock');
ret := WSAStartup($0002, wsdata);//initiates use of the Winsock
if ret<>0 then exit;
try
Writeln('Description : '+wsData.szDescription);
Writeln('Status : '+wsData.szSystemStatus);
if PortTCPIsOpen(80,'127.0.0.1') then
Writeln('Open')
else
Writeln('Close');
finally
WSACleanup; //terminates use of the Winsock
end;
Readln;
end.
netstat information can be retrieved by calling the GetTcpTable and GetUdpTable functions in the IP Helper API, or IPHLPAPI.DLL. For more information on calling the IPHLPAPI.DLL from Delphi, check out this Network traffic monitor. There are some wrappers for it too, and it is part of JEDI API Library.
I wrote a Delphi version of NetStat long ago, but have since lost the source code. Those resources should get you started though.
The following code from Synapse works very well:
uses
blcksock;
function PortAvailable(Port:STring):boolean;
var
svr : TTCPBlockSocket;
begin
svr := TTCPBlockSocket.Create;
try
svr.Bind('0.0.0.0',Port);
svr.Listen;
result := svr.LastError = 0;
Svr.CloseSocket;
finally
svr.Free;
end;
end;
Using an Indy.Sockets v10 TIdTCPServer component:
function TExample.IsTCPPortAvailable(const APort: Word): Boolean;
var
LTCPServer: TIdTCPServer;
LBinding: TIdSocketHandle;
begin
Result := True;
LTCPServer := TIdTCPServer.Create;
try
try
with LTCPServer do
begin
DefaultPort := APort;
LBinding := Bindings.Add;
LBinding.IP := '127.0.0.1';
LBinding.Port := APort;
OnExecute := TCPServerExecute;
Active := True;
end;
finally
LTCPServer.Free;
end;
except on EIdCouldNotBindSocket do
Result := False;
end;
end;
procedure TExample.TCPServerExecute(AContext: TIdContext);
begin
end;
Based on Silver's example above, and since in many cases you want to find an available port rather than just verifying that a given port is in use:
uses
//Indy V10
IdContext,
IdSocketHandle,
IdTcpServer;
type
//our port-checking tool
TPortChk = class(TIdTCPServer)
procedure OnExec(AContext: TIdContext);
end;
procedure TPortChk.OnExec(AContext: TIdContext);
begin
//does nothing, but must exist and be hooked
end;
//check a TCP port to see if it's already in use.
//normally used before opening a listener.
function PortAvailable(APort: Word): Boolean;
var
svr: TPortChk;
bnd: TIdSocketHandle;
begin
//assume our port is available
Result := True;
//create our checking object
svr := TPortChk.Create;
try
//set the execute event
svr.OnExecute := svr.OnExec;
//loop looking for an available port
try
//set up the binding for our local system and the
//port in question
bnd := svr.Bindings.Add;
bnd.IP := '127.0.0.1';
bnd.Port := APort;
//try to bind. This will throw an EIdCouldNotBindSocket
//exception if the port is already in use.
svr.Active := True;
//if we get here, the port is *currently* available.
//close the server and bail
svr.Active := False;
Exit;
except
//whoops, port's in use (or some related failure)
Result := False;
end;
finally
svr.Free;
end;
end;
//search a range of ports for the first available
function FindAvailablePort(First, Count: Word): Word;
var
svr: TPortChk;
bnd: TIdSocketHandle;
begin
//assume our initial port is available
Result := First;
//create our checking object
svr := TPortChk.Create;
try
//set the execute event
svr.OnExecute := svr.OnExec;
//loop looking for an available port
while (Result - First) < Count do begin
try
//set up the binding for our local system and the
//port in question
bnd := svr.Bindings.Add;
bnd.IP := '127.0.0.1';
bnd.Port := Result;
//try to bind. This will throw an EIdCouldNotBindSocket
//exception if the port is already in use.
svr.Active := True;
//if we get here, we found our available port, so kill the
//server and bail
svr.Active := False;
Exit;
except
Inc(Result);
svr.Bindings.Clear;
end;
end;
//if we get here, all of our possible ports are in use,
//so return $FFFF to indicate that no port is available
Result := $FFFF;
finally
svr.Free;
end;
end;