On Wed, Jul 4, 2018 at 12:18 AM, Graeme Geldenhuys <mailingli...@geldenhuys.co.uk> wrote:
> I haven't had time to look at that job at work yet, but it's on my todo > list and should be done in the next week. I don't mind sharing the solution. This is the easy part: const WTS_CURRENT_SERVER_HANDLE = DWORD(0); WTS_CURRENT_SESSION = DWORD(-1); WTS_PROTOCOL_TYPE_CONSOLE = 0; WTS_SESSION_TYPE_ICA = 1; WTS_SESSION_TYPE_RDP = 2; type WTS_INFO_CLASS = ( WTSInitialProgram , WTSApplicationName , WTSWorkingDirectory , WTSOEMId , WTSSessionId , WTSUserName , WTSWinStationName , WTSDomainName , WTSConnectState , WTSClientBuildNumber , WTSClientName , WTSClientDirectory , WTSClientProductId , WTSClientHardwareId , WTSClientAddress , WTSClientDisplay , WTSClientProtocolType , WTSIdleTime , WTSLogonTime , WTSIncomingBytes , WTSOutgoingBytes , WTSIncomingFrames , WTSOutgoingFrames , WTSClientInfo , WTSSessionInfo , WTSSessionInfoEx , WTSConfigInfo , WTSValidationInfo , WTSSessionAddressV4 , WTSIsRemoteSession); function WTSQuerySessionInformationA(hServer: HANDLE; SessionId: DWORD; WTSInfoClass: WTS_INFO_CLASS; var ppBuffer: LPTSTR; var pBytesReturned: DWORD): BOOL; stdcall; external 'wtsapi32.dll' name 'WTSQuerySessionInformationA'; procedure WTSFreeMemory(pMemory: Pointer); stdcall; external 'wtsapi32.dll'name 'WTSFreeMemory'; function WTSGetSessionType: Word; var pBuf: Pointer; pBytesReturned: DWORD; begin Result := Word(-1); pBuf := nil; pBytesReturned := 0; if not WTSQuerySessionInformationA(WTS_CURRENT_SERVER_HANDLE, WTS_CURRENT_SESSION, WTSClientProtocolType, pBuf, pBytesReturned) then Exit; if (pBytesReturned > 0) {should be 2} then begin Result := PWord(pBuf)^; WTSFreeMemory(pBuf); end; end; function WTSSessionTypeToStr(ProtocolID: Word): String; begin case ProtocolID of WTS_PROTOCOL_TYPE_CONSOLE: Result := 'WTS_PROTOCOL_TYPE_CONSOLE'; WTS_SESSION_TYPE_ICA: Result := 'WTS_PROTOCOL_TYPE_ICA'; WTS_SESSION_TYPE_RDP: Result := 'WTS_PROTOCOL_TYPE_RDP'; else Result := 'WTS_SESSION_TYPE_UNKNOWN'; end;//case end; Now only the hard part remains ... Bart _______________________________________________ fpc-pascal maillist - fpc-pascal@lists.freepascal.org http://lists.freepascal.org/cgi-bin/mailman/listinfo/fpc-pascal