以下是公共模块
CodeOption Explicit
Public StrC As String
Public Function ExecSql(sql As String, msgString As String) As ADODB.Recordset
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim sTokens() As String
On Error GoTo myerr
'sql = CheckYingHao(sql)
sTokens = Split(sql)
Set cnn = New ADODB.Connection
With cnn
.CursorLocation = adUseClient
'.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\book.mdb" _
& ";Persist Security Info=False"
.ConnectionString = StrC
.Open
End With
If InStr("IF,EXEC,EXECUTE,INSERT,DELETE,UPDATE,CREATE,DROP", UCase(sTokens(0))) Then
Set rst = cnn.Execute(sql)
msgString = "更新数据完成"
Else
Set rst = New ADODB.Recordset
rst.Open sql, cnn, adOpenKeyset, adLockOptimistic
msgString = "查询到" & rst.RecordCount & "条记录"
End If
Set ExecSql = rst
myc:
'rst.Close
'cnn.Close
'Set rst = Nothing
'Set cnn = Nothing
Exit Function
myerr:
msgString = "查询错误;" & Err.Description '& vbCrLf & sql
'Debug.Print sql
Debug.Print msgString
'Clipboard.SetText msgString
Resume myc
End Function
'该过程获得用某一个值,如果错误，返回空
Public Function GetName(Usersql As String, Optional msg As Boolean = True) As String
Dim mystr As String
Dim rs As New ADODB.Recordset
Set rs = ExecSql(Usersql, mystr)
If Left(mystr, 4) = "查询错误" Then
If msg Then MsgBox mystr, vbCritical
GetName = ""
Exit Function
End If
If rs.EOF Then
'MsgBox "用户名不存在，请重试", vbExclamation
GetName = ""
Exit Function
End If
GetName = rs.Fields(0) & ""
End Function
以下是窗体代码：
CodeVERSION 5.00
Begin VB.Form Form1
Caption = "替换"
ClientHeight = 7680
ClientLeft = 60
ClientTop = 345
ClientWidth = 10650
LinkTopic = "Form1"
ScaleHeight = 7680
ScaleWidth = 10650
StartUpPosition = 3 '窗口缺省
Begin VB.TextBox Text4
Height = 4575
Left = 120
MultiLine = -1 'True
ScrollBars = 3 'Both
TabIndex = 7
Top = 2880
Width = 10455
End
Begin VB.TextBox Text3
Height = 375
Left = 1440
TabIndex = 5
Text = "Provider=SQLOLEDB;Data Source=.\sqlexpress;Initial Catalog=test;User ID=sa;Password=12345678"
Top = 1440
Width = 8535
End
Begin VB.TextBox Text2
Height = 375
Left = 1440
TabIndex = 2
Text = "SZX"
Top = 840
Width = 8535
End
Begin VB.CommandButton Command1
Caption = "开始"
Height = 495
Left = 2760
TabIndex = 1
Top = 2040
Width = 4575
End
Begin VB.TextBox Text1
Height = 375
Left = 1440
TabIndex = 0
Text = "SFT"
Top = 240
Width = 8535
End
Begin VB.Label lblP
AutoSize = -1 'True
Caption = "Cick it"
Height = 180
Left = 7800
TabIndex = 8
Top = 2160
Width = 630
End
Begin VB.Label Label2
AutoSize = -1 'True
Caption = "数据库:"
Height = 180
Left = 480
TabIndex = 6
Top = 1560
Width = 630
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "替换:"
Height = 180
Index = 1
Left = 480
TabIndex = 4
Top = 960
Width = 450
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "查找:"
Height = 180
Index = 0
Left = 480
TabIndex = 3
Top = 360
Width = 450
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim mystr As String
Dim b As Boolean
Private Sub Command1_Click()
If Command1.Caption = "开始" Then
Command1.Caption = "停止"
StrC = Text3.Text
Text4.Text = ""
Call start
'Command1_Click
Command1.Caption = "开始"
ElseIf Command1.Caption = "停止" Then
Command1.Caption = "开始"
End If
End Sub
Sub start()
Dim rs As New ADODB.Recordset
Dim rs1 As New ADODB.Recordset
Dim t As String
Dim f As String
Dim i1 As Long, i2 As Long, i3 As Long, i4 As Long
Set rs = ExecSql("select name from sysobjects where type='U' ", mystr)
If rs.EOF Then Exit Sub
i1 = 0
i2 = 0
i3 = 0
rs.MoveLast
rs.MoveFirst
i4 = rs.RecordCount
SetLab i1, i2, i3, i4
Do While Not rs.EOF
If Command1.Caption = "开始" Then Exit Sub
DoEvents
i3 = i3 + 1
SetLab i1, i2, i3, i4
t = "[" & rs.Fields(0) & "]"
't = t & Space(40 - Len(t))
Set rs1 = ExecSql("Select Name from SysColumns Where id=Object_Id('" & t & "') and xtype in ( select xtype from systypes where name in ( 'varchar ', 'nvarchar', 'char', 'nchar') )", mystr)
If Not rs1.EOF Then
rs1.MoveLast
rs1.MoveFirst
i2 = rs1.RecordCount
Do While Not rs1.EOF
DoEvents
i1 = i1 + 1
SetLab i1, i2, i3, i4
f = "[" & rs1.Fields(0) & "]"
If Val(GetName(" select count(1) from " & t & " where " & f & " = '" & Text1.Text & "'")) > 0 Then
Text4.Text = Text4.Text & " update " & t & Space(40 - Len(t)) & " set " & f & Space(30 - Len(f)) & "='" & Text2.Text & "' where " & f & Space(30 - Len(f)) & " = '" & Text1.Text & "'" & vbCrLf
End If
rs1.MoveNext
Loop
End If
i1 = 0
rs.MoveNext
Loop
End Sub
Sub SetLab(i1 As Long, i2 As Long, i3 As Long, i4 As Long)
lblP.Caption = "Current:" & i1 & "/" & i2 & vbCrLf & "Total:" & i3 & "/" & i4
Text4.SelStart = Len(Text4.Text)
End Sub