检测SQL SERVER数据库是否能连得上！！！！！(200分)

下面是VB中检测数据库连接的代码，非常快，那位高手帮忙翻译成DELPHI，应该很多人都需要用到的,分数据不够可以再加的：

VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "Class1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit


Private Const IP_SUCCESS As Long = 0
Private Const IP_STATUS_BASE As Long = 11000
Private Const IP_BUF_TOO_SMALL As Long = (11000 + 1)
Private Const IP_DEST_NET_UNREACHABLE As Long = (11000 + 2)
Private Const IP_DEST_HOST_UNREACHABLE As Long = (11000 + 3)
Private Const IP_DEST_PROT_UNREACHABLE As Long = (11000 + 4)
Private Const IP_DEST_PORT_UNREACHABLE As Long = (11000 + 5)
Private Const IP_NO_RESOURCES As Long = (11000 + 6)
Private Const IP_BAD_OPTION As Long = (11000 + 7)
Private Const IP_HW_ERROR As Long = (11000 + 8)
Private Const IP_PACKET_TOO_BIG As Long = (11000 + 9)
Private Const IP_REQ_TIMED_OUT As Long = (11000 + 10)
Private Const IP_BAD_REQ As Long = (11000 + 11)
Private Const IP_BAD_ROUTE As Long = (11000 + 12)
Private Const IP_TTL_EXPIRED_TRANSIT As Long = (11000 + 13)
Private Const IP_TTL_EXPIRED_REASSEM As Long = (11000 + 14)
Private Const IP_PARAM_PROBLEM As Long = (11000 + 15)
Private Const IP_SOURCE_QUENCH As Long = (11000 + 16)
Private Const IP_OPTION_TOO_BIG As Long = (11000 + 17)
Private Const IP_BAD_DESTINATION As Long = (11000 + 18)
Private Const IP_ADDR_DELETED As Long = (11000 + 19)
Private Const IP_SPEC_MTU_CHANGE As Long = (11000 + 20)
Private Const IP_MTU_CHANGE As Long = (11000 + 21)
Private Const IP_UNLOAD As Long = (11000 + 22)
Private Const IP_ADDR_ADDED As Long = (11000 + 23)
Private Const IP_GENERAL_FAILURE As Long = (11000 + 50)
Private Const MAX_IP_STATUS As Long = (11000 + 50)
Private Const IP_PENDING As Long = (11000 + 255)
Private Const PING_TIMEOUT As Long = 500
Private Const WS_VERSION_REQD As Long = &H101
Private Const MIN_SOCKETS_REQD As Long = 1
Private Const SOCKET_ERROR As Long = -1
Private Const INADDR_NONE As Long = &HFFFFFFFF
Private Const MAX_WSADescription As Long = 256
Private Const MAX_WSASYSStatus As Long = 128

Private Type ICMP_OPTIONS
Ttl As Byte
Tos As Byte
Flags As Byte
OptionsSize As Byte
OptionsData As Long
End Type

Private Type ICMP_ECHO_REPLY
Address As Long
status As Long
RoundTripTime As Long
DataSize As Long '注释：formerly integer
'Reserved As Integer
DataPointer As Long
Options As ICMP_OPTIONS
Data As String * 250
End Type

Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription(0 To MAX_WSADescription) As Byte
szSystemStatus(0 To MAX_WSASYSStatus) As Byte
wMaxSockets As Long
wMaxUDPDG As Long
dwVendorInfo As Long
End Type

Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long

Private Declare Function IcmpCloseHandle Lib "icmp.dll" _
(ByVal IcmpHandle As Long) As Long

Private Declare Function IcmpSendEcho Lib "icmp.dll" _
(ByVal IcmpHandle As Long, _
ByVal DestinationAddress As Long, _
ByVal RequestData As String, _
ByVal RequestSize As Long, _
ByVal RequestOptions As Long, _
ReplyBuffer As ICMP_ECHO_REPLY, _
ByVal ReplySize As Long, _
ByVal Timeout As Long) As Long

Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long

Private Declare Function WSAStartup Lib "WSOCK32.DLL" _
(ByVal wVersionRequired As Long, _
lpWSADATA As WSADATA) As Long

Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long

Private Declare Function gethostname Lib "WSOCK32.DLL" _
(ByVal szHost As String, _
ByVal dwHostLen As Long) As Long

Private Declare Function gethostbyname Lib "WSOCK32.DLL" _
(ByVal szHost As String) As Long

Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(xDest As Any, _
xSource As Any, _
ByVal nbytes As Long)

Private Declare Function inet_addr Lib "WSOCK32.DLL" _
(ByVal s As String) As Long






Dim Conn As ADODB.Connection
Dim Rs As ADODB.Recordset

Public Function reDataErr(ByVal struid As String, ByVal strpwd As String, ByVal strip As String, ByVal Database As String) As Long
Dim strConn As String
Dim temp1 As String, temp2 As ICMP_ECHO_REPLY
On Error GoTo DataErr:

If Ping(strip, temp1, temp2) <> 0 Then
reDataErr = -1
Exit Function
End If

Set Conn = New ADODB.Connection
strConn = "Provider=SQLOLEDB;uid=" &amp; struid &amp; ";pwd=" &amp; strpwd &amp; ";Database=" &amp; Database &amp; ";Server=" &amp; strip
Conn.ConnectionTimeout = 1
Conn.Open strConn
Conn.Close
reDataErr = 1
Exit Function
DataErr:
reDataErr = 0
End Function



Public Function GetStatusCode(status As Long) As String

Dim msg As String

Select Case status
Case IP_SUCCESS: msg = "ip success"
Case INADDR_NONE: msg = "inet_addr: bad IP format"
Case IP_BUF_TOO_SMALL: msg = "ip buf too_small"
Case IP_DEST_NET_UNREACHABLE: msg = "ip dest net unreachable"
Case IP_DEST_HOST_UNREACHABLE: msg = "ip dest host unreachable"
Case IP_DEST_PROT_UNREACHABLE: msg = "ip dest prot unreachable"
Case IP_DEST_PORT_UNREACHABLE: msg = "ip dest port unreachable"
Case IP_NO_RESOURCES: msg = "ip no resources"
Case IP_BAD_OPTION: msg = "ip bad option"
Case IP_HW_ERROR: msg = "ip hw_error"
Case IP_PACKET_TOO_BIG: msg = "ip packet too_big"
Case IP_REQ_TIMED_OUT: msg = "ip req timed out"
Case IP_BAD_REQ: msg = "ip bad req"
Case IP_BAD_ROUTE: msg = "ip bad route"
Case IP_TTL_EXPIRED_TRANSIT: msg = "ip ttl expired transit"
Case IP_TTL_EXPIRED_REASSEM: msg = "ip ttl expired reassem"
Case IP_PARAM_PROBLEM: msg = "ip param_problem"
Case IP_SOURCE_QUENCH: msg = "ip source quench"
Case IP_OPTION_TOO_BIG: msg = "ip option too_big"
Case IP_BAD_DESTINATION: msg = "ip bad destination"
Case IP_ADDR_DELETED: msg = "ip addr deleted"
Case IP_SPEC_MTU_CHANGE: msg = "ip spec mtu change"
Case IP_MTU_CHANGE: msg = "ip mtu_change"
Case IP_UNLOAD: msg = "ip unload"
Case IP_ADDR_ADDED: msg = "ip addr added"
Case IP_GENERAL_FAILURE: msg = "ip general failure"
Case IP_PENDING: msg = "ip pending"
Case PING_TIMEOUT: msg = "ping timeout"
Case Else: msg = "unknown msg returned"
End Select

GetStatusCode = CStr(status) &amp; " [ " &amp; msg &amp; " ]"

End Function


Private Function Ping(sAddress As String, sDataToSend As String, ECHO As ICMP_ECHO_REPLY) As Long

'注释：If Ping succeeds :
'注释：.RoundTripTime = time in ms for the ping to complete,
'注释：.Data is the data returned (NULL terminated)
'注释：.Address is the Ip address that actually replied
'注释：.DataSize is the size of the string in .Data
'注释：.Status will be 0
'注释:
'注释：If Ping fails .Status will be the error code

Dim hPort As Long
Dim dwAddress As Long

'注释：convert the address into a long representation
dwAddress = inet_addr(sAddress)

'注释：if a valid address..
If dwAddress <> INADDR_NONE Then

'注释：open a port
hPort = IcmpCreateFile()

'注释：and if successful,
If hPort Then

'注释：ping it.
Call IcmpSendEcho(hPort, _
dwAddress, _
sDataToSend, _
Len(sDataToSend), _
0, _
ECHO, _
Len(ECHO), _
PING_TIMEOUT)

'注释：return the status as ping succes and close
Ping = ECHO.status
Call IcmpCloseHandle(hPort)

End If

Else:
'注释：the address format was probably invalid
Ping = INADDR_NONE

End If

End Function
Public Sub SocketsCleanup()

If WSACleanup() <> 0 Then
'MsgBox "Windows Sockets error occurred in Cleanup.", vbExclamation
End If

End Sub


Public Function SocketsInitialize() As Boolean

Dim WSAD As WSADATA

SocketsInitialize = WSAStartup(WS_VERSION_REQD, WSAD) = IP_SUCCESS

End Function

用SOCKET方式肯定很慢，用SQLDMO试试，不过SQL就是这样呀。

用sqldmo来做，它的企业管理器就是调用的sqldmo来实现的，给你点代码参考
{*******************************************************}
{ }
{ 数据库的操作及把连接字符串写进注册表 }
{ 作者：XXXXXX }
{ }
{ 日期：2002-09-10 }
{ 引用了SQLDMO_TLB单元,只有安装sql server才能引入 }
{ 如果不delphi引入则须把dcu文件加入到工程中即可 }
{ }
{*******************************************************}
unit Umain;

interface

uses
Windows, Messages, SysUtils, Variants,SQLDMO_TLB,Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, Menus;

type
TFrmDataManager = class(TForm)
PnlTitle: TPanel;
ImgTitle: TImage;
LblTitle1: TLabel;
LblTitle2: TLabel;
ImgServer: TImage;
CmbxServer: TComboBox;
LblServer: TLabel;
BvlCon: TBevel;
LblConnection: TLabel;
RadioBtnWin: TRadioButton;
RadioBtnSql: TRadioButton;
LblUser: TLabel;
LblPassWord: TLabel;
EdtUser: TEdit;
EdtPassWord: TEdit;
LblDatabase: TLabel;
BvlData: TBevel;
LblDatabaseLst: TLabel;
CmbxDatabase: TComboBox;
BvlOperate: TBevel;
BtnConnection: TButton;
BtnBackUp: TButton;
BtnRestore: TButton;
BtnExit: TButton;
SaveDlg: TSaveDialog;
OpenDlg: TOpenDialog;
PMnu: TPopupMenu;
Pmnu_CreateDatabase: TMenuItem;
Pmnu_DeleteDatabase: TMenuItem;
Pmnu_NewUser: TMenuItem;
Pmnu_DeleteUser: TMenuItem;
N5: TMenuItem;
N1: TMenuItem;
Pmnu_ShrinkLog: TMenuItem;
Pmnu_CreateRoles: TMenuItem;
Pmnu_DeleteRoles: TMenuItem;
Pmnu_Pub: TMenuItem;
N2: TMenuItem;
procedure BtnExitClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure RadioBtnWinClick(Sender: TObject);
procedure RadioBtnSqlClick(Sender: TObject);
procedure BtnConnectionClick(Sender: TObject);
procedure CmbxDatabaseDropDown(Sender: TObject);
procedure CmbxDatabaseCloseUp(Sender: TObject);
procedure BtnBackUpClick(Sender: TObject);
procedure BtnRestoreClick(Sender: TObject);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Pmnu_CreateDatabaseClick(Sender: TObject);
procedure Pmnu_DeleteDatabaseClick(Sender: TObject);
procedure Pmnu_NewUserClick(Sender: TObject);
procedure Pmnu_ShrinkLogClick(Sender: TObject);
procedure Pmnu_DeleteUserClick(Sender: TObject);
procedure Pmnu_CreateRolesClick(Sender: TObject);
procedure Pmnu_DeleteRolesClick(Sender: TObject);
procedure Pmnu_PubClick(Sender: TObject);
private
{ Private declarations }
procedure SetBtnState(value:Boolean);
procedure SetEdtState;
public
{ Public declarations }
Connected:boolean;
end;

var
FrmDataManager: TFrmDataManager;
App:_application;
Server:_sqlserver;
Dtbase:_database;
DBFileData :_DBFile;
LogFile :_LogFile;
Backup :_Backup;
Restore :_Restore;
SvrRoles:_ServerRole;
DbRoles:_DatabaseRole;
User:_user;
Login:_login;
implementation

uses reg, Common, UDbSet, UDelUser, UAddDbRole, UDelDbRole;

{$R *.dfm}

procedure TFrmDataManager.BtnExitClick(Sender: TObject);
begin
Close;
end;

procedure TFrmDataManager.SetBtnState(value: Boolean);
begin
BtnBackUp.Enabled:=Value;
BtnRestore.Enabled:=Value;
end;

procedure TFrmDataManager.SetEdtState;
begin
EdtUser.Enabled:=False;
EdtPassWord.Enabled:=False;
EdtUser.Color:=clBtnFace;
EdtPassWord.Color:=clBtnFace;
if RadioBtnSql.Checked then
begin
EdtUser.Enabled:=True;
EdtPassWord.Enabled:=True;
EdtUser.Color:=clWhite;
EdtPassWord.Color:=clWhite;
end;
end;

procedure TFrmDataManager.FormCreate(Sender: TObject);
var
i:integer;
nl:namelist;

begin
Connected:=False;
BtnConnection.Enabled:=False;
SetBtnState(Connected);
App:=coapplication.Create;
Server:=cosqlserver.Create ;
DBFileData :=coDBFile.Create ;
LogFile :=coLogFile.create;

nl:=App.ListAvailableSQLServers;
CmbxServer.Clear;
for i:=0 to nl.Count-1 do
begin
CmbxServer.Items.Add(nl.Item(i+1) )
end;
CmbxServer.ItemIndex:=0;
end;

procedure TFrmDataManager.RadioBtnWinClick(Sender: TObject);
begin
SetEdtState;
end;

procedure TFrmDataManager.RadioBtnSqlClick(Sender: TObject);
begin
SetEdtState;
end;

procedure TFrmDataManager.BtnConnectionClick(Sender: TObject);
var
ConStr:string;
begin
Connected:=False;

if RadioBtnWin.Checked then
begin
ConStr:=BaseConStr+'Integrated Security=SSPI;Persist Security Info=False;'+
'Initial Catalog='+CmbxDatabase.Text +';Data Source='+
CmbxServer.Text;
end
else
begin
ConStr:=BaseConStr+'Password='+EdtPassWord.Text
+';Persist Security Info=True;User ID='+EdtUser.Text
+';Initial Catalog='+CmbxDatabase.Text
+';Data Source='+CmbxServer.Text;
end;

Connected:=True;
{$IFDEF CGMERP}
SetRegString(HKEY_LOCAL_MACHINE, MyRegSection, MyRegKey_Connection, ConStr);
{$ENDIF}

SetBtnState(Connected);

end;

procedure TFrmDataManager.CmbxDatabaseDropDown(Sender: TObject);
var
i:integer;
begin
BtnConnection.Enabled:=False;
Server:=cosqlserver.Create ;
Dtbase:=codatabase.Create;
CmbxDatabase.Clear;
Server.LoginTimeout:=-1;
Screen.Cursor := crHourGlass;

try
if RadioBtnWin.Checked then
begin
With Server do
begin
LoginSecure:=true;
AutoReConnect:= False;
Connect(CmbxServer.Text,null,null);
end;
end
else
begin
With Server do
begin
LoginSecure := False;
AutoReConnect := False;
Connect(CmbxServer.Text,EdtUser.Text, EdtPassWord.Text);
end;
end;
CmbxDatabase.Clear;
for i:=1 to Server.Databases.Count do
begin
CmbxDatabase.Items.Add(Server.Databases.Item(i,'').Name);
end;

except
ErrBox('连接数据库失败!');
EdtUser.SetFocus;
end;
Screen.Cursor := crDefault;
end;

procedure TFrmDataManager.CmbxDatabaseCloseUp(Sender: TObject);
var
i:integer;
begin
if CmbxDatabase.ItemIndex>=0 then
begin
for i:=1 to server.Databases.Count do
begin
if CmbxDatabase.Text =server.Databases.Item(i,'').Name then
begin
Dtbase:=server.Databases.Item(i,'');
end;
end;
BtnConnection.Enabled:=True;
end;
end;

procedure TFrmDataManager.BtnBackUpClick(Sender: TObject);
var
Server:_sqlserver;
Backup:_Backup;
begin
Server:=cosqlserver.Create ;
Server.LoginTimeout:=-1;
if SaveDlg.Execute then
begin
try
Screen.Cursor := crHourGlass;
if RadioBtnWin.Checked then
begin
With Server do
begin
LoginSecure:=true;
AutoReConnect:= False;
Connect(CmbxServer.Text,null,null);
end;
end
else
begin
With Server do
begin
LoginSecure := False;
AutoReConnect := False;
Connect(CmbxServer.Text,EdtUser.Text, EdtPassWord.Text);

end;
end;


Backup :=coBackup.Create ;
Backup.action:=SQLDMOBackup_DATABASE;
Backup.Database:=CmbxDatabase.Text;
Backup.Files := SaveDlg.FileName;

Backup.SQLBackup(Server);
Screen.Cursor := crDefault;
MsgBox('数据库 '+CmbxDatabase.Text +' 备份成功');
except
Screen.Cursor := crDefault;
ErrBox('数据库 '+CmbxDatabase.Text+' 备份失败');
end;

Screen.Cursor := crDefault;
end;
end;

procedure TFrmDataManager.BtnRestoreClick(Sender: TObject);
var
Server:_sqlserver;
Restore:_Restore;
begin
Server:=cosqlserver.Create ;
Server.LoginTimeout:=-1;
if OpenDlg.Execute then
begin
try
Screen.Cursor := crHourGlass;
if RadioBtnWin.Checked then
begin
With Server do
begin
LoginSecure:=true;
AutoReConnect:= False;
Connect(CmbxServer.Text,null,null);
end;
end
else
begin
With Server do
begin
LoginSecure := False;
AutoReConnect := False;
Connect(CmbxServer.Text,EdtUser.Text, EdtPassWord.Text);
end;
end;

Restore :=coRestore.create;
Restore.Replacedatabase:=true;
Restore.action:=SQLDMORESTORE_DATABASE;
Restore.Database:=CmbxDatabase.Text;
Restore.Files := OpenDlg.FileName;
Restore.SQLRestore(Server);
Screen.Cursor := crDefault;
MsgBox('数据库 '+CmbxDatabase.Text +' 恢复成功');
except
Screen.Cursor := crDefault;
ErrBox('数据库 '+CmbxDatabase.Text+' 恢复失败');
end;

Screen.Cursor := crDefault;
end;
end;

procedure TFrmDataManager.FormMouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if (Button=mbRight)and (CmbxDatabase.ItemIndex>=0) then
begin
PMnu.Popup(Mouse.CursorPos.X,Mouse.CursorPos.Y );

end;
end;

procedure TFrmDataManager.Pmnu_CreateDatabaseClick(Sender: TObject);
var
i :Integer;
sDatabaseName :String;
begin
try
sDatabaseName := InputBox('请输入新的数据库名称','创建数据库', 'DefaultDB');
If sDatabaseName='' Then Exit;

for i:=1 to server.Databases.Count do
begin
if sdatabasename=server.Databases.Item(i,'').Name then
begin
ErrBox('数据库名重复');
exit;
end;

end;
screen.Cursor:=crHourGlass;

Dtbase.Name := sDatabaseName;
DBFileData.Name := sDatabaseName;
DBFileData.PhysicalName:=server.Registry.SQLDataRoot+'/data/'+sdatabasename+'.mdf';
DBFileData.PrimaryFile := True;
DBFileData.Size := 2 ;
DBFileData.FileGrowthType := SQLDMOGrowth_MB;
DBFileData.FileGrowth := 1;
Dtbase.FileGroups.Item(1).DBFiles.Add(DBFileData);

LogFile.Name := sDatabaseName +'Log';
LogFile.PhysicalName:=server.Registry.SQLDataRoot+'/data/'+LogFile.Name+'.ldf';
LogFile.Size := 2;
Dtbase.TransactionLog.LogFiles.Add(logfile);
Server.Databases.Add(dtbase);
MsgBox('数据库 '+sDatabaseName+' 成功');
CmbxDatabase.Clear;
for i:=1 to server.Databases.Count do
begin
CmbxDatabase.Items.Add(server.Databases.Item(i,'').Name);
end;
CmbxDatabase.ItemIndex:=0;
screen.Cursor:=crDefault;
except
screen.Cursor:=crDefault;
ErrBox('数据库 '+sDatabaseName+' 失败');
end;
end;


procedure TFrmDataManager.Pmnu_DeleteDatabaseClick(Sender: TObject);
var
sDataBaseToDelete :String;
i:integer;
begin
sDataBaseToDelete := CmbxDatabase.Text;
if not Confirm('你真的要删除数据库 '+sDataBaseToDelete +' 吗?') then exit;
try
Screen.Cursor := crHourGlass;
server.Databases.Remove(sDataBaseToDelete,null);
MsgBox('数据库 '+sDataBaseToDelete +' 已删除完毕!') ;
Screen.Cursor := crDefault;
except
Screen.Cursor := crDefault;
ErrBox('数据库 '+sDataBaseToDelete +' 删除失败!') ;
end;
CmbxDatabase.Clear;
for i:=1 to server.Databases.Count do
begin
CmbxDatabase.Items.Add(server.Databases.Item(i,'').Name);
end;
CmbxDatabase.ItemIndex:=0;
end;


procedure TFrmDataManager.Pmnu_NewUserClick(Sender: TObject);
var
i,j:integer;
Uname,Upass:string;
begin
try
for i:=1 to server.Databases.Count do
begin
if CmbxDatabase.Text =server.Databases.Item(i,'').Name then
begin
Dtbase:=server.Databases.Item(i,'');
end;
end;
if Login<>nil then Login:=nil;
LogIn:=coLogIn.Create;
if User<>nil then User:=nil;
User:=coUser.Create;
if Frm_DbSet=nil then Frm_DbSet:=TFrm_DbSet.create(nil);

Frm_DbSet.Lsb_UserName.Clear;
for i:=1 to DtBase.Users .Count do
begin
Frm_DbSet.Lsb_UserName.Items.Add (DtBase.Users.Item(i).Name)
end;

Frm_DbSet.CLsB_ServerRoles.Clear;
for i:=1 to server.ServerRoles.Count do
begin
Frm_DbSet.CLsB_ServerRoles.Items.Add(server.ServerRoles.Item(i).Name);
end;
Frm_DbSet.CLsB_DbRoles.Clear;
for i:=1 to DtBase.DatabaseRoles.Count do
begin
Frm_DbSet.CLsB_DbRoles.Items.Add(DtBase.DatabaseRoles.Item(i).Name);
end;

Frm_DbSet.ShowModal;

if Frm_DbSet.ModalResult=mrOK then
begin
Uname:=Frm_DbSet.Edt_Name.Text;
Upass:=Frm_DbSet.Edt_Pass.Text;
Login.Database:=CmbxDatabase.Text;
for i:=1 to server.Databases.Count do
begin
if CmbxDatabase.Text =server.Databases.Item(i,'').Name then
begin
Dtbase:=server.Databases.Item(i,'');
end;
end;
for j:=1 to server.Logins.Count do
begin
if Uppercase(Uname)=uppercase(server.Logins.Item(j).Name) then
begin
if not Confirm('该用户 '+ Uname +' 已存在,是否修改?') then exit
else
begin
server.Logins.Remove(Uname);
break;
end;
end;
end;
try
Login.Name:=Uname;
Login.SetPassword('',Upass);
User.Login:=Login.Name ;
server.Logins.Add(Login);

Dtbase.Users.Add(User);

for i:=0 to Frm_DbSet.CLsB_DbRoles.Count-1 do
begin
if Frm_DbSet.CLsB_DbRoles.Checked then
begin
for j:=1 to DtBase.DatabaseRoles.Count do
begin
if UpperCase(DtBase.DatabaseRoles.Item(j).Name)=UpperCase(Frm_DbSet.CLsB_DbRoles.Items.Strings) then
begin
if DbRoles<>nil then DbRoles:=nil;
DbRoles:=coDatabaserole.Create;
DbRoles:=DtBase.DatabaseRoles.Item(j);
if UpperCase(DbRoles.Name)=UpperCase('public') then Continue;
DbRoles.AddMember(Uname);
end;

end;
end;
end;

for i:=0 to Frm_DbSet.CLsB_ServerRoles.Count-1 do
begin
if Frm_DbSet.CLsB_ServerRoles.Checked then
begin
for j:=1 to Server.ServerRoles.Count do
begin
if Uppercase(server.ServerRoles.Item(j).Name)=UpperCase(Frm_DbSet.CLsB_ServerRoles.Items.Strings) then
begin
if SvrRoles<>nil then SvrRoles:=nil;
SvrRoles:=server.ServerRoles.Item(j);
SvrRoles.AddMember(Login.Name );
end;
end;
end;
end;
MsgBox('用户增加成功!');
except
ErrBox('用户增加失败!');
end;
end;
except
ErrBox('用户'+EdtUser.text+'权限不够!');
end;
end;


procedure TFrmDataManager.Pmnu_ShrinkLogClick(Sender: TObject);
var
i:integer ;
TLog:TransactionLog;
LogFileName:String;
begin

for i:=1 to server.Databases.Count do
begin
if CmbxDatabase.Text =server.Databases.Item(i,'').Name then
begin
Dtbase:=server.Databases.Item(i,'');
LogFileName:=CmbxDatabase.Text+'_Log';
end;
end;
TLog := Dtbase.TransactionLog ;

for i := 1 to TLog.LogFiles.Count do
begin
if (Uppercase(TLog.LogFiles.Item(i).Name) =Uppercase(LogFileName)) then
begin
LogFile := TLog.LogFiles.Item(i) ;
Break ;
end;
end;
try
LogFile.Shrink(1, SQLDMOShrink_Default);
MsgBox('数据库'+CmbxDatabase.Text+'日志文件已压缩成功');
except
ErrBox('数据库'+CmbxDatabase.Text+'日志文件压缩失败!');
end;

end;


procedure TFrmDataManager.Pmnu_DeleteUserClick(Sender: TObject);
var
i,j,m:integer;
begin
if Frm_DeleteUser=nil then Frm_DeleteUser:=TFrm_DeleteUser.Create(nil);
Frm_DeleteUser.CLsB_User.Clear;
for i:=1 to server.Logins.Count do
begin
Frm_DeleteUser.CLsB_User.Items.Add (server.Logins.Item(i).Name)
end;
Frm_DeleteUser.ShowModal;
if Frm_DeleteUser.ModalResult=mrOK then
begin
self.Cursor:=crHourGlass;
for i:=0 to Frm_DeleteUser.CLsB_User.Items.Count-1 do
begin
if Frm_DeleteUser.CLsB_User.Checked then
begin
if Confirm('该用户 '+ Frm_DeleteUser.CLsB_User.Items.Strings +'是否删除?') then
begin
for j:=1 to server.Databases.Count do
begin
for m:=1 to server.Databases.Item(j,'').Users.Count do
begin
if Uppercase(server.Databases.Item(j,'').Users.Item(m).Login)=Uppercase(Frm_DeleteUser.CLsB_User.Items.Strings) then
begin
try
server.Databases.Item(j,'').Users.Remove(m);
server.Logins.Remove(Frm_DeleteUser.CLsB_User.Items.Strings);
MsgBox('该用户 '+ Frm_DeleteUser.CLsB_User.Items.Strings +'已被删除!');
Break;
except
ErrBox('该用户 '+ Frm_DeleteUser.CLsB_User.Items.Strings +'删除失败!');
end;
end;
end;
end;
end;
end;
end;
self.Cursor:=crDefault;
MsgBox('删除用户成功');
end;
end;


procedure TFrmDataManager.Pmnu_CreateRolesClick(Sender: TObject);
var
i,j,m:integer;
begin
Dobusy(True);
for i:=1 to server.Databases.Count do
begin
if CmbxDatabase.Text =server.Databases.Item(i,'').Name then
begin
Dtbase:=server.Databases.Item(i,'');
end;
end;

if Frm_AddDbRole=nil then Frm_AddDbRole:=TFrm_AddDbRole.Create(self);
Frm_AddDbRole.CLsB_User.Clear;
for i:=1 to DtBase.Users.Count do
begin
Frm_AddDbRole.CLsB_User.Items.Add (DtBase.Users.Item(i).Name);
end;
Frm_AddDbRole.SGrd_Permissions.RowCount:=DtBase.Tables.Count;
for i:=1 to DtBase.Tables.Count do
begin
Frm_AddDbRole.SGrd_Permissions.Cells[0,i]:=Dtbase.Tables.Item(i,null).Name;
Frm_AddDbRole.SGrd_Permissions.Cells[1,i]:=Dtbase.Tables.Item(i,null).Owner;

end;
Frm_AddDbRole.ShowModal;
if Frm_AddDbRole.ModalResult=mrOK then
begin
for i:=1 to DtBase.DatabaseRoles.Count do
begin
if UpperCase(Frm_AddDbRole.NewDbRole)=UpperCase(DtBase.DatabaseRoles.Item(i).Name) then
begin
ErrBox('数据库角色重复');
exit;
end;
end;
if DbRoles<>nil then DbRoles:=nil;
DbRoles:=coDatabaserole.Create;
DbRoles.Name:=Frm_AddDbRole.NewDbRole;
DtBase.DatabaseRoles.Add(DbRoles);
for j:=1 to DtBase.DatabaseRoles.Count do
begin
if UpperCase(Frm_AddDbRole.NewDbRole)=UpperCase(DtBase.DatabaseRoles.Item(j).Name) then
begin
DbRoles:= DtBase.DatabaseRoles.Item(j);
for i:=0 to Frm_AddDbRole.CLsB_User.Count -1 do
begin
if Frm_AddDbRole.CLsB_User.Checked then
begin
if UpperCase(Frm_AddDbRole.CLsB_User.Items.Strings )='DBO' then Continue;
DbRoles.AddMember(Frm_AddDbRole.CLsB_User.Items.Strings );

end;

end;
end;
end;

for i:=2 to 7 do
begin
for j:=1 to Frm_AddDbRole.SGrd_Permissions.RowCount do
begin
for m:=1 to Dtbase.Tables.Count do
begin
if Dtbase.Tables.Item(m,null).Name = Frm_AddDbRole.SGrd_Permissions.Cells[0,j] then break;
end;
if Frm_AddDbRole.SGrd_Permissions.Cells[i,j]='Grant' then
begin
case i of
2:dtbase.Tables.Item(m,null).Grant (1,dbroles.Name,Null,true,null);
3:dtbase.Tables.Item(m,null).Grant (2,dbroles.Name,Null,true,null);
4:dtbase.Tables.Item(m,null).Grant (4,dbroles.Name,Null,true,null);
5:dtbase.Tables.Item(m,null).Grant (8,dbroles.Name,Null,true,null);
6:;//dtbase.Tables.Item(m,null).Grant (1,dbroles.Name,Null,true,null);
7:;//dtbase.Tables.Item(m,null).Grant (32,dbroles.Name,Null,true,null);

end;
end //
else if Frm_AddDbRole.SGrd_Permissions.Cells[i,j]='Deny' then
begin
case i of
2:dtbase.Tables.Item(m,null).Deny (1,dbroles.Name,Null,false);
3:dtbase.Tables.Item(m,null).Deny (2,dbroles.Name,Null,false);
4:dtbase.Tables.Item(m,null).Deny (4,dbroles.Name,Null,false);
5:dtbase.Tables.Item(m,null).Deny (8,dbroles.Name,Null,false);
6:;//dtbase.Tables.Item(m,null).Grant (1,dbroles.Name,Null,true,null);
7:;//dtbase.Tables.Item(m,null).Deny (32,dbroles.Name,Null,false);

end;

end
else
begin
case i of
2:dtbase.Tables.Item(m,null).Revoke(1,dbroles.Name,Null,true,false,null);
3:dtbase.Tables.Item(m,null).Revoke(2,dbroles.Name,Null,true,false,null);
4:dtbase.Tables.Item(m,null).Revoke(4,dbroles.Name,Null,true,false,null);
5:dtbase.Tables.Item(m,null).Revoke(8,dbroles.Name,Null,true,false,null);
6:;//dtbase.Tables.Item(m,null).Grant (1,dbroles.Name,Null,true,null);
7:;//dtbase.Tables.Item(m,null).Revoke(32,dbroles.Name,Null,true,false,null);
end;
end;
end;

end;

MsgBox('增加数据库角色成功');

end;
DoBusy(False);
Frm_AddDbRole.Free;
Frm_AddDbRole:=nil;
end;
procedure TFrmDataManager.Pmnu_DeleteRolesClick(Sender: TObject);
var
i,j,m:integer;
begin
for i:=1 to server.Databases.Count do
begin
if CmbxDatabase.Text =server.Databases.Item(i,'').Name then
begin
Dtbase:=server.Databases.Item(i,'');
end;
end;

if Frm_DelDbRole=nil then Frm_DelDbRole:=TFrm_DelDbRole.Create(self);
Frm_DelDbRole.CLsb_DbRoles.Clear;
for i:=1 to DtBase.DatabaseRoles.Count do
begin
Frm_DelDbRole.CLsb_DbRoles.Items.Add(DtBase.DatabaseRoles.Item(i).Name);
end;
Frm_DelDbRole.ShowModal;

if Frm_DelDbRole.ModalResult=mrOK then
begin
try
for i:=0 to Frm_DelDbRole.CLsB_DbRoles.Count-1 do
begin
if Frm_DelDbRole.CLsB_DbRoles.Checked then
begin
for j:=1 to DtBase.DatabaseRoles.Count do
begin
if UpperCase(Frm_DelDbRole.CLsB_DbRoles.Items.Strings)=UpperCase(DtBase.DatabaseRoles.Item(j).Name) then
begin
DbRoles:= DtBase.DatabaseRoles.Item(j);
for m:=1 to DtBase.Users.Count do
begin
if UpperCase(DtBase.Users.Item(m).Name)='DBO' then continue;
DbRoles.DropMember(DtBase.Users.Item(m).Name);
end;
DbRoles.Remove;
Break;
end;
end;
end;
end;
MsgBox('删除数据库角色成功');
except
ErrBox('删除数据库角色失败!');
end;

end;
end;


procedure CreateSubScription(RemoteDb,DbName,Pub,Pubpwd,Dispwd:string);
var
ObjSub:_MergePullSubscription;
begin
ObjSub:=coMergePullSubscription.Create;

with ObjSub do
begin
Publisher:=RemoteDb; //出版者
Publicationdb:=DbName;//出版的数据库
Publication:=Pub; //文章来源
SubScriberType:=SQLDMOMergeSubscriber_Anonymous; //订阅类型
with DistributorSecurity do //分布的安全验证对象
begin
SecurityMode:=SQLDMOReplSecurity_Normal; //验证方式
StandardLogin:='sa'; //用户名
StandardPassword:=Dispwd; //口令
end;
with PublisherSecurity do //出版的安全验证对象
begin
SecurityMode:=SQLDMOReplSecurity_Normal; //验证方式
StandardLogin:='sa'; //用户名
StandardPassword:=Pubpwd; //口令
end;
with MergeSchedule do //复制进度对象
begin
FrequencyType:=SQLDMOFreq_Daily;
ActiveStartDate:=strtoint(Formatdatetime('yyyymmdd',now)); //把当天的时间设为第一次运行的时间
end;
end;
server.Replication.ReplicationDatabases.Item (DbName).mergepullsubscriptions.add(ObjSub); //把objsub对象加进去
ObjSub:=nil;
end;



procedure TFrmDataManager.Pmnu_PubClick(Sender: TObject);
begin
CreateSubScription('server','master','master','','');
end;

end.

速度还可以啊，我现在就用住，不过是VB里面做的不方便，使用前还要安装VB的什么包，哪位帮翻译一下啊！

还是使用delphi自己的控件好，因为连不上是很正常的。
看一下这里有没有你需要的。
http://www.cfwp.com/delphi_data.htm

接受答案了！