ufrmcominfo.pas

提供读取并设置计算机有关系统信息.如网卡ID,修改计算机IP子网掩码网关DNS等系统信息.

{********************************************************
  1、计算机名
  2、IP
  3、子网掩码
  4、网关
  5、DNS
*********************************************************}
unit ufrmComInfo;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, IPEdit, StdCtrls, Buttons, ExtCtrls, WinSock, ComCtrls;
  
Const
  MAX_HOSTNAME_LEN               = 128; { from IPTYPES.H }
  MAX_DOMAIN_NAME_LEN            = 128;
  MAX_SCOPE_ID_LEN               = 256;
  MAX_ADAPTER_NAME_LENGTH        = 256;
  MAX_ADAPTER_DESCRIPTION_LENGTH = 128;
  MAX_ADAPTER_ADDRESS_LENGTH     = 8;

Type
  TIPAddressString = Array[0..4*4-1] of Char;

  PIPAddrString = ^TIPAddrString;
  TIPAddrString = Record
    Next      : PIPAddrString;
    IPAddress : TIPAddressString;
    IPMask    : TIPAddressString;
    Context   : Integer;
  end;

  PFixedInfo = ^TFixedInfo;
  TFixedInfo = Record { FIXED_INFO }
    HostName         : Array[0..MAX_HOSTNAME_LEN+3] of Char;
    DomainName       : Array[0..MAX_DOMAIN_NAME_LEN+3] of Char;
    CurrentDNSServer : PIPAddrString;
    DNSServerList    : TIPAddrString;
    NodeType         : Integer;
    ScopeId          : Array[0..MAX_SCOPE_ID_LEN+3] of Char;
    EnableRouting    : Integer;
    EnableProxy      : Integer;
    EnableDNS        : Integer;
  end;

  PIPAdapterInfo = ^TIPAdapterInfo;
  TIPAdapterInfo = Record { IP_ADAPTER_INFO }
    Next                : PIPAdapterInfo;
    ComboIndex          : Integer;
    AdapterName         : Array[0..MAX_ADAPTER_NAME_LENGTH+3] of Char;
    Description         : Array[0..MAX_ADAPTER_DESCRIPTION_LENGTH+3] of Char;
    AddressLength       : Integer;
    Address             : Array[1..MAX_ADAPTER_ADDRESS_LENGTH] of Byte;
    Index               : Integer;
    _Type               : Integer;
    DHCPEnabled         : Integer;
    CurrentIPAddress    : PIPAddrString;
    IPAddressList       : TIPAddrString;
    GatewayList         : TIPAddrString;
    DHCPServer          : TIPAddrString;
    HaveWINS            : Bool;
    PrimaryWINSServer   : TIPAddrString;
    SecondaryWINSServer : TIPAddrString;
    LeaseObtained       : Integer;
    LeaseExpires        : Integer;
  end;

  TfrmComInfo = class(TForm)
    Label1: TLabel;
    edtComputer: TEdit;
    bbtnOk: TBitBtn;
    bbtnCancel: TBitBtn;
    Label6: TLabel;
    Bevel1: TBevel;
    cbxMacList: TComboBox;
    GroupBox1: TGroupBox;
    IPDNS: TIPEdit;
    rbDNSAuto: TRadioButton;
    rbDNSStatic: TRadioButton;
    GroupBox2: TGroupBox;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    IPAddr: TIPEdit;
    IPMask: TIPEdit;
    IPGateWay: TIPEdit;
    rbIPAuto: TRadioButton;
    rbIPStatic: TRadioButton;
    Memo1: TMemo;
    GroupBox3: TGroupBox;
    mmStartPage: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure bbtnCancelClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure cbxMacListChange(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure bbtnOkClick(Sender: TObject);
    procedure IPAddrFieldChange(Sender: TObject; OldField, Value: Byte);
    procedure rbIPAutoClick(Sender: TObject);
    procedure rbDNSAutoClick(Sender: TObject);
    procedure IPMaskFieldChange(Sender: TObject; OldField, Value: Byte);
    procedure IPGateWayFieldChange(Sender: TObject; OldField, Value: Byte);
    procedure IPDNSFieldChange(Sender: TObject; OldField, Value: Byte);
  private
    { Private declarations }
    procedure GetCompInfo;
    procedure GetMacList;
    procedure GetCompName;
    function GetLocalIP: string;
    procedure GetRegValue;
    procedure GetAdapterInformation;
    function GetNetworkParameters: string;
    function GetStartPage: string;
    procedure SetStartPage(APage: string);
  public
    { Public declarations }
  end;
  PCompInfo = ^TCompInfo;
  TCompInfo = Record
    MacValue    : string[20];
    IpAddress   : string[15];
    Mask        : string[15];
    GateWay     : string[15];
    Dns         : string[15];
  end;
var
  frmComInfo: TfrmComInfo;
  //aDnsList: TStrings;
  Function GetNetworkParams(FI : PFixedInfo; Var BufLen : Integer) : Integer;
           StdCall; External 'iphlpapi.dll' Name 'GetNetworkParams';

  Function GetAdaptersInfo(AI : PIPAdapterInfo; Var BufLen : Integer) : Integer;
           StdCall; External 'iphlpapi.dll' Name 'GetAdaptersInfo';

implementation
uses NB30, Registry;

{$R *.dfm}

function WinExecAndWait32(FileName:String; Visibility : 
integer):integer;
var
  zAppName:array[0..512] of char;
  zCurDir:array[0..255] of char;
  WorkDir:String;
  StartupInfo:TStartupInfo;
  ProcessInfo:TProcessInformation;
begin
  StrPCopy(zAppName,FileName);
  GetDir(0,WorkDir);
  StrPCopy(zCurDir,WorkDir);
  FillChar(StartupInfo,Sizeof(StartupInfo),#0);
  StartupInfo.cb := Sizeof(StartupInfo);

  StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
  StartupInfo.wShowWindow := Visibility;
  if not CreateProcess(nil,
    zAppName,                      { pointer to command line string }
    nil,                           { pointer to process security 
attributes }
    nil,                           { pointer to thread security 
attributes }
    false,                         { handle inheritance flag }
    CREATE_NEW_CONSOLE or          { creation flags }
    NORMAL_PRIORITY_CLASS,
    nil,                           { pointer to new environment block }
    nil,                           { pointer to current directory name }
    StartupInfo,                   { pointer to STARTUPINFO }
    ProcessInfo) then Result := -1 { pointer to PROCESS_INF }

  else begin
    WaitforSingleObject(ProcessInfo.hProcess,INFINITE);
    GetExitCodeProcess(ProcessInfo.hProcess,Dword(Result))
  end;
end;

procedure IPStrToEdit(AStr: string; AEdit: TIpEdit);
var
  sTmp: string;
  iPos: Integer;
begin
  sTmp := AStr;
  AEdit.Clear;
  {AEdit.Field0 := 0;
  AEdit.Field1 := 0;
  AEdit.Field2 := 0;
  AEdit.Field3 := 0;}
  iPos := Pos('.', sTmp);
  if iPos > 0 then
  begin
    AEdit.Field0 := StrToInt(copy(sTmp, 1, iPos - 1));
    sTmp := copy(stmp, iPos + 1, Length(sTmp) - iPos);
    iPos := Pos('.', sTmp);
  end;
  if iPos > 0 then
  begin
    AEdit.Field1 := StrToInt(copy(sTmp, 1, iPos - 1));
    sTmp := copy(stmp, iPos + 1, Length(sTmp) - iPos);
    iPos := Pos('.', sTmp);
  end;
  if iPos > 0 then
  begin
    AEdit.Field2 := StrToInt(copy(sTmp, 1, iPos - 1));
    sTmp := copy(stmp, iPos + 1, Length(sTmp) - iPos);
    iPos := Pos('.', sTmp);
  end;
  if sTmp <> '' then
    AEdit.Field3 := StrToInt(sTmp);    
end;

function GetAdapterInfo(Adapter_num: Char; var AMac_Addr: string): Boolean;
type
  TStat = record
    Adapt: TAdapterStatus;
    Name_Buffer: TNameBuffer;
  end;
var
  P: PNCB;
  Adapter: TStat;
  Temp: Char;
begin
  New(P);
  try
  // 重置网卡，以便我们可以查询
    FillChar(P^, SizeOf(TNcb), #0);
    P^.ncb_command := Chr(NCBRESET);
    P^.ncb_lana_num := adapter_num;
    Temp := Netbios(P);
    if Temp <> Chr(NRC_GOODRET) then
    begin
      AMac_Addr := 'bad (NCBRESET): ' + P^.Ncb_retcode;
      Result := False;
      Exit;
    end;
    FillChar(P^, SizeOf(TNcb), #0);
    P^.ncb_command := Chr(NCBASTAT);
    P^.ncb_lana_num := Adapter_num;
    P^.ncb_callname := '*';
    FillChar(Adapter, SizeOf(TStat), #0);
    P^.ncb_buffer := @Adapter;
    P^.ncb_length := Sizeof(Adapter);
  // 取得网卡的信息，并且如果网卡正常工作的话，返回标准的冒号分隔格式。
    Temp := Netbios(P);
    if Temp = #0 then
    begin
      AMac_Addr := Format('%0.2x-%0.2x-%0.2x-%0.2x-%0.2x-%0.2x', [Ord(Adapter.adapt.adapter_address[0]),
        Ord(Adapter.adapt.adapter_address[1]), Ord(Adapter.adapt.adapter_address[2]),
          Ord(Adapter.adapt.adapter_address[3]), Ord(Adapter.adapt.adapter_address[4]),
          Ord(Adapter.adapt.adapter_address[5])]);
    end;
  finally
    Dispose(P);
  end;
  Result := True;
end;


{ TfrmComInfo }

procedure TfrmComInfo.GetCompInfo;
begin
  GetCompName;
  GetAdapterInformation;
  mmStartPage.Text := GetStartPage;
end;

procedure TfrmComInfo.GetMacList;
var
  AdapterList: TLanaEnum;
  Ncb: PNcb;
  I: Integer;
  Mac_addr: string;
begin
  New(Ncb);
  try
  // 取得网卡列表
    FillChar(Ncb^, SizeOf(TNcb), #0);
    FillChar(AdapterList, Sizeof(AdapterList), #0);
    Ncb.ncb_command := Chr(NCBENUM);
    Ncb.ncb_buffer := @AdapterList;
    Ncb.ncb_length := Sizeof(AdapterList);
    Netbios(Ncb);
    cbxMacList.Clear;
    for I := 0 to Ord(AdapterList.Length) - 1 do
    begin
      if GetAdapterInfo(AdapterList.lana[i], Mac_addr) then
        cbxMacList.Items.Add(Mac_addr)
      else
      begin
        cbxMacList.Items.Add('读取 网卡ID 失败! 请确认是否安装 NetBIOS 协议?');
        Break;
      end;
    end;
  finally
    Dispose(Ncb);
  end;
end;

procedure TfrmComInfo.FormCreate(Sender: TObject);
begin
  //aDnsList:=TStringList.Create;
  GetCompInfo;
end;

procedure TfrmComInfo.GetCompName;
var
  ComputerName: array[0..MAX_COMPUTERNAME_LENGTH+1] of char;  // holds the name
  Size: DWORD;                                              // holds the size
begin
  {initialize the computer name size variable}
  Size := MAX_COMPUTERNAME_LENGTH+1;
  {retrieve the computer name}
  if GetComputerName(ComputerName, Size) then
    edtComputer.Text := StrPas(Computername);
end;

procedure TfrmComInfo.bbtnCancelClick(Sender: TObject);
begin
  close;
end;

function TfrmComInfo.GetLocalIP: string;
type
  TaPInAddr = array [0..10] of PInAddr;
  PaPInAddr = ^TaPInAddr;
var
  phe : PHostEnt;
  pptr : PaPInAddr;
  Buffer : array [0..63] of char;
  I : Integer;
  GInitData : TWSADATA;
begin
  WSAStartup($101, GInitData);
  Result := '';
  GetHostName(Buffer, SizeOf(Buffer));
  phe :=GetHostByName(buffer);
  if phe = nil then Exit;
  pptr := PaPInAddr(Phe^.h_addr_list);
  I := 0;
  while pptr^[I] <> nil do begin
    result:=StrPas(inet_ntoa(pptr^[I]^));
    Inc(I);
  end;
  WSACleanup;
end;

procedure TfrmComInfo.GetRegValue;
var
  sRet: string;
begin
  with TRegistry.Create do
  begin
    RootKey := HKEY_LOCAL_MACHINE;
    if OpenKey('SYSTEM\CurrentControlSet\Services\Tcpip\Parameters\Interfaces\{A23487EA-E963-4AB0-BB4D-E24A26007F4C}', False) then
    begin
      //sRet := ReadString('IPAddress');
      //IPStrToEdit(sRet, IPAddr);
      ////sRet := ReadString('SubnetMask');
      //IPStrToEdit(sRet, IPMask);
      //sRet := ReadString('DefaultGateway');
      //IPStrToEdit(sRet, IPGateWay);
      sRet := ReadString('NameServer');
      IPStrToEdit(sRet, IPDNS);