pgfwq.pas

三层数据配置程序 很简单

unit PGFWQ;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls,inifiles, DB, ADODB,Registry, IdWinsock,ComObj,
  Buttons;

type
  PnetResourceArr = ^TNetResource;
  TFrmpgfwq = class(TForm)
    Panel1: TPanel;
    GroupBox1: TGroupBox;
    Label1: TLabel;
    Label2: TLabel;
    fromshow: TCheckBox;
    edserver: TEdit;
    Button1: TButton;
    GroupBox2: TGroupBox;
    Label3: TLabel;
    Label4: TLabel;
    Socketck: TCheckBox;
    Edit1: TEdit;
    Edit2: TEdit;
    Button2: TButton;
    Panel2: TPanel;
    Listzu: TListBox;
    Listcomp: TListBox;
    Label5: TLabel;
    Label6: TLabel;
    Button3: TButton;
    ComboBox2: TComboBox;
    ADOQuery1: TADOQuery;
    BitBtn1: TBitBtn;
    procedure FormShow(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    function GetNetWorkgroup : string;    //得到网络上的工作组 1
    Function GetNameByIP(MIP:string; var Name:string):boolean;
    function GetServercomList(List:TStrings):boolean;
    procedure Button3Click(Sender: TObject); //得到网络上的工作组2
    function GetUserList(fServer:string;List:TStrings):boolean;
    procedure ListzuClick(Sender: TObject);
    procedure ListcompDblClick(Sender: TObject);//得到计算机名
    function checksqlserver:boolean;
    function  pRemote(var Cn: Tadoquery; pServerName: String):boolean;
    procedure Panel2DblClick(Sender: TObject);
    procedure BitBtn1Click(Sender: TObject); //连接远程数据库
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Frmpgfwq: TFrmpgfwq;
  myfile:Tinifile;
implementation

{$R *.dfm}

procedure TFrmpgfwq.FormShow(Sender: TObject);
var
  filename:string;
begin
  Filename:=ExtractFilePath(Paramstr(0))+'system\login.ini';
  myfile:=Tinifile.Create(filename);
  with myfile do
     begin
       edserver.Text:=ReadString('DMS','ServerName','');
       combobox2.SelText:=ReadString('DMS','DataBaseName','');
       fromshow.Checked:=readBOOL('DMS','ShowMainForm',false);
     END;
   with myfile do
    begin
        EDIT1.Text:= ReadString('DM','Address','');
        EDIT2.Text:=ReadString('DM','Port','');
        SocketCK.Checked:=readBOOL('DM','Socket',FALSE);
    END;
    panel2.Visible:=false;
 end;

procedure TFrmpgfwq.Button1Click(Sender: TObject);
begin
 if combobox2.Text='' then
   begin
  showmessage('请选择数据库!!!!');
   combobox2.SetFocus;
   end
 else
  begin
   WITH myfile do
    begin
       WriteString('DMS','ServerName',edserver.Text);
       WriteString('DMS','DataBaseName',combobox2.Text);
       WriteBool('DMS','ShowMainForm',fromshow.Checked);
    end;
  end;
end;

procedure TFrmpgfwq.Button2Click(Sender: TObject);
begin
 with myfile do
    begin
      WriteString('DM','Address', EDIT1.Text);
      WriteString('DM','Port',EDIT2.Text);
      WriteBOOL('DM','Socket',SOCKETCK.Checked);
    END;
end;

function TFrmpgfwq.GetNetWorkgroup: string;
var
  Reg : TRegistry;
begin
  Reg := TRegistry.create;
  Result := '(n/a)';
  with Reg do
  try
     RootKey := HKEY_LOCAL_MACHINE;
     if OpenKey('System\CurrentControlSet\Services\VxD\VNETSUP',
        false) then
        Result := ReadString('Workgroup');
  finally
     CloseKey;
     free;
  end;
end;
function TFrmpgfwq.GetNameByIP(MIP: string; var Name: string): boolean;
var
  PHt:PHostEnt;
  WSData: TWSAData;
  i:Word;
  j:integer;
  k:u_long;
begin
  result:=false;
  i:=MAKEWORD(1,1);
  if WSAStartup(i,WSData)<>0 then exit;
  k:=inet_addr(PChar(MIP));
  PHt:=gethostbyaddr(@k,4,PF_INET);
  if PHt=nil then begin
     j:=WSAGetLastError;
     Name:='Error:'+inttostr(j-WSABASEERR);
  end else begin
     Name:=PHt.h_name;
     result:=true;
  end;
  WSACleanup;

end;

function TFrmpgfwq.GetServercomList(List: Tstrings):boolean;
Type
  {$H+}
  PMyRec = ^MyRec;
  MyRec = Record
            dwScope      : Integer;
            dwType        : Integer;
            dwDisplayType : Integer;
            dwUsage      : Integer;
            LocalName    : String;
            RemoteName    : String;
            Comment      : String;
            Provider      : String;
          End;
  {H-}
Var
  NetResource : TNetResource;          //定义网络资源类型数组
  TempRec    : PMyRec;
  Buf        : Pointer;
  Count,
  BufSize,
  Res        : DWORD;
  lphEnum    : THandle;
  p          : PNetResourceArr;
  i,
  j          : SmallInt;
  NetworkTypeList : TList;       //用于存储枚举类型的网络类型
begin
  Result := False;

  NetworkTypeList := TList.Create;
  List.BeginUpdate;
  List.Clear;
  GetMem(Buf, 8192);
  Try
    Res := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK, RESOURCEUSAGE_CONTAINER, Nil,lphEnum);
    If Res <> 0 Then Raise Exception(Res);
    Count := $FFFFFFFF;
    BufSize := 8192;
    Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize);
    If Res = ERROR_NO_MORE_ITEMS Then Exit;
    If (Res <> 0) Then Raise Exception(Res);
    P := PNetResourceArr(Buf);
    For I := 0 To Count - 1 Do
    Begin
      New(TempRec);
      TempRec^.dwScope := P^.dwScope;
      TempRec^.dwType := P^.dwType ;
      TempRec^.dwDisplayType := P^.dwDisplayType ;
      TempRec^.dwUsage := P^.dwUsage ;
      TempRec^.LocalName := StrPas(P^.lpLocalName);
      TempRec^.RemoteName := StrPas(P^.lpRemoteName);
      TempRec^.Comment := StrPas(P^.lpComment);
      TempRec^.Provider := StrPas(P^.lpProvider);
      NetworkTypeList.Add(TempRec);
      Inc(P);
    End;
    Res := WNetCloseEnum(lphEnum);
    If Res <> 0 Then Raise Exception(Res);
    For J := 0 To NetworkTypeList.Count-1 Do
    Begin
      TempRec := NetworkTypeList.Items[J];
      NetResource := TNetResource(TempRec^);
      Res := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK, RESOURCEUSAGE_CONTAINER, @NetResource,lphEnum);
      If Res <> 0 Then Raise Exception(Res);
      While true Do
      Begin
        Count := $FFFFFFFF;
        BufSize := 8192;
        Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize);
        If Res = ERROR_NO_MORE_ITEMS Then Break;
        If (Res <> 0) Then Raise Exception(Res);
        P := PNetResourceArr(Buf);
        For I := 0 To Count - 1 Do
        Begin
          List.Add(P^.lpRemoteName);
          //listcomp.Items.Add(P^.lpRemoteName);
          Inc(P);
        End;
      End;
    End;
    Res := WNetCloseEnum(lphEnum);
    If Res <> 0 Then Raise Exception(Res);
      Result := True;
    Finally
      FreeMem(Buf);
      NetworkTypeList.Destroy;
  End;
  List.EndUpdate;
end;

procedure TFrmpgfwq.Button3Click(Sender: TObject);
begin
 try
   panel2.Visible:=true;
   GetServercomList(listzu.Items);
   listzu.Selected[0]:=true;
   ListzuClick(self);
 except
   showmessage('系统错误!!') ;
 end;
end;

function TFrmpgfwq.GetUserList(fServer: string; List: TStrings):boolean;
Var
  NetResource : TNetResource;
  Buf        : Pointer;
  Count,
  BufSize,
  Res        : DWord;
  Ind        : Integer;
  lphEnum    : THandle;
  Temp        : PNetResourceArr;
Begin
  List.Clear;
  GetMem(Buf, 8192);
  Try
    FillChar(NetResource, SizeOf(NetResource), 0);
    NetResource.lpRemoteName := @fServer[1];
    NetResource.dwDisplayType := RESOURCEDISPLAYTYPE_SERVER;
    NetResource.dwUsage := RESOURCEUSAGE_CONTAINER;
    NetResource.dwScope := RESOURCETYPE_DISK;
    Res := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK, RESOURCEUSAGE_CONTAINER, @NetResource,lphEnum);
    If Res <> 0 Then
     begin
          Result := false;
          Exit;
     end;      
    While True Do
    Begin
      Count := $FFFFFFFF;
      BufSize := 8192;
      Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize);
      If Res = ERROR_NO_MORE_ITEMS Then
        begin
          Result := false;
          Exit;
        end;  
      If (Res <> 0) then
        begin
          Result := false;
          Exit;
        end;  
      Temp := PNetResourceArr(Buf);
      For Ind := 0 to Count - 1 do
      Begin
        List.Add(Temp^.lpRemoteName + 2); { Add all the network usernames to List StringList }
        Inc(Temp);
      End;
    End;
    Res := WNetCloseEnum(lphEnum);
    If Res <> 0 Then Raise Exception(Res);
   Result := True;
  Finally
    FreeMem(Buf);

end;
end;

procedure TFrmpgfwq.ListzuClick(Sender: TObject);
begin
  try
    GetUserList(Listzu.Items[Listzu.ItemIndex],Listcomp.Items);
  except
    showmessage('网络故障，请稍后再试!!!!!');
  end;
end;

procedure TFrmpgfwq.ListcompDblClick(Sender: TObject);
type
   ds=(master,Northwind,pubs,model,msdb,tempdb);
 var
  i:integer;

begin
   try
      for i:= 0 to listcomp.Items.Count-1 do
        begin
          if  (listcomp.Selected[i]=true )  then
              edserver.Text:=listcomp.items.Strings[i];
        end;
        if checksqlserver then  panel2.Visible:=false;
         with adoquery1 do
          begin
            try
             close;
             SQL.LoadFromFile(ExtractFilePath(Paramstr(0))+'system\SQL.txt');
             pRemote(adoquery1,edserver.Text);
             open;
             application.ProcessMessages;
             except
               showmessage('登陆失败，请于管理员联系!!!') ;
               CLOSE;
              END; 
            first;
            COMBOBOX2.Clear;
            while not eof do
             begin
                if (fieldbyname('name').AsString ='master')or (fieldbyname('name').AsString ='Northwind')or
                (fieldbyname('name').AsString ='pubs') or(fieldbyname('name').AsString ='tempdb') or (fieldbyname('name').AsString ='msdb')or (fieldbyname('name').AsString='model') then
                   next
                else
                 combobox2.Items.Add(fieldbyname('name').AsString);
                 next;
             end;
         end;       

   except
     showmessage('系统错误，稍后再试!!!!');
   end;
   combobox2.SetFocus;
end;

function TFrmpgfwq.checksqlserver:boolean;
var
   SQLServer: Variant;
   ServerList: Variant;
  i,nServers: integer;
begin
 try
   SQLServer := CreateOleObject('SQLDMO.Application');
   ServerList := SQLServer.ListAvailableSQLServers;
   nServers := ServerList.Count;
  except
   Result :=false;
   Messagebox(handle, '数据库实例检测失败，请安装数据库管理系统！', '', 1);
   exit;
 end;

  for i := 1 to nservers do
    begin
     // combobox1.Items.Add(ServerList.Item(i));
   end;
 SQLServer := NULL;
 serverList := NULL;
 Result :=true;
 end;
 
function TFrmpgfwq.pRemote(var Cn: Tadoquery; pServerName:String): boolean;
begin
  cn.Close;
 if Trim(pServerName) <> '' then
    begin
     Cn.ConnectionString := 'Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Initial Catalog=master;Data Source=' +pServerName;
     end;
    result:=true;
end;

procedure TFrmpgfwq.Panel2DblClick(Sender: TObject);
begin
   panel2.Visible:=false;
end;

procedure TFrmpgfwq.BitBtn1Click(Sender: TObject);
begin
  close;
end;

end.