Oscar Sun
孫守真任真甫 https://github.com/oscarsun72 http://www.facebook.com/oscarsun72 http://bit.ly/2rnOu8Z
https://oscarsun72.blogspot.com/@oscarsun72ADO 參數查詢範例 4808部件
Sub d()
On Error GoTo eH
Dim x4808 As String
Dim tb As Table, tb2 As Table, cnt As New ADODB.Connection, rst As New ADODB.Recordset, cmd As New ADODB.Command, objparam As New ADODB.Parameter
'Dim flg As Boolean
Dim flg2 As Boolean
Dim timeStart As Date, timeEnd As Date
Dim Wcheck As String, ww As String, t As Integer, myRng As Range ', cpRng As Range
'Dim c() As String, tb2Row As Long
Dim d As Document, inlSp As InlineShape
Dim a
timeStart = Now
x4808 = Left(ActiveDocument.Range, 4808)
ActiveDocument.Close
'Set d = Documents(2) '檢查字圖是否都有描述,以供日後檢索
'For Each inlSp In d.InlineShapes
' If inlSp.AlternativeText = "" Then
' MsgBox "請輸入此字圖的命名描述,以便日後檢索;輸入完畢後再繼續!", vbExclamation
' inlSp.Select
' d.Activate
' End
' End If
'Next
'Set inlSp = Nothing
'Set d = Nothing
Set tb = Documents(2).Tables(1)
Set tb2 = ThisDocument.Tables(1)
r = tb.Rows.Count
cnt.Open "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=" & ThisDocument.Path & "\!!!!!4808部件最全20151217.mdb"
Set cmd.ActiveConnection = cnt
'cmd.CommandText = "tb5Check"
'cmd.CommandType = adCmdText
cmd.CommandType = adCmdStoredProc
cmd.CommandText = "tb5Check"
'Set objparam = cmd.CreateParameter("wq", adBSTR, adParamInput, 2, a)
'cmd.Parameters.Append objparam
rst.CursorType = adOpenStatic 'adOpenKeyset'adOpenForwardOnly 不行!
rst.LockType = adLockReadOnly 'adLockOptimistic
'rst.Open cmd
'rst.Open "tb5", cnt, adOpenStatic ' adOpenKeyset
Set myRng = ThisDocument.Range
'Set cpRng = Documents(2).Range
For i = 2 To r
If i Mod 54 = 0 Then
MsgBox "!!!", vbExclamation
Documents(1).ActiveWindow.Selection.Find.Execute a
Debug.Print Selection.Cells(1).RowIndex
Stop
End If
If tb.Cell(i, 2).Range.InlineShapes.Count > 0 Then
'tb.Cell(i, 2).Range.Copy
' cpRng.SetRange tb.Cell(i, 2).Range.Start, tb.Cell(i, 2).Range.End - 2
' cpRng.InlineShapes(1).Range.Copy
tb.Cell(i, 2).Range.InlineShapes(1).Range.Copy
flg2 = True
Else
flg2 = False
ww = Left(tb.Cell(i, 2).Range, Len(tb.Cell(i, 2).Range) - 2)
End If
For Each a In tb.Cell(i, 6).Range.Characters
'If a <> Chr(13) & Chr(7) And a <> "（" And a <> "）" And a <> Chr(13) And a <> Chr(32) Then
If InStr(x4808, a) Then
' If a = Chr(13) Or a = Chr(32) Then
' MsgBox "分段符號或半形空格", vbExclamation
' Stop
' End If
ws = InStr(Wcheck, a)
If ws = 0 Then
If Len(a) > 1 Then '若字元長度大於1則須用陣列了
MsgBox "!!!", vbExclamation
Documents(1).ActiveWindow.Selection.Find.Execute a
Debug.Print Selection.Cells(1).RowIndex
Stop
End If
Wcheck = Wcheck & a
' ReDim Preserve c(j)
' c(j) = a
j = j + 1
tb2.Cell(j, 1).Range.Text = a
' cmd.CommandText = "Select * From tb5 Where strcomp(字, """ & a & """)=0" ' = """ & a & """" '"tb5Check"
Set objparam = cmd.CreateParameter("wq", adBSTR, adParamInput, 2, a)
cmd.Parameters.Append objparam
rst.Open cmd
' With rst
' Do Until .EOF
' If StrComp(.Fields(0).Value, a) = 0 Then
' flg = True
' Exit Do
' End If
' .MoveNext
' Loop
' End With
' If flg Then
If rst.RecordCount > 0 Then
x = rst.Fields(2).Value
' rst.Delete
Else
x = ""
End If
cmd.Parameters.Delete (0)
rst.Close
' rst.MoveFirst
' flg = False
tb2.Cell(j, 2).Range.Text = x
If flg2 Then
tb2.Cell(j, 3).Range.Paste
Else
tb2.Cell(j, 3).Range = ww
End If
tb2.Rows.Add
Else '已經有此字了
' 'If flg2 Then
'' tb2.Columns(1).Select
'' fd = tb2.Range.Document.ActiveWindow.Selection.Find.Execute(a, , , , , , , wdFindStop)
''' fd = tb2.Range.Document.Range.Find.Execute(a, , , , , , , wdFindStop)
'' If fd Then
'' ks = Selection.Cells(1).RowIndex
''' ks = tb2.Range.Document.Range.Cells(1).RowIndex
'' Else
'' ks = 1
'' End If
' For Each cc In c()
' tb2Row = tb2Row + 1
' If cc = a Then Exit For
' Next
r2 = tb2.Rows.Count
ks = ws
' If ks <> tb2Row Then
'
' MsgBox "!!!", vbExclamation
' Documents(1).ActiveWindow.Selection.Find.Execute a
' Debug.Print Selection.Cells(1).RowIndex
' Stop
'
' ks = tb2Row
' End If
For k = ks To r2
If StrComp(tb2.Cell(k, 1).Range.Text, a & Chr(13) & Chr(7)) = 0 Then
If flg2 Then
' 'Set myRng = tb2.Cell(k, 3).Range
myRng.SetRange tb2.Cell(k, 3).Range.Start, tb2.Cell(k, 3).Range.Start
' If tb2.Cell(k, 3).Range.InlineShapes.Count > 0 Then
' tb2.Cell(k, 3).Range.Select
' MsgBox "!", vbExclamation
' Stop
' End If
' ' If myRng.InlineShapes.Count > 0 Then
' ' myRng.Select
' ' Stop
' ' myRng.InsertAfter " "
' '' myRng.Collapse Direction:=wdCollapseEnd
' '' myRng.MoveEnd Unit:=wdCharacter, Count:=-2
' '' myRng.EndOf 1, wdExtend '.mover wdCharacter,
' ' myRng.SetRange myRng.Start + 1, myRng.Start + 1
' ' End If
' ' MsgBox "!!", vbInformation
' ' myRng.Select
myRng.Paste
Else
tb2.Cell(k, 3).Range.InsertAfter ww
End If
flg3 = True
Exit For
End If
Next
If flg3 = False Then
MsgBox "!!!", vbExclamation
Documents(1).ActiveWindow.Selection.Find.Execute a
Debug.Print Selection.Cells(1).RowIndex
Stop
End If
flg3 = False
' End If
End If
' If InStr(Wcheck, a) Then
' MsgBox "!!!", vbExclamation
' Documents(1).ActiveWindow.Selection.Find.Execute a
' Debug.Print Selection.Cells(1).RowIndex & vbTab & Len(Wcheck) & vbTab & UBound(c) & vbTab & ws & vbTab & tb2Row & vbTab & a
' Stop
' End If
tb2Row = 0
End If
Next
flg2 = False
t = 0
Next
timeEnd = Now
MsgBox "Done!" & vbCr & vbLf & timeStart & vbTab & timeEnd, vbInformation
Exit Sub
eH:
Stop
Select Case Err.Number
Case 4605 '剪貼簿是空的
tb.Cell(i, 2).Range.InlineShapes(1).Range.Select
' tb.Cell(i, 2).Range.InlineShapes(1).Range.Copy
Documents(2).ActiveWindow.Selection.Copy
t = t + 1
If t > 3 Then
MsgBox "請手動複製", vbExclamation
Stop
End If
Resume
Case Else
MsgBox Err.Number & Err.Description
tb2.Cell(k, 3).Range.Select
tb.Cell(i, 2).Range.InlineShapes(1).Range.Select
Documents(1).ActiveWindow.Selection.Copy
Stop
Resume
End Select
End Sub