main.pas

一个Delphi的Telnet程序示例

{ ****************************************************** }
{ * Telnet main form:                                  * }
{ *   Remove TOopsconsole and use TOopsTelnet now!     * }
{ *                                                    * }
{ * Copyright (C)1995-2001,OopsWare Corp,China. Oops!  * }
{ * E-mail: [e-mail]               * }
{ *   Web : oopsware.qzone.com                         * }
{ ****************************************************** }

unit Main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Menus, ExtCtrls, StdCtrls, ScktComp, OopsTelnet;

const
  RegPath = 'Software\OopsWare\简体中文 Telnet';
  FormPosTop  = '窗口位置“上”';
  FormPosLeft = '窗口位置“左”';
  AppName = '简体中文 Telnet';
  MachineName = '主机地址_';
  RegCount = '历史数目';
  TermCaretStyle = '终端光标';
  CaretStyleLine = '线状';
  CaretStyleBlock = '块状';
  RegFont = '字体';
  RegFontSize = '字体大小';
  RegFontCharset = '字符集';
  LastLog = '日志文件';
  DefaultHostName = 'localhost';
  DefaultTermType = 'ansi';

type
  TTelnetForm = class(TForm)
    TelnetMainMenu: TMainMenu;
    miConnect: TMenuItem;
    miEdit: TMenuItem;
    miConnectOpen: TMenuItem;
    miConnectClose: TMenuItem;
    miConnectLine: TMenuItem;
    miConnectExit: TMenuItem;
    miTerm: TMenuItem;
    miHelp: TMenuItem;
    miHelpContents: TMenuItem;
    miHelpLine: TMenuItem;
    miHelpAbort: TMenuItem;
    miEditCopy: TMenuItem;
    miEditPaste: TMenuItem;
    miEditLine: TMenuItem;
    miEditSelectAll: TMenuItem;
    miTermCaret: TMenuItem;
    miTermCaretLine: TMenuItem;
    miTermCaretBlock: TMenuItem;
    miTermCaretFont: TMenuItem;
    FontDialog: TFontDialog;
    miTermLine: TMenuItem;
    miTermStartLog: TMenuItem;
    miTermStopLog: TMenuItem;
    OopsTelnet: TOopsTelnet;
    SaveDialog: TSaveDialog;
    procedure miConnectOpenClick(Sender: TObject);
    procedure miConnectCloseClick(Sender: TObject);
    procedure miHelpAbortClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure miTermCaretNoneClick(Sender: TObject);
    procedure miTermCaretFontClick(Sender: TObject);
    procedure miConnectExitClick(Sender: TObject);
    procedure miEditClick(Sender: TObject);
    procedure miEditCopyClick(Sender: TObject);
    procedure miEditPasteClick(Sender: TObject);
    procedure miEditSelectAllClick(Sender: TObject);
    procedure OopsTelnetConnect(Sender: TObject; Socket: TCustomWinSocket);
    procedure OopsTelnetDisconnect(Sender: TObject; Socket: TCustomWinSocket);
    procedure OopsTelnetError(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure miTermClick(Sender: TObject);
    procedure miTermStartLogClick(Sender: TObject);
    procedure miTermStopLogClick(Sender: TObject);
  private
    CurHost: string;
    CurPort: Integer;
    CurTerm: string;
    MaxRegs: Integer;
    UserStop: Boolean;
    procedure HostMenuClick(Sender: TObject);
    function CanOpenNew: Boolean;
    procedure UpdateMenuList;
  public
    procedure Init;
    procedure OpenHost(hName: string);
    procedure RecOpenned;
  end;

procedure DecodeIP(inIP: string; var outIP, outTp: string);

var
  TelnetForm: TTelnetForm;
  HostList: TStringList;

implementation

{$R *.DFM}

uses Registry, Clipbrd, OpenHosts, About;

procedure DecodeIP(inIP: string; var outIP, outTp: string);
var i, j: Integer;
begin
  inIP:=Trim(inIP);
  outIP:=''; outTp:=''; j:=0;
  for i:=1 to Length(inIP) do begin
    if inIP[i]=')' then break;
    if j=1 then j:=2;
    if inIP[i]='(' then j:=1;
    if j=0 then outIP:=outIP+inIP[i];
    if j=2 then outTp:=outTp+inIP[i];
  end;
end;

procedure TelnetErrorProc(ErrorCode: Integer);
begin
  case ErrorCode of
   10049, 10060, 10061, 10065:
       MessageBox(TelnetForm.Handle, @('无法连接到主机“'+TelnetForm.CurHost+'”')[1], '连接失败', MB_ICONSTOP);
  else MessageBox(TelnetForm.Handle, @('Unknown Error with code :'+IntToStr(ErrorCode))[1], '错误', MB_ICONSTOP);
  end;
end;

procedure TTelnetForm.Init;
var Reg: TRegistry;
    tmpvar, tmpcode: Integer;
    tmpstr: string;
begin
  HostList:= TStringList.Create;
  CurPort:=23;
  Reg:=TRegistry.Create;
  Reg.RootKey:=HKEY_CURRENT_USER;
  Reg.OpenKey(RegPath, True);
  Val(Reg.ReadString(FormPosTop), tmpvar, tmpcode);
  if tmpcode=0 then Top:=tmpvar;
  Val(Reg.ReadString(FormPosLeft), tmpvar, tmpcode);
  if tmpcode=0 then Left:=tmpvar;
  Val(Reg.ReadString(RegCount), MaxRegs, tmpcode);
  if tmpcode<>0 then begin
    MaxRegs:=4;
    Reg.WriteString(RegCount, IntToStr(MaxRegs));
  end else begin
    for tmpvar:=1 to MaxRegs do begin
      tmpstr:=Trim(Reg.ReadString(MachineName+IntToStr(tmpvar)));
      if tmpstr<>'' then HostList.Add(tmpstr);
    end;
    UpdateMenuList;
  end;
  tmpstr:=Reg.ReadString(TermCaretStyle); { 光标类型 }
  if tmpstr=CaretStyleLine then begin
    OopsTelnet.CaretStyle:=csLine;
    miTermCaretLine.Checked:=True;
  end;
  if tmpstr=CaretStyleBlock then begin
    OopsTelnet.CaretStyle:=csBlock;
    miTermCaretBlock.Checked:=True;
  end;
  FontDialog.Font.Name:=Reg.ReadString(RegFont); { 字体 }
  Val(Reg.ReadString(RegFontSize), tmpvar, tmpcode);
  if tmpcode=0 then FontDialog.Font.Size:=tmpvar;
  Val(Reg.ReadString(RegFontCharset), tmpvar, tmpcode);
  if tmpcode=0 then FontDialog.Font.Charset:=tmpvar;
  OopsTelnet.Font.Assign(FontDialog.Font);
  tmpstr:=Trim(Reg.ReadString(LastLog));
  if tmpstr='' then begin
    SaveDialog.InitialDir:=ExtractFileDir(Application.ExeName);
    SaveDialog.FileName:=SaveDialog.InitialDir+'\Telnet.log';
  end else begin
    SaveDialog.InitialDir:=ExtractFileDir(tmpstr);
    SaveDialog.FileName:=tmpstr;
  end;
  Reg.Free;
  Update;
  SetErrorProc(TelnetErrorProc);
  Application.ProcessMessages;
end;

procedure TTelnetForm.miConnectOpenClick(Sender: TObject);
begin
  if not CanOpenNew then Exit;
  if HostList.Count>0 then DecodeIP(HostList[0], CurHost, CurTerm);
  if ConnectToHost(CurHost, CurTerm)<>ID_OK then Exit;
  OopsTelnet.TermType:=CurTerm;
  OopsTelnet.Open(CurHost, CurPort);
end;

procedure TTelnetForm.HostMenuClick(Sender: TObject);
var i: integer;
begin { 用历史菜单打开连接 }
  if not CanOpenNew then Exit;
  with Sender as TMenuItem do i:=Tag;
  if (i<1)or(i>HostList.Count) then Exit;
  DecodeIP(HostList[i-1], CurHost, CurTerm);
  OopsTelnet.TermType:=CurTerm;
  OopsTelnet.Open(CurHost, CurPort);
end;

procedure TTelnetForm.OpenHost(hName: string);
begin { 命令行打开连接 }
  CurHost:=Trim(hName);
  CurTerm:=DefaultTermType;
  OopsTelnet.TermType:=CurTerm;
  OopsTelnet.Open(CurHost, CurPort);
end;

procedure TTelnetForm.RecOpenned;
var i: Integer;
    s: string;
begin  { 记录成功连接 }
  miConnectOpen.Enabled:=False;
  miConnectClose.Enabled:=True;
  s:=CurHost+'('+OopsTelnet.TermType+')';
  i:=HostList.IndexOf(s);
  if i>=0 then HostList.delete(i);
  HostList.Insert(0, s);
  UpdateMenuList;
end;

procedure TTelnetForm.miConnectCloseClick(Sender: TObject);
begin { 断开连接 }
  if OopsTelnet.Active then begin
    UserStop:=True;
    OopsTelnet.Close;
  end;
end;

function TTelnetForm.CanOpenNew: Boolean;
begin
  Result:=True;
  if OopsTelnet.Active then begin
    if MessageBox(Handle, '连接新主机之前，断开当前的连接吗？', '询问', MB_ICONQUESTION+MB_YESNO)<>ID_YES then
    begin Result:=False; Exit end;
    UserStop:=True;
    OopsTelnet.Close;
  end;
end;

procedure TTelnetForm.UpdateMenuList;
var mchmi: TMenuItem;
    tmpvar: Integer;
begin { 更新历史菜单 }
  if HostList.Count>MaxRegs then HostList.Delete(MaxRegs);
  for tmpvar:=(miConnect.Count-1) downto 4 do miConnect.Delete(tmpvar);
  if HostList.Count>0 then begin
    mchmi:=TMenuItem.Create(Self);
    mchmi.Caption:='-';
    miConnect.Add(mchmi);
    for tmpvar:=0 to HostList.Count-1 do begin
      mchmi:=TMenuItem.Create(Self);
      mchmi.Caption:='&'+IntToStr(tmpvar+1)+' '+HostList[tmpvar];
      mchmi.OnClick:=HostMenuClick;
      mchmi.Tag:=tmpvar+1;
      miConnect.Add(mchmi);
    end;
  end;
end;

procedure TTelnetForm.miHelpAbortClick(Sender: TObject);
begin { 关于 }
  ShowAbout;
end;

procedure TTelnetForm.FormClose(Sender: TObject; var Action: TCloseAction);
var Reg: TRegistry;
    i: integer;
begin  { 退出 }
  Reg:=TRegistry.Create;
  Reg.RootKey:=HKEY_CURRENT_USER;
  Reg.OpenKey(RegPath, True);
  Reg.WriteString(FormPosTop, IntToStr(Top));
  Reg.WriteString(FormPosLeft, IntToStr(Left));
  for i:=0 to HostList.Count-1 do
    Reg.WriteString(MachineName+IntToStr(i+1), HostList[i]);
  Reg.Free;
  HostList.Free;
end;

procedure TTelnetForm.miTermCaretNoneClick(Sender: TObject);
var Reg: TRegistry;
begin { 光标类型选择 }
  with Sender as TMenuItem do begin
    Checked:=True;
    case Tag of
     1: OopsTelnet.CaretStyle:=csLine;
     2: OopsTelnet.CaretStyle:=csBlock;
    end;
    Reg:=TRegistry.Create;
    Reg.RootKey:=HKEY_CURRENT_USER;
    Reg.OpenKey(RegPath, True);
    case Tag of
     1: Reg.WriteString(TermCaretStyle, CaretStyleLine);
     2: Reg.WriteString(TermCaretStyle, CaretStyleBlock);
    end;
    Reg.Free;
  end;
end;

procedure TTelnetForm.miTermCaretFontClick(Sender: TObject);
var Reg: TRegistry;
begin { 字体设置 }
  FontDialog.Font.Assign(OopsTelnet.Font);
  FontDialog.Font.Style:=[];
  FontDialog.Font.Color:=clWindowText;
  if not FontDialog.Execute then Exit;
  FontDialog.Font.Style:=[];
  FontDialog.Font.Color:=clWindowText;
  OopsTelnet.Font.Assign(FontDialog.Font);
  Reg:=TRegistry.Create;
  Reg.RootKey:=HKEY_CURRENT_USER;
  Reg.OpenKey(RegPath, True);
  Reg.WriteString(RegFont, OopsTelnet.Font.Name);
  Reg.WriteString(RegFontSize, IntToStr(OopsTelnet.Font.Size));
  Reg.WriteString(RegFontCharset, IntToStr(OopsTelnet.Font.Charset));
  Reg.Free;
end;

procedure TTelnetForm.miConnectExitClick(Sender: TObject);
begin Close end;

procedure TTelnetForm.miEditClick(Sender: TObject);
begin
  miEditCopy.Enabled:=OopsTelnet.Selected;
  miEditPaste.Enabled:=Clipboard.HasFormat(CF_TEXT);
end;

procedure TTelnetForm.miEditCopyClick(Sender: TObject);
begin
  OopsTelnet.CopyToClipboard;
end;

procedure TTelnetForm.miEditPasteClick(Sender: TObject);
begin
  OopsTelnet.PasteFromClipboard;
end;

procedure TTelnetForm.miEditSelectAllClick(Sender: TObject);
begin
  OopsTelnet.SelectAll;
end;

procedure TTelnetForm.OopsTelnetConnect(Sender: TObject; Socket: TCustomWinSocket);
begin
  Caption:=AppName + ' - '+CurHost;
  RecOpenned;
end;

procedure TTelnetForm.OopsTelnetDisconnect(Sender: TObject; Socket: TCustomWinSocket);
begin
  if not UserStop then
    MessageBox(Handle, '到主机的连接丢失。', AppName, 0);
  Caption:=AppName+' - (无)';
  UserStop:=False;
  miConnectOpen.Enabled:=True;
  miConnectClose.Enabled:=False;
end;

procedure TTelnetForm.OopsTelnetError(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; var ErrorCode: Integer);
begin
  TelnetErrorProc(ErrorCode);
  ErrorCode:=0;
end;

procedure TTelnetForm.miTermClick(Sender: TObject);
begin
  miTermStartLog.Enabled:=not OopsTelnet.Logging;
  miTermStopLog.Enabled:=OopsTelnet.Logging;
end;

procedure TTelnetForm.miTermStartLogClick(Sender: TObject);
var Reg: TRegistry;
begin
  if SaveDialog.Execute then begin
    OopsTelnet.StartLog(SaveDialog.FileName);
    Reg:=TRegistry.Create;
    Reg.RootKey:=HKEY_CURRENT_USER;
    Reg.OpenKey(RegPath, True);
    Reg.WriteString(LastLog, SaveDialog.FileName);
    Reg.Free;
  end;
end;

procedure TTelnetForm.miTermStopLogClick(Sender: TObject);
begin
  OopsTelnet.StopLog;
end;

end.