'''
'''在服务器上动行时提示value 的field 方法失败。
'''
'''
Option Explicit
Dim Conn As New ADODB.Connection 'SQL SERVER 的连接
Dim RsTabList As New ADODB.Recordset '要改动的表名列表
Dim RsDeptOldNew As New ADODB.Recordset '新旧部门对照表
Dim RsOldTab As New ADODB.Recordset '要被改动的旧表
'Dim CmUpdate As New ADODB.Command '调用更改存贮过程
Dim strTabName As String '要发生变动的表名
Dim strFieldName As String '表中要改变的字段名
Dim strOldDeptCode As String '旧的部门编号
Dim strNewDeptCode As String '新的部门编号
Dim strSQL As String
---------------------------------------------------------------
Private Sub Command1_Click()
With Conn '打开连接
.Provider = "SQLOLEDB"
.CursorLocation = adUseServer
.Properties("Data Source") = "love"
.Properties("Initial Catalog") = "Test"
.Properties("User Id") = "sa"
.Properties("Password") = ""
.Properties("prompt") = adPromptNever
.Open
DoEvents
End With
' With CmUpdate
' .ActiveConnection = Conn
'
' End With
With RsTabList '打开要改动的表名列表
.ActiveConnection = Conn
.Source = "select * from bsjTab"
.Open
End With
With StepMain
'RsTabList.MoveLast
'RsTabList.MoveFirst
.Value = 0
.Max = 19 'RsTabList.RecordCount
.Min = 0
End With
Do Until RsTabList.EOF '循环开始
strTabName = Trim(RsTabList!tabName) '取表名
strFieldName = Trim(RsTabList!myField) '取字段名
Label1.Caption = "正在更改“" & strTabName & "”表……"
strSQL = "select * from " & strTabName
With RsOldTab
.ActiveConnection = Conn
.CursorLocation = adUseServer
.Source = strSQL
.Open '打开要被改动的旧表
End With
If (Not RsOldTab.EOF) And (Not RsOldTab.BOF) Then
With Step
'RsOldTab.MoveLast
'RsOldTab.MoveFirst
.Value = 0
.Max = 1000 'RsOldTab.RecordCount
.Min = 0
End With
End If
Do Until RsOldTab.EOF '循环开始
'取得旧部门编号
strOldDeptCode = Trim(RsOldTab.Fields(strFieldName).Value)
'取得新部门编号
strNewDeptCode = Trim(GetNewDeptCode(strOldDeptCode))
'更改部门编号
RsOldTab.Fields(strFieldName).Value = strNewDeptCode
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'提示value 的field 方法失败
Stop
'strSQL = "update " & strTabName & " set " & strFieldName & "='" & strNewDeptCode & "' where " & strFieldName & " = " & strOldDeptCode
'Conn.Execute strSQL
RsOldTab.Update
RsOldTab.MoveNext
Step.Value = Step.Value + 1
DoEvents
Loop '循环结束
RsOldTab.Close '关闭被打开的旧表
RsTabList.MoveNext
StepMain.Value = StepMain.Value + 1
DoEvents
Loop '循环结束
RsTabList.Close
Conn.Close
End Sub
------------------------------------------------------------------
Function GetNewDeptCode(ByVal strDeptCode) As String
'根据旧部门编号取得新部门编号
strSQL = "select * from bsjDept where oldCode='" & strDeptCode & "'"
RsDeptOldNew.Open strSQL, Conn
GetNewDeptCode = RsDeptOldNew!newCode
RsDeptOldNew.Close
End Function
-----------------------------------------------------------------
Private Sub Form_Unload(Cancel As Integer)
Set RsTabList = Nothing
Set RsDeptOldNew = Nothing
Set RsOldTab = Nothing
Set Conn = Nothing
End Sub
