unit_frmmain.pas

端口服务程序（ServerService.rar）及常用网络函数及加解密

unit Unit_FrmMain;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, ShellApi, Graphics,
Controls, Forms, Dialogs, ExtCtrls, StdCtrls, WinInet,
DateUtils, IniFiles,ImgList,DES,ComCtrls,
MSNPopUp,WinTypes, WSocket,WinSock, WSocketS;

const WM_TrayIcon = WM_USER + 1234;
const WM_NID=WM_USER+1000    ;
const WM_APPSTARTUP = WM_USER + 1;
type

  TTcpSrvClient = class(TWSocketClient)
  public
    RcvdLine    : String;
    ConnectTime : TDateTime;
  end;

TFrmMain = class(TForm)
    Edit4: TEdit;
    Button2: TButton;
    MSNPop: TMSNPopUp;
    Timer1: TTimer;
    Image3: TImage;
    DisplayMemo: TMemo;
    StartButton: TButton;
    DataAvailableLabel: TLabel;
    Timer2: TTimer;
    WSocketServer1: TWSocketServer;

    procedure FormCreate(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure FormDestroy(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure Timer2Timer(Sender: TObject);
    procedure WSocketServer1ClientConnect(Sender: TObject;Client: TWSocketClient; Error: Word);
    procedure WSocketServer1BgException(Sender: TObject; E: Exception;var CanClose: Boolean);
    procedure WSocketServer1ClientDisconnect(Sender: TObject;Client: TWSocketClient; Error: Word);
    procedure ClientBgException(Sender       : TObject;
                                E            : Exception;
                                var CanClose : Boolean);


private
{ Private declarations }

IconData: TNotifyIconData;
//FServerAddr  : TInAddr;


procedure AddIconToTray;
procedure DelIconFromTray;
procedure TrayIconMessage(var Msg: TMessage); message WM_TrayIcon;
procedure SysButtonMsg(var Msg: TMessage); message WM_SYSCOMMAND;
procedure Display(Msg : String);
procedure WMAppStartup(var Msg: TMessage); message WM_APPSTARTUP;
procedure ClientDataAvailable(Sender: TObject; Error: Word);
procedure ProcessData(Client : TTcpSrvClient);
procedure ClientLineLimitExceeded(Sender        : TObject;
                                      Cnt           : LongInt;
                                      var ClearData : Boolean);

procedure DoSomething(Cmd : string);
procedure AdjustToken();
function  IsNT: Boolean;
public
{ Public declarations }

end;

var
FrmMain: TFrmMain;
gbCanClose: Boolean;
Port:String;

implementation

{$R *.dfm}

procedure TFrmMain.FormCreate(Sender: TObject);
var
 iFile : TiniFile;
 fName : String;
begin
    DisplayMemo.Lines.Clear ;
  //  memo1.Lines.Add('正在加载配置信息...');

    fName :=ExtractFilePath(Paramstr(0)) + 'JKHService.ini';

    FormStyle := fsStayOnTop;
    SetWindowLong(Application.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW);
    gbCanClose := False;
    Timer1.Interval := 1000;
    Timer1.Enabled := True;

    iFile := nil;
    try
      try
        iFile:=  TIniFile.Create(fName);//fName   :Ini   文件
        port := iFile.ReadString('Server','port','8600') ;

        except
          DisplayMemo.Lines.Add('获取相关配置信息错误');
        end;
    finally
        iFile.Free;
    end ;

end;


procedure TFrmMain.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
   CanClose := gbCanClose;
   if not CanClose then
   begin
        Hide;
   end;
end;

procedure TFrmMain.FormDestroy(Sender: TObject);
begin
  Timer1.Enabled := False;
  DelIconFromTray;
end;

procedure TFrmMain.AddIconToTray;
begin

    ZeroMemory(@IconData, SizeOf(TNotifyIconData));
    IconData.uID := 1;
    IconData.cbSize := SizeOf(TNotifyIconData);
    IconData.Wnd := Handle;
    IconData.uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
    IconData.uCallbackMessage := WM_TrayIcon;
    IconData.hIcon := Image3.Picture.Icon.Handle ;

    if not Shell_NotifyIcon(NIM_modify,@IconData) then
      Shell_NotifyIcon(NIM_ADD, @IconData);
 //   visible:=true;
end;


procedure TFrmMain.DelIconFromTray;
begin
  Shell_NotifyIcon(NIM_DELETE, @IconData);
end;

procedure TFrmMain.SysButtonMsg(var Msg: TMessage);
begin
   if (Msg.wParam = SC_CLOSE) or (Msg.wParam = SC_MINIMIZE) then
   begin
        Hide;
   end
   else inherited; // 执行默认动作
end;

procedure TFrmMain.TrayIconMessage(var Msg: TMessage);
begin
   if (Msg.LParam = WM_LBUTTONDBLCLK) then
   BEGIN
      Show();
   END;
end;

procedure TFrmMain.Timer1Timer(Sender: TObject);
begin
    AddIconToTray;
end;

procedure TFrmMain.Timer2Timer(Sender: TObject);
begin
    WSocketServer1.Proto       := 'tcp';         { Use TCP protocol  }
    WSocketServer1.Port        := Port;      { Use telnet port   }
    WSocketServer1.Addr        := '0.0.0.0';     { Use any interface }
    WSocketServer1.ClientClass := TTcpSrvClient; { Use our component }

    if WSocketServer1.State = wsClosed then
    begin
         WSocketServer1.Listen;                       { Start litening    }
         Display('等待客户端连接...');
    end;
end;

procedure TFrmMain.Display(Msg : String);
var
    I : Integer;
begin
    DisplayMemo.Lines.BeginUpdate;
    try
        if DisplayMemo.Lines.Count > 200 then begin
            for I := 1 to 50 do
                DisplayMemo.Lines.Delete(0);
        end;
        DisplayMemo.Lines.Add(Msg);
    finally
        DisplayMemo.Lines.EndUpdate;
        SendMessage(DisplayMemo.Handle, EM_SCROLLCARET, 0, 0);
    end;
end;
procedure TFrmMain.WSocketServer1ClientConnect(Sender: TObject;
  Client: TWSocketClient; Error: Word);
begin
    with Client as TTcpSrvClient do begin
        Display('客户端连接.' +
                ' 远程: ' + PeerAddr + '/' + PeerPort +
                ' 本地: '  + GetXAddr + '/' + GetXPort);
        Display('目前共有:' +
                IntToStr(TWSocketServer(Sender).ClientCount) +
                ' 个客户端正在连接.');
        LineMode            := TRUE;
        LineEdit            := TRUE;
        LineLimit           := 80; { Do not accept long lines }
        OnDataAvailable     := ClientDataAvailable;
        OnLineLimitExceeded := ClientLineLimitExceeded;
        OnBgException       := ClientBgException;
        ConnectTime         := Now;
    end;

end;

procedure TFrmMain.WSocketServer1BgException(Sender: TObject; E: Exception;
  var CanClose: Boolean);
begin
    Display('Server exception occured: ' + E.ClassName + ': ' + E.Message);
    CanClose := FALSE;  { Hoping that server will still work ! }

end;

procedure TFrmMain.WSocketServer1ClientDisconnect(Sender: TObject;
  Client: TWSocketClient; Error: Word);
begin
    with Client as TTcpSrvClient do begin
        Display('客户端退出: ' + PeerAddr + '   ' +
                ',在线时间: ' + FormatDateTime('hh:nn:ss',
                Now - ConnectTime));
        Display('目前共有：' +
                IntToStr(TWSocketServer(Sender).ClientCount - 1) +
                ' 个客户端正在连接.');
    end;

end;

procedure TFrmMain.ProcessData(Client : TTcpSrvClient);
var
    I       : Integer;
    AClient : TTcpSrvClient;
begin
    { We could replace all those CompareText with a table lookup }
    DataAvailableLabel.caption := Client.RcvdLine ;
    
    if CompareText(Client.RcvdLine, 'help') = 0 then
        Client.SendStr('命令:' + #13#10 +
                       '  exit' + #13#10 +
                       '  who' + #13#10 +
                       '  time' + #13#10 +
                       '  exception' + #13#10)
    else if CompareText(Client.RcvdLine, 'exit') = 0 then
        Client.CloseDelayed
    else if CompareText(Client.RcvdLine, 'time') = 0 then
        Client.SendStr(DateTimeToStr(Now) + #13#10)
    else if CompareText(Client.RcvdLine, 'who') = 0 then begin
        Client.SendStr('目前共有：' + IntToStr(WSocketServer1.ClientCount) +
                       ' 已连接用户:' + #13#10);
        for I := WSocketServer1.ClientCount - 1 downto 0 do begin
            AClient := TTcpSrvClient(WSocketServer1.Client[I]);
            Client.SendStr(AClient.PeerAddr + ':' + AClient.GetPeerPort + ' ' +
                           DateTimeToStr(AClient.ConnectTime) + #13#10);
        end;
    end
    else if CompareText(Client.RcvdLine, 'exception') = 0 then
        { This will trigger a background exception for client }
        PostMessage(Client.Handle, WM_TRIGGER_EXCEPTION, 0, 0)
//    else if CompareText(Client.RcvdLine, 'shutdown') = 0 then
//      Client.SendStr('shutdown: ''' + Client.RcvdLine + 'shutdown' + #13#10)
    else
        if Client.State = wsConnected then
        begin
            Client.SendStr('未知命令: ''' + Client.RcvdLine + '''' + #13#10);
            dosomething(Client.RcvdLine);
        end;
end;
procedure TFrmMain.dosomething(Cmd : string);
begin
  if CompareText(Cmd, 'shutdownS') = 0 then
   begin
       MSNPop.text := Cmd;
       MSNPop.ShowPopUp ;
     {关机}
       if IsNT then
         begin
            AdjustToken;
            ExitWindowsEx(EWX_FORCE or EWX_POWEROFF, 0 );
            Exit;
         end else
           begin
             ExitWindowsEx(EWX_SHUTDOWN or EWX_FORCE, 0 );
             Exit;
           end;  //暴力关闭计算机!
     Exit;
  end
  else if CompareText(Cmd, 'shutdownR') = 0  then
   begin     {重启计算机}
       MSNPop.text := Cmd;
       MSNPop.ShowPopUp ;
       if IsNT then
         begin
            AdjustToken;
            ExitWindowsEx(EWX_REBOOT or EWX_FORCE, 0 );
            Exit;
         end else
           begin
             ExitWindowsEx(EWX_REBOOT or EWX_FORCE, 0 );
             Exit;
           end;  //暴力重启计算机!
     Exit;
  end;

end;


{------------------------------------}
procedure TFrmMain.AdjustToken();
var
   currToken:THandle;
   prevState,newState:TTokenPrivileges;
   prevStateLen:DWORD;
   uid:TLargeInteger;
begin
    OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, currToken);
    LookupPrivilegeValue(nil, 'SeShutdownPrivilege',uid);
    newState.PrivilegeCount:=1;
    newState.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
    newState.Privileges[0].Luid := uid;
    windows.AdjustTokenPrivileges(currToken, False, newState, sizeof(TTokenPrivileges),prevState, 
prevStateLen);
end;

{-----------------------------------}
function TFrmMain.IsNT: Boolean;
var
  OSVersionInfo: TOSVersionInfo;
begin
  OSVersionInfo.dwOSVersionInfoSize := SizeOf(OSVersionInfo);
  GetVersionEx(OSVersionInfo);
  if OSVersionInfo.dwPlatformId = VER_PLATFORM_WIN32_NT then
    Result := True
  else
    Result := False;
end;

procedure TFrmMain.WMAppStartup(var Msg: TMessage);
begin
    WSocketServer1.Proto       := 'tcp';         { Use TCP protocol  }
    WSocketServer1.Port        := Port ;      { Use telnet port   }
    WSocketServer1.Addr        := '0.0.0.0';     { Use any interface }
    WSocketServer1.ClientClass := TTcpSrvClient; { Use our component }
    WSocketServer1.Listen;                       { Start litening    }
    Display('等待客户端连接...');
end;

procedure TFrmMain.ClientDataAvailable(
    Sender : TObject;
    Error  : Word);
begin
    with Sender as TTcpSrvClient do begin
        RcvdLine := ReceiveStr;
        { Remove trailing CR/LF }
        while (Length(RcvdLine) > 0) and
              (RcvdLine[Length(RcvdLine)] in [#13, #10]) do
            RcvdLine := Copy(RcvdLine, 1, Length(RcvdLine) - 1);
        Display('从 ' + GetPeerAddr + ' 收到: ''' + RcvdLine + '''');
        ProcessData(Sender as TTcpSrvClient);
    end;
end;
procedure TFrmMain.ClientLineLimitExceeded(
    Sender        : TObject;
    Cnt           : LongInt;
    var ClearData : Boolean);
begin
    with Sender as TTcpSrvClient do begin
        Display('Line limit exceeded from ' + GetPeerAddr + '. Closing.');
        ClearData := TRUE;
        Close;
    end;
end;

procedure TFrmMain.ClientBgException(
    Sender       : TObject;
    E            : Exception;
    var CanClose : Boolean);
begin
    Display('Client exception occured: ' + E.ClassName + ': ' + E.Message);
    CanClose := TRUE;   { Goodbye client ! }
end;

end.