main.pas

在深度历险网站上发布的所有delphi程序原码。对初学delphi者很有用。

unit main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls, Registry, ExtCtrls, UrlLabel;

type
  TMSTCPType = (mtRWIN, mtTTL, mtMTUDiscovery, mtMTUBlackHole);
  
  TMainForm = class(TForm)
    Button1: TBUTTON;
    Button2: TBUTTON;
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    gbxMTU: TGroupBox;
    TabSheet2: TTabSheet;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    rbtMTUDefault: TRadioButton;
    rbtRecommand: TRadioButton;
    rbtMTUCustom: TRadioButton;
    txtMTUValue: TEdit;
    Label6: TLabel;
    Label10: TLabel;
    Button3: TBUTTON;
    TabSheet3: TTabSheet;
    TabSheet4: TTabSheet;
    lblRWINValue: TLabel;
    gbxRWIN: TGroupBox;
    rbtDefault: TRadioButton;
    rbtMultiple: TRadioButton;
    txtRWINValue: TEdit;
    rbtCustom: TRadioButton;
    gbxRecommand: TGroupBox;
    ListBox1: TListBox;
    gbxNDICache: TRadioGroup;
    gbxTTL: TRadioGroup;
    gbxMTUDetect: TGroupBox;
    cbxMTUAuto: TCheckBox;
    cbxMTUHole: TCheckBox;
    cbxDefaultMTU: TComboBox;
    tbarMultiple: TTrackBar;
    lblMultiple: TLabel;
    lbxDefaultMTUValue: TListBox;
    lblMTUValue: TLabel;
    UrlLabel1: TUrlLabel;
    UrlLabel2: TUrlLabel;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure rbtMTUDefaultClick(Sender: TObject);
    procedure txtMTUValueExit(Sender: TObject);
    procedure txtRWINValueExit(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure cbxDefaultMTUChange(Sender: TObject);
    procedure tbarMultipleChange(Sender: TObject);
    procedure rbtCustomClick(Sender: TObject);
  private
    { Private declarations }
    FMTU, RWIN, oldMTU, oldRWIN, RWINTimes: Integer;
    oldTTL, oldNDICache, oldMTUAuto, oldMTUBlackHole: Integer;

    FMTURegistryKey: string;
    
    function GetMSTCPValue(Kind: TMSTCPType): Integer;
    procedure SetMSTCPValue(Kind: TMSTCPType; const Value: Integer);
    function GetMTU: Integer;
    procedure SetMTU(const Value: Integer);
    function GetNDICache: Integer;
    procedure SetNDICache(const Value: Integer);

    procedure ShowStatus;
    procedure ShowOldValue;
    procedure UpdateLabel;
  public
    { Public declarations }
  end;

const
  MSTCPKeys: array[TMSTCPType] of string =
    ('DefaultRcvWindow', 'DefaultTTL', 'PMTUDiscovery', 'PMTUBlackHoleDetect');

var
  MainForm: TMainForm;

implementation

uses util;

{$R *.DFM}

procedure TMainForm.SetMSTCPValue(Kind: TMSTCPType; const Value: Integer);
begin
  with TRegistry.Create do
  begin
    try
      RootKey := HKEY_LOCAL_MACHINE;
      if OpenKey('System\CurrentControlSet\Services\VxD\MSTCP', True) = False then Exit;
      WriteString(MSTCPKeys[Kind], IntToStr(Value));
    finally
      CloseKey;
      Free;
    end;
  end;
end;

function TMainForm.GetMSTCPValue(Kind: TMSTCPType): Integer;
const
  bEverErrBox: Boolean = False;
var
  S: string;
begin
  Result := -1;
  
  with TRegistry.Create do
  begin
    try
      RootKey := HKEY_LOCAL_MACHINE;
      if OpenKey('System\CurrentControlSet\Services\VxD\MSTCP', False) = False then
      begin
        //