查询数据库所有表所有字段的某个值，生成更新代码 (VB)

以下是公共模块

Option 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

 

 

以下是窗体代码：

 

 

VERSION 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