getcompu_name.pas

以前写的一个利用P2P 技术的一个通讯的例子。里面用到了 DBISAM 、INDY 控件。

unit GetCompu_Name;

interface

uses
   Windows;

const
   //Terminal server constants and external call procedures
   wtsapi = 'wtsapi32.dll';
   WTS_CURRENT_SERVER = THandle(0);
   {$EXTERNALSYM WTS_CURRENT_SERVER}
   WTS_CURRENT_SERVER_HANDLE = THandle(0);
   {$EXTERNALSYM WTS_CURRENT_SERVER_HANDLE}
   WTS_CURRENT_SERVER_NAME = '';
   {$EXTERNALSYM WTS_CURRENT_SERVER_NAME}
   WTS_CURRENT_SESSION = DWORD(-1);
   {$EXTERNALSYM WTS_CURRENT_SESSION}

   {$IFDEF UNICODE}
   WtsFunctionName = 'WTSQuerySessionInformationW';
   {$ELSE}
   WtsFunctionName = 'WTSQuerySessionInformationA';
   {$ENDIF}

type
   TPrinterError = (tpeNone, tpeSystemNotDefined, tpeWindowsNotDefined, tpeUndefined);

   _WTS_INFO_CLASS = (
      WTSInitialProgram,
      WTSApplicationName,
      WTSWorkingDirectory,
      WTSOEMId,
      WTSSessionId,
      WTSUserName,
      WTSWinStationName,
      WTSDomainName,
      WTSConnectState,
      WTSClientBuildNumber,
      WTSClientName,
      WTSClientDirectory,
      WTSClientProductId,
      WTSClientHardwareId,
      WTSClientAddress,
      WTSClientDisplay,
      WTSClientProtocolType);

   {$EXTERNALSYM _WTS_INFO_CLASS}
   WTS_INFO_CLASS = _WTS_INFO_CLASS;
   TWtsInfoClass = WTS_INFO_CLASS;

   TWTSQuerySessionInformationA = function(hServer: THandle; SessionId: DWORD; WTSInfoClass: TWtsInfoClass; var ppBuffer: Pointer; var pBytesReturned: DWORD): BOOL; stdcall;
   {$EXTERNALSYM TWTSQuerySessionInformationA}
   TWTSQuerySessionInformationW = function(hServer: THandle; SessionId: DWORD; WTSInfoClass: TWtsInfoClass; var ppBuffer: Pointer; var pBytesReturned: DWORD): BOOL; stdcall;
   {$EXTERNALSYM TWTSQuerySessionInformationW}

   {$IFDEF UNICODE}
   TWTSQuerySessionInformation = function(hServer: THandle; SessionId: DWORD; WTSInfoClass: TWtsInfoClass; var ppBuffer: Pointer; var pBytesReturned: DWORD): BOOL; stdcall;
   {$EXTERNALSYM TWTSQuerySessionInformation}
   {$ELSE}
   TWTSQuerySessionInformation = function(hServer: THandle; SessionId: DWORD; WTSInfoClass: TWtsInfoClass; var ppBuffer: Pointer; var pBytesReturned: DWORD): BOOL; stdcall;
   {$EXTERNALSYM TWTSQuerySessionInformation}
   {$ENDIF}

   TWTSFreeMemory = procedure(pMemory: Pointer); stdcall;
   {$EXTERNALSYM TWTSFreeMemory}

function DoGetComputerName: string;

implementation

uses
   SysUtils;

function DoGetComputerName: string;
var
   nSize: DWORD;
   InfoClass: Pointer;
   NameLocated: Boolean;
   LibHandle: THandle;
   WTSQuerySessionInformation: TWTSQuerySessionInformation;
   WTSFreeMemory: TWTSFreeMemory;
begin
   Result := 'DEFAULT'; //locate why computername can't be readed

   //Terminal Server solution get client computer name
   @WTSQuerySessionInformation := nil;
   @WTSFreeMemory := nil;
   InfoClass := nil;
   NameLocated := false;
   LibHandle := LoadLibrary(wtsapi);
   try
      if LibHandle > 0 then
         try
            @WTSQuerySessionInformation := GetProcAddress(LibHandle, WtsFunctionName);
            if not (@WTSQuerySessionInformation = nil) then
               begin
                  NameLocated := WTSQuerySessionInformation(WTS_CURRENT_SERVER_HANDLE, WTS_CURRENT_SESSION, WTSClientName, InfoClass, nSize);

                  if NameLocated then
                     begin
                        Result := UpperCase(Trim(strPas(PChar(InfoClass))));
                        if Result = '' then
                           NameLocated := false;
                     end;
               end;

            @WTSFreeMemory := GetProcAddress(LibHandle, 'WTSFreeMemory');
            if not (@WTSFreeMemory = nil) and Assigned(Infoclass) then
               wtsFreeMemory(InfoClass);

         finally
            if not NameLocated then
               begin
                  nSize := MAX_COMPUTERNAME_LENGTH + 1;
                  SetLength(Result, nSize);
                  if GetComputerName(PChar(Result), nSize) then
                     begin
                        SetLength(Result, StrLen(PChar(Result)));
                        Result := UpperCase(Trim(Result));
                     end;
               end;
         end;
   finally
      FreeLibrary(LibHandle);
   end;
end;

end.