ufrmcominfo.pas

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

    end;
  end;
end;

procedure TfrmComInfo.GetAdapterInformation;
Var
  AI,Work : PIPAdapterInfo;
  Size    : Integer;
  Res     : Integer;
  I       : Integer;
  compInfo: PCompInfo;
  Function MACToStr(ByteArr : PByte; Len : Integer) : String;
  Begin
    Result := '';
    While (Len > 0) do Begin
      Result := Result+IntToHex(ByteArr^,2)+'-';
      ByteArr := Pointer(Integer(ByteArr)+SizeOf(Byte));
      Dec(Len);
    End;
    SetLength(Result,Length(Result)-1); { remove last dash }
  End;

  Function GetAddrString(Addr : PIPAddrString) : String;
  Begin
    Result := '';
    if Addr <> nil then
      Result := Addr^.IPAddress;
    //While (Addr <> nil) do Begin
    //  Result := Result+'A: '+Addr^.IPAddress+' M: '+Addr^.IPMask+#13;
    //  Addr := Addr^.Next;
    //End;
  End;

  function GetMaskString(Addr: PIPAddrString): string;
  begin
    Result := '';
    if Addr <> nil then
      Result := Addr^.IPMask;
  end;
  Function TimeTToDateTimeStr(TimeT : Integer) : String;
  Const UnixDateDelta = 25569; { days between 12/31/1899 and 1/1/1970 }
  Var
    DT  : TDateTime;
    TZ  : TTimeZoneInformation;
    Res : DWord;

  Begin
    If (TimeT = 0) Then Result := ''
    Else Begin
      { Unix TIME_T is secs since 1/1/1970 }
      DT := UnixDateDelta+(TimeT / (24*60*60)); { in UTC }
      { calculate bias }
      Res := GetTimeZoneInformation(TZ);
      If (Res = TIME_ZONE_ID_INVALID) Then RaiseLastWin32Error;
      If (Res = TIME_ZONE_ID_STANDARD) Then Begin
        DT := DT-((TZ.Bias+TZ.StandardBias) / (24*60));
        Result := DateTimeToStr(DT)+' '+WideCharToString(TZ.StandardName);
      End
      Else Begin { daylight saving time }
        DT := DT-((TZ.Bias+TZ.DaylightBias) / (24*60));
        Result := DateTimeToStr(DT)+' '+WideCharToString(TZ.DaylightName);
      End;
    End;
  End;

begin
  Size := 5120;
  GetMem(AI,Size);
  Res := GetAdaptersInfo(AI,Size);
  If (Res <> ERROR_SUCCESS) Then Begin
    SetLastError(Res);
    RaiseLastWin32Error;
  End;
  //With Info.Lines do Begin
    Work := AI;
    I := 1;
    Repeat
      new(compInfo);
      compInfo^.MacValue := MACToStr(@Work^.Address,Work^.AddressLength);
      rbIPAuto.Checked := (Work^.DHCPEnabled = 1);
      rbIPStatic.Checked := (Work^.DHCPEnabled = 0);
      if Work^.DHCPEnabled = 0 then
      begin
        compInfo^.IpAddress := GetAddrString(@Work^.IPAddressList);
        compInfo^.Mask := GetMaskString(@Work^.IPAddressList);
        compInfo^.GateWay := GetAddrString(@Work^.GatewayList);
      end
      else
      begin
        compInfo^.IpAddress := '';
        compInfo^.Mask := '';
        compInfo^.GateWay := '';
      end;
      compInfo^.Dns := GetNetworkParameters;
      {Add('');
      Add('Adapter '+IntToStr(I));
      Add('  ComboIndex: '+IntToStr(Work^.ComboIndex));
      Add('  Adapter name: '+Work^.AdapterName);
      Add('  Description: '+Work^.Description);
      Add('  Adapter address: '+MACToStr(@Work^.Address,Work^.AddressLength));
      Add('  Index: '+IntToStr(Work^.Index));
      Add('  Type: '+IntToStr(Work^._Type));
      Add('  DHCP: '+IntToStr(Work^.DHCPEnabled));
      Add('  Current IP: '+GetAddrString(Work^.CurrentIPAddress));
      Add('  IP addresses: '+GetAddrString(@Work^.IPAddressList));
      Add('  Gateways: '+GetAddrString(@Work^.GatewayList));
      Add('  DHCP servers: '+GetAddrString(@Work^.DHCPServer));
      Add('  Has WINS: '+IntToStr(Integer(Work^.HaveWINS)));
      Add('  Primary WINS: '+GetAddrString(@Work^.PrimaryWINSServer));
      }//Add('  Secondary WINS: '+GetAddrString(@Work^.SecondaryWINSServer));
      //Add('  Lease obtained: '+TimeTToDateTimeStr(Work^.LeaseObtained));
      //Add('  Lease expires: '+TimeTToDateTimeStr(Work^.LeaseExpires));
      cbxMacList.AddItem(compInfo^.MacValue, TObject(compInfo));
      Inc(I);
      Work := Work^.Next;
    Until (Work = nil);
  //End;
  FreeMem(AI);

end;

function TfrmComInfo.GetNetworkParameters: string;
Var
  FI   : PFixedInfo;
  Size : Integer;
  Res  : Integer;
  I    : Integer;
  DNS  : PIPAddrString;

begin
  Result := '';
  Size := 1024;
  GetMem(FI,Size);
  Res := GetNetworkParams(FI,Size);
  If (Res <> ERROR_SUCCESS) Then Begin
    SetLastError(Res);
    RaiseLastWin32Error;
  End;
  //With Info do Begin
  //  Clear;
  //  Lines.Add('Host name: '+FI^.HostName);
  //  Lines.Add('Domain name: '+FI^.DomainName);
    //aDnsList.Clear;
    //If (FI^.CurrentDNSServer <> nil) Then
    //begin
    //  Lines.Add('Current DNS Server: '+FI^.CurrentDNSServer^.IPAddress);
    //end
    //Else Lines.Add('Current DNS Server: (none)');
    I := 1;
    rbDNSAuto.Checked := (FI^.EnableDNS = 1);
    rbDNSStatic.Checked := (FI^.EnableDNS = 0);
    if FI^.EnableDNS = 0 then
    begin
      DNS := @FI^.DNSServerList;
      Repeat
        //Lines.Add('DNS '+IntToStr(I)+': '+DNS^.IPAddress);
        Result := DNS^.IPAddress;
        //aDnsList.Add();
        Inc(I);
        DNS := DNS^.Next;
      Until (DNS = nil) or (I > 2);
    end;
    //if aDnsList.Count > 0 then
    //  showmessage(aDnsList.Strings[0]);  
    //Lines.Add('Scope ID: '+FI^.ScopeId);
    //Lines.Add('Routing: '+IntToStr(FI^.EnableRouting));
    //Lines.Add('Proxy: '+IntToStr(FI^.EnableProxy));
    //Lines.Add('DNS: '+IntToStr(FI^.EnableDNS));
  //End;
  FreeMem(FI);

end;

procedure TfrmComInfo.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  //FreeAndNil(aDnsList);
end;

procedure TfrmComInfo.cbxMacListChange(Sender: TObject);
begin
  if cbxMacList.ItemIndex >= 0 then
  begin
    with PCompInfo(cbxMacList.Items.Objects[cbxMacList.ItemIndex])^ do
    begin
      IPStrToEdit(IpAddress, IPAddr);
      IPStrToEdit(Mask, IPMask);
      IPStrToEdit(GateWay, IPGateWay);
      IPStrToEdit(Dns, IPDNS);
    end;
  end;
end;

procedure TfrmComInfo.FormDestroy(Sender: TObject);
var
  I: Integer;
begin
  for I := 0 To cbxMacList.Items.Count - 1 do
    Dispose(PCompInfo(cbxMacList.Items.Objects[I]));
end;

procedure TfrmComInfo.FormShow(Sender: TObject);
begin
  if cbxMacList.Items.Count > 0 then
  begin
    cbxMacList.ItemIndex := 0;
    cbxMacListChange(cbxMacList);
  end;

end;

procedure TfrmComInfo.bbtnOkClick(Sender: TObject);
var
  str: string;
begin
  if cbxMacList.ItemIndex >= 0 then
  begin
    if rbIPAuto.Checked then
      str := 'netsh interface ip set address name="本地连接" source=dhcp'
    else
    begin
      str := 'netsh interface ip set address 本地连接 static ';
      with PCompInfo(cbxMacList.Items.Objects[cbxMacList.ItemIndex])^ do
      begin
        str := str + IpAddress + ' ' + Mask + ' ' + GateWay + ' 1';
      end;
    end;
    WinExecAndWait32(str, SW_HIDE);
    if rbDNSAuto.Checked then
      str := 'netsh interface ip set dns name="本地连接" source=dhcp'
    else
    begin
      str := 'netsh interface ip set dns 本地连接 static ';
      with PCompInfo(cbxMacList.Items.Objects[cbxMacList.ItemIndex])^ do
      begin
        str := str + dns + ' primary ';
      end;
    end;
    WinExecAndWait32(str, SW_HIDE);
    //设置首页
    SetStartPage(mmStartPage.Text);
    ShowMessage('恭喜你，设置成功！');
    Close; 
  end;
end;

procedure TfrmComInfo.IPAddrFieldChange(Sender: TObject; OldField,
  Value: Byte);
begin
  if cbxMacList.ItemIndex >= 0 then
  begin
    with PCompInfo(cbxMacList.Items.Objects[cbxMacList.ItemIndex])^ do
    begin
      IpAddress := IntToStr(IPAddr.Field0) + '.'
                  +IntToStr(IPAddr.Field1) + '.'
                  +IntToStr(IPAddr.Field2) + '.'
                  +IntToStr(IPAddr.Field3);
    end;
  end;
end;

procedure TfrmComInfo.rbIPAutoClick(Sender: TObject);
begin
  if rbIPAuto.Checked then
  begin
    IPAddr.Clear;
    IPMask.Clear;
    IPGateWay.Clear;
  end;
  IPAddr.Enabled := not rbIPAuto.Checked;
  IPMask.Enabled := not rbIPAuto.Checked;
  IPGateWay.Enabled := not rbIPAuto.Checked;
end;

procedure TfrmComInfo.rbDNSAutoClick(Sender: TObject);
begin
  if rbDNSAuto.Checked then IPDNS.Clear;
  IPDNS.Enabled := not rbDNSAuto.Checked;

end;

procedure TfrmComInfo.IPMaskFieldChange(Sender: TObject; OldField,
  Value: Byte);
begin
  if cbxMacList.ItemIndex >= 0 then
  begin
    with PCompInfo(cbxMacList.Items.Objects[cbxMacList.ItemIndex])^ do
    begin
      Mask := IntToStr(IPMask.Field0) + '.'
             +IntToStr(IPMask.Field1) + '.'
             +IntToStr(IPMask.Field2) + '.'
             +IntToStr(IPMask.Field3);
    end;
  end;

end;

procedure TfrmComInfo.IPGateWayFieldChange(Sender: TObject; OldField,
  Value: Byte);
begin
  if cbxMacList.ItemIndex >= 0 then
  begin
    with PCompInfo(cbxMacList.Items.Objects[cbxMacList.ItemIndex])^ do
    begin
      GateWay := IntToStr(IPGateWay.Field0) + '.'
                +IntToStr(IPGateWay.Field1) + '.'
                +IntToStr(IPGateWay.Field2) + '.'
                +IntToStr(IPGateWay.Field3);
    end;
  end;

end;

procedure TfrmComInfo.IPDNSFieldChange(Sender: TObject; OldField,
  Value: Byte);
begin
  if cbxMacList.ItemIndex >= 0 then
  begin
    with PCompInfo(cbxMacList.Items.Objects[cbxMacList.ItemIndex])^ do
    begin
      Dns := IntToStr(IPDNS.Field0) + '.'
             +IntToStr(IPDNS.Field1) + '.'
             +IntToStr(IPDNS.Field2) + '.'
             +IntToStr(IPDNS.Field3);
    end;
  end;

end;

function TfrmComInfo.GetStartPage: string;
var
  reg: TRegistry;
begin
  reg := TRegistry.Create;
  try
    Result := '';
    reg.RootKey := HKEY_LOCAL_MACHINE;
    if reg.OpenKey('SOFTWARE\Microsoft\Internet Explorer\Main', False) then
      Result := reg.ReadString('Start Page');
    reg.CloseKey;
  finally
    reg.Free;
  end;
end;

procedure TfrmComInfo.SetStartPage(APage: string);
var
  reg: TRegistry;
begin
  reg := TRegistry.Create;
  try
    reg.RootKey := HKEY_LOCAL_MACHINE;
    reg.OpenKey('SOFTWARE\Microsoft\Internet Explorer\Main', True);
    reg.WriteString('Start Page', APage);
    reg.CloseKey;
    reg.RootKey := HKEY_CURRENT_USER;
    reg.OpenKey('SOFTWARE\Microsoft\Internet Explorer\Main', True);
    reg.WriteString('Start Page', APage);
    reg.CloseKey;
  finally
    reg.Free;
  end;
end;

end.