Option Explicit
'------------------------------------------------------------
'比较两个SQLSERVER的数据结构的不同
'------------------------------------------------------------
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long

Private Cnn1 As ADODB.Connection, Cnn2 As ADODB.Connection

Private Sub main()
Dim ServerName As String, DataBase As String, UserName As String, password As String
Dim iniName As String
iniName = App.Path & IIf(Len(App.Path) > 3, "\", "") & App.EXEName & ".ini"
Set Cnn1 = New ADODB.Connection
   ServerName = GetProfileString("DataBase1", "serverName", "", iniName)(0)
   DataBase = GetProfileString("DataBase1", "database", "", iniName)(0)
   password = GetProfileString("DataBase1", "password", "", iniName)(0)
   UserName = GetProfileString("DataBase1", "username", "", iniName)(0)
Call conn(Cnn1, ServerName, DataBase, UserName, password)
Call createProc(Cnn1)
Set Cnn2 = New ADODB.Connection

   ServerName = GetProfileString("DataBase2", "serverName", "", iniName)(0)
   DataBase = GetProfileString("DataBase2", "database", "", iniName)(0)
   password = GetProfileString("DataBase2", "password", "", iniName)(0)
   UserName = GetProfileString("DataBase2", "username", "", iniName)(0)
Call conn(Cnn2, ServerName, DataBase, UserName, password)
Call createProc(Cnn2)
Call writeLog
End Sub
'--------------------------------------------
'写入文件
'--------------------------------------------
Private Sub writeLog()
 Dim fn As Integer
 On Error GoTo errSave
 fn = FreeFile(0)
 Open App.Path & IIf(Len(App.Path) > 3, "\", "") & App.EXEName & ".log" For Output As #fn
 Print #fn, checkTable()
 Print #fn, CheckProc()
 Close #fn
 MsgBox "比较完成,结果写入" & App.EXEName & ".log"
 Exit Sub
errSave:
   If Err > 0 Then MsgBox "错误：" & Err & " " & Error$
   On Error Resume Next
   If fn > 0 Then Close #fn
End Sub

'--------------------------------------------
'比校两个数据库中的所有表及字段
'--------------------------------------------
Private Function checkTable() As String
Dim rec1 As ADODB.Recordset, rec2 As ADODB.Recordset
Dim tablename As String, fieldname As String, i As Integer, flag As Boolean
Dim Msg As String
Set rec1 = getTableMsg(Cnn1)
Set rec2 = getTableMsg(Cnn2)
Do While rec1.EOF = False
  If tablename <> rec1.Fields("表名") Or flag = False Then
    flag = False
    tablename = rec1.Fields("表名")
    fieldname = rec1.Fields("字段名")
    rec2.Filter = "表名='" & tablename & "'"
    If rec2.RecordCount = 0 Then
      Msg = Msg & vbCrLf & "目标2欠:" & tablename
      flag = True
    Else
      rec2.Filter = "表名='" & tablename & "' and 字段名='" & fieldname & "'"
      If rec2.RecordCount = 0 Then
         Msg = Msg & vbCrLf & "目标2欠:" & tablename & "->" & fieldname
      Else
         For i = 0 To rec1.Fields.Count - 1
              If rec1(i) <> rec2(i) Then Msg = Msg & vbCrLf & "不同:" & tablename & "->" & fieldname & ">>" & rec1(i).Name
         Next
      End If
    End If
  End If
  rec1.MoveNext
Loop
rec2.Filter = 0
If rec2.RecordCount > 0 Then rec2.MoveFirst
tablename = ""
flag = False
Do While rec2.EOF = False
  If tablename <> rec2.Fields("表名") Or flag = False Then
     flag = False
     tablename = rec2.Fields("表名")
     fieldname = rec2.Fields("字段名")
     rec1.Filter = "表名='" & tablename & "'"
     If rec1.RecordCount = 0 Then
        Msg = Msg & vbCrLf & "目标1欠:" & tablename
        flag = True
     Else
        rec1.Filter = "表名='" & tablename & "' and 字段名='" & fieldname & "'"
        If rec1.RecordCount = 0 Then Msg = Msg & vbCrLf & "目标1欠:" & tablename & "->" & fieldname
     End If
  End If
  rec2.MoveNext
Loop
checkTable = IIf(Msg = "", "表的结构完全相同", Msg)
rec1.Close
rec2.Close
End Function
'------------------------------------------------
'比校两个数据库中的存储过程，函数，视图，触发器
'------------------------------------------------
Private Function CheckProc() As String
Dim rec1 As ADODB.Recordset, rec2 As ADODB.Recordset
Dim Msg As String
Set rec1 = getProcMsg(Cnn1)
Set rec2 = getProcMsg(Cnn2)
Do While rec1.EOF = False
   rec2.Filter = rec2.Fields(0).Name & "='" & rec1(0) & "'"
   If rec2.RecordCount = 0 Then
      Msg = Msg & vbCrLf & "目标2欠:" & rec1(0)
   Else
      If getProcAll(Cnn1, rec1(0)) <> getProcAll(Cnn2, rec1(0)) Then Msg = Msg & vbCrLf & "两者不同:" & rec1(0)
   End If
   rec1.MoveNext
Loop
rec2.Filter = 0
If rec2.RecordCount > 0 Then rec2.MoveFirst
Do While rec2.EOF = False
   rec1.Filter = rec1.Fields(0).Name & "='" & rec2(0) & "'"
   If rec1.RecordCount = 0 Then Msg = Msg & vbCrLf & "目标1欠:" & rec2(0)
   rec2.MoveNext
Loop
CheckProc = IIf(Msg = "", "存储过程，函数，视图，触发器完全相同", Msg)
rec1.Close
rec2.Close
End Function
'---------------------------------------------------
'获取SQLSERVER所有表及字段信息的结构
'---------------------------------------------------
Private Function getTableMsg(Cnn As ADODB.Connection) As ADODB.Recordset
Dim rec As ADODB.Recordset, sql As String
Set rec = New ADODB.Recordset
sql = LoadResString(102)   '读资源文件102
rec.Open sql, Cnn, adOpenStatic, adLockReadOnly
Set getTableMsg = rec
End Function
'----------------------------------------------------
'获取SQLSERVER所有存储过程，函数，视图，触发器的名称
'-----------------------------------------------------
Private Function getProcMsg(Cnn As ADODB.Connection) As ADODB.Recordset
Dim rec As ADODB.Recordset
Set rec = New ADODB.Recordset
rec.Open "select [name] as a from sysobjects where (xtype='FN' or xtype='TF' or xtype='IF' or xtype='P' or xtype='V' or xtype='TR' ) and category=0", _
    Cnn, adOpenStatic, adLockReadOnly
Set getProcMsg = rec
End Function
'------------------------------------------------
'读取存储过程，函数，视图，触发器的源代码
'------------------------------------------------
Private Function getProcAll(Cnn As ADODB.Connection, ProcName As String) As String
 Dim st As String, rec As New ADODB.Recordset
 Set rec = Cnn.Execute("#sp_decrypt '" & ProcName & "' ", , adCmdText)
 Do While rec.EOF = False
    st = st & rec(0)
    rec.MoveNext
 Loop
 rec.Close
 getProcAll = st
End Function
'------------------------------------------------
'连接数据服务器
'------------------------------------------------
Private Function conn(Cnn As ADODB.Connection, ServerName As String, DataBase As String, UserName As String, password As String)
 Cnn.CursorLocation = adUseClient
 Cnn.CommandTimeout = 60
 If UserName = "." Then
    Cnn.ConnectionString = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;" & _
    "Initial Catalog=" & DataBase & ";Data Source=" & ServerName
    Cnn.Open
 Else
   Cnn.ConnectionString = "Provider=SQLOLEDB.1;Persist Security Info=True;Data Source=" & ServerName & ";Initial Catalog=" & DataBase & ";"
   Cnn.Open , UserName, password
 End If
End Function
'---------------------------------------------------------------------
'创建读取SQLSERVER2000存储过程，函数，视图，触发器的临时存储过程
'---------------------------------------------------------------------
Private Sub createProc(Cnn As ADODB.Connection)
Dim sql As String
sql = LoadResString(101)   '读资源文件101
Cnn.Execute sql
End Sub

'-----------------------------------
'读ini文件
'-----------------------------------
Public Function GetProfileString(ApplicationName As String, KeyName As String, DefaultString As String, FileName As String) As String()
Dim RetString As String * 128, Retvalue As Long, i As Integer, j As Integer, ret() As String
 If KeyName = "" Then KeyName = vbNullString
 Retvalue = (GetPrivateProfileString(ApplicationName, KeyName, DefaultString, RetString, 128, FileName))
 ReDim ret(0)
 If Retvalue > 0 Then
    Do
       Do While Left(RetString, 1) = Chr(0) '删除开头的空白
          RetString = Mid(RetString, 2)
       Loop
       i = InStr(1, RetString, Chr(0), vbTextCompare)
       If i = 0 Then Exit Do
       ReDim Preserve ret(j) As String
       ret(j) = Left(RetString, i - 1)
       j = j + 1
       RetString = Mid(RetString, i + 1)
    Loop
End If
GetProfileString = ret
End Function

//ini文件如下

[DataBase1]
serverName=.
Database=test1
UserName=.
password=

[DataBase2]
serverName=.
Database=test2
UserName=.
password=

//
//资源文件(101)
//
--适用于SQLSERVER2000存储过程，函数，视图，触发器
--破解SQL SERVER 加密存储过程,函数,触发器,视图 由CSDNj9988@tom.com 提供
Create  PROCEDURE #sp_decrypt(@objectName varchar(50))
AS
begin
set nocount on
begin tran
declare @objectname1 varchar(100),@orgvarbin varbinary(8000)
declare @sql1 nvarchar(4000),@sql2 varchar(8000),@sql3 nvarchar(4000),@sql4 nvarchar(4000)
DECLARE @OrigSpText1 nvarchar(4000), @OrigSpText2 nvarchar(4000) , @OrigSpText3 nvarchar(4000), @resultsp nvarchar(4000)
declare @i int,@status int,@type varchar(10),@parentid int
declare @colid int,@n int,@q int,@j int,@k int,@encrypted int,@number int
select @type=xtype,@parentid=parent_obj from sysobjects where id=object_id(@ObjectName)
create table #tmdivs(rst nvarchar(4000))
create table #temp(number int,colid int,ctext varbinary(8000),encrypted int,status int)
insert #temp SELECT number,colid,ctext,encrypted,status FROM syscomments WHERE id = object_id(@objectName)
select @number=max(number) from #temp
set @k=0

while @k<=@number
  begin
  if exists(select 1 from syscomments where id=object_id(@objectname) and number=@k)
  begin
    if @type='P'
        set @sql1=(case when @number>1 then 'ALTER PROCEDURE '+ @objectName +';'+rtrim(@k)+' WITH ENCRYPTION AS ' else 'ALTER PROCEDURE '+ @objectName+' WITH ENCRYPTION AS ' end)

    if @type='TR'
       set @sql1='ALTER TRIGGER '+@objectname+' ON '+OBJECT_NAME(@parentid)+' WITH ENCRYPTION FOR INSERT AS PRINT 1 '

    if @type='FN' or @type='TF' or @type='IF'
       set @sql1=(case @type when 'TF' then
           'ALTER FUNCTION '+ @objectName+'(@a char(1)) returns @b table(a varchar(10)) with encryption as begin insert @b select @a return end '
       when 'FN' then
           'ALTER FUNCTION '+ @objectName+'(@a char(1)) returns char(1) with encryption as begin return @a end'
       when 'IF' then
       'ALTER FUNCTION '+ @objectName+'(@a char(1)) returns table with encryption as return select @a as a'
       end)

    if @type='V'
       set @sql1='ALTER VIEW '+@objectname+' WITH ENCRYPTION AS SELECT 1 as f'

    set @q=len(@sql1)
    set @sql1=@sql1+REPLICATE('-',4000-@q)
    select @sql2=REPLICATE('-',8000)
    set @sql3='exec(@sql1'
    select @colid=max(colid) from #temp where number=@k
    set @n=1
    while @n<=CEILING(1.0*(@colid-1)/2) and len(@sQL3)<=3996
    begin
        set @sql3=@sql3+'+@'
        set @n=@n+1
    end
    set @sql3=@sql3+')'
    exec sp_executesql @sql3,N'@Sql1 nvarchar(4000),@ varchar(8000)',@sql1=@sql1,@=@sql2

  end  --if
  set @k=@k+1
end --while @k<=@number

set @k=0
while @k<=@number
   begin
   if exists(select 1 from syscomments where id=object_id(@objectname) and number=@k)
      begin
      select @colid=max(colid) from #temp where number=@k
      set @n=1

      while @n<=@colid
         begin
         select @OrigSpText1=ctext,@encrypted=encrypted,@status=status FROM #temp WHERE colid=@n and number=@k

         SET @OrigSpText3=(SELECT ctext FROM syscomments WHERE id=object_id(@objectName) and colid=@n and number=@k)
         if @n=1
            begin
            if @type='P'
               SET @OrigSpText2=(case when @number>1 then 'CREATE PROCEDURE '+ @objectName +';'+rtrim(@k)+' WITH ENCRYPTION AS ' else 'CREATE PROCEDURE '+ @objectName +' WITH ENCRYPTION AS '  end)

            if @type='FN' or @type='TF' or @type='IF'--刚才有错改一下
               SET @OrigSpText2=(case @type when 'TF' then
                  'CREATE FUNCTION '+ @objectName+'(@a char(1)) returns @b table(a varchar(10)) with encryption as begin insert @b select @a return end '
               when 'FN' then
                    'CREATE FUNCTION '+ @objectName+'(@a char(1)) returns char(1) with encryption as begin return @a end'
               when 'IF' then
                   'CREATE FUNCTION '+ @objectName+'(@a char(1)) returns table with encryption as return select @a as a'
               end)

            if @type='TR'
                  set @OrigSpText2='CREATE TRIGGER '+@objectname+' ON '+OBJECT_NAME(@parentid)+' WITH ENCRYPTION FOR INSERT AS PRINT 1 '

            if @type='V'
                set @OrigSpText2='CREATE VIEW '+@objectname+' WITH ENCRYPTION AS SELECT 1 as f'
                set @q=4000-len(@OrigSpText2)
                set @OrigSpText2=@OrigSpText2+REPLICATE('-',@q)
         end
         else
             begin
               SET @OrigSpText2=REPLICATE('-', 4000)
         end  --@n=1
         SET @i=1

         SET @resultsp = replicate(N'A', (datalength(@OrigSpText1) / 2))

         WHILE @i<=datalength(@OrigSpText1)/2
            BEGIN

            SET @resultsp = stuff(@resultsp, @i, 1, NCHAR(UNICODE(substring(@OrigSpText1, @i, 1)) ^
                 (UNICODE(substring(@OrigSpText2, @i, 1)) ^
             UNICODE(substring(@OrigSpText3, @i, 1)))))
     SET @i=@i+1
        END
        set @orgvarbin=cast(@OrigSpText1 as varbinary(8000))
        set @resultsp=(case when @encrypted=1
      then @resultsp
      else convert(nvarchar(4000),case when @status&2=2 then uncomdivss(@orgvarbin) else @orgvarbin end)
      end)
        --print @resultsp
        insert into #tmdivs (rst) values (@resultsp)
      set @n=@n+1
     end
   end
set @k=@k+1
end
set nocount off
select * from #tmdivs
set nocount on
drop table #temp
rollback tran
end
//
//资源文件(102)
//
--获取SQLSERVER字段信息的原型语句
SELECT
d.name  表名,
a.colorder 字段序号,
a.name 字段名,
(case when COLUMNPROPERTY( a.id,a.name,'IsIdentity')=1 then '√'else '' end) 标识,
(case when (SELECT count(*)
  FROM sysobjects
   WHERE (name in
  (SELECT name
    FROM sysindexes
     WHERE (id = a.id) AND (indid in
  (SELECT indid
    FROM sysindexkeys
     WHERE (id = a.id) AND (colid in
  (SELECT colid
    FROM syscolumns
     WHERE (id = a.id) AND (name = a.name))))))) AND
     (xtype = 'PK'))>0 then '√' else '' end) 主键,
 b.name 类型,
 a.length 占用字节数,
 COLUMNPROPERTY(a.id,a.name,'divCISION') as 长度,
 isnull(COLUMNPROPERTY(a.id,a.name,'Scale'),0) as 小数位数,
 (case when a.isnullable=1 then '√'else '' end) 允许空,
 isnull(e.text,'') 默认值,
 isnull(g.[value],'') AS 字段说明   
  FROM  syscolumns  a
    left join systypes b on  a.xtype=b.xusertype
      inner join sysobjects d on a.id=d.id  and  d.xtype='U' and  d.name<>'dtproperties'
    left join syscomments e on a.cdefault=e.id
    left join sysproperties g on a.id=g.id AND a.colid = g.smallid 
 order by a.id,a.colorder

 

本文来源：http://blog.csdn.net/gdcyh/archive/2007/08/11/1737775.aspx