Oscar Sun on SnipSave | Web-based code snippet manager for developers

ADO SQL 變數參數查詢範例-漢字轉拼音

View Snippet

                    Sub 漢字轉拼音()
'F2
Const fpath As String = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Users\ssz3\Google 雲端硬碟\私人\VB\詞典.mdb" 

Dim rst As New ADODB.Recordset
Dim cnt As New ADODB.Connection
'Dim p As New ADODB.Parameter
Dim x As String, y As String
Dim cmd As New ADODB.Command
If Selection.Type = wdSelectionNormal Then
    x = Selection
    Selection.Copy
Else
    x = Selection.Previous
End If
cnt.Open fpath
Set cmd.ActiveConnection = cnt
cmd.CommandText = "SELECT 字.字, 拼音.拼音 FROM 拼音 INNER JOIN (字 INNER JOIN 字_注音 ON 字.字ID = 字_注音.字ID) ON 拼音.拼音ID = 字_注音.拼音ID" _
        & " WHERE (((字.字)=""" & x & """));"
cmd.CommandType = adCmdText
rst.Open cmd
If rst.EOF Then
    Beep
Else
    'y = "（" & rst.Fields("拼音").Value & "）"
    y = rst.Fields("拼音").Value
    With Selection
        .Collapse wdCollapseEnd
        .TypeText y
        .MoveLeft wdCharacter, Len(y), wdExtend
        .Font.NameAscii = "NSimSun"
        .Font.ColorIndex = wdRed
        .Font.Size = 16
        .Range.HighlightColorIndex = wdYellow
        .Collapse wdCollapseEnd
    End With
    Selection.Document.Save
End If
rst.Close
cnt.Close

End Sub

ADO 參數查詢範例 4808部件

View Snippet

                    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

On Error GoTo eH

View Snippet

                    On Error GoTo eH

Exit Sub
eH:
Select Case Err.Number
    Case 591 '集合中成員不存在
    Case Else
        Debug.Print Err.Number & Err.Description
        MsgBox Err.Number & Err.Description, vbCritical
'        Stop
'        Resume
End Select

自動填滿序欄位() \'有合併儲存格的情形下\'2016/1/5

View Snippet

                    Sub 自動填滿序欄位() '有合併儲存格的情形下'2016/1/5
On Error GoTo eH
Dim clm As Column
Dim r As Long, c As Cell
Set clm = ThisDocument.Tables(1).Columns(1)
r = clm.Cells.Count
For i = 2 To r
   clm.Cells(i).Range = i - 1
Next
MsgBox "DONE!!", vbInformation
Exit Sub
eH:
Select Case Err.Number
    Case 13 '        型態不符合
        Resume Next
    Case Else
        Debug.Print Err.Number & Err.Description
        MsgBox Err.Number & Err.Description, vbCritical
'        Stop
'        Resume
End Select
End Sub

以選取文字作為書籤

View Snippet

                    Sub 書籤_以選取文字作為書籤() 'ALT+SHIFT+B

' 巨集錄製於 2015/9/20，錄製者 王觀如
    With ActiveDocument.Bookmarks
        .Add Range:=Selection.Range, Name:=Replace(Selection.Text, Chr(13), "")
        .DefaultSorting = wdSortByName
        .ShowHidden = False
    End With
End Sub