檢查可能未標點者、檢查卦名不加書名號 | by Oscar Sun on SnipSave | Web-based code snippet manager for developers

檢查可能未標點者、檢查卦名不加書名號 vbscript

                  Option Explicit
Dim cnt As New ADODB.Connection
Const dbF As String = "E:\@@@華語文工具及資料@@@\Macros\說文資料庫原造字取代為系統字參照用.mdb"
Sub 易學書加書名號() '目前不止於易學書
Dim rst As New ADODB.Recordset ', i As Long
Dim d As Document, rng As Range, rText As String
Set d = ActiveDocument
Set rng = d.Range(1, d.Range.End) '只操作指定點之後的文本
'Set rng = d.Range(Selection.End, d.Range.End) '只操作插入點之後的文本
If cnt.State = 0 Then cnt.Open "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=" & dbF
'rst.Open "select * from 《易》學書標書名號 where (組別=" & 7 & " or 先後順序 =10000 or 先後順序 =99999) order by 先後順序,ID", cnt  '要取代哪一組格式的文字
rst.Open "select * from 《易》學書標書名號 where (組別=1 or 組別=7 or 組別=8 or 組別=9 or 先後順序 =10000 or 先後順序 =99999) order by 組別,先後順序,ID", cnt  '要取代哪一組格式的文字
Application.ScreenUpdating = False
With rst
    Do Until .EOF
        If InStr(rng.Text, .Fields("須標書名號字詞").Value) > 0 Then
'            i = i + 1
'            If i Mod 20 = 0 Then d.UndoClear
            rng.Find.ClearFormatting
            rng.Find.ClearAllFuzzyOptions
            If VBA.IsNull(.Fields("標成書名號結果").Value) Then
                rText = "《" & .Fields("須標書名號字詞").Value & "》"
            Else
                rText = .Fields("標成書名號結果").Value
            End If
            rng.Find.Execute .Fields("須標書名號字詞").Value, , , , , , True, wdFindStop, , rText, wdReplaceAll
            '若用 wdFindContinue仍會取代前面部分
        End If
        .MoveNext
    Loop
End With
Do While rng.Find.Execute("《《", , , , , , True, wdFindStop, , "《", wdReplaceAll)
Loop
Do While rng.Find.Execute("》》", , , , , , True, wdFindStop, , "》", wdReplaceAll)
Loop
Application.ScreenUpdating = True
Application.ScreenRefresh
Beep
d.Save
'MsgBox "done!", vbInformation
rst.Close: Set rst = Nothing
End Sub
Sub 檢查可能未標點者()
Dim rst As New ADODB.Recordset, d As Document, r As Range, x As String, e As Long
Dim rstPass As New ADODB.Recordset
If cnt.State = 0 Then cnt.Open "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=" & dbF
Set d = ActiveDocument
Set r = d.Range
'rst.Open "select * from 《易》學書標書名號 where (組別=1 or 組別=7 or 組別=8 or 組別=9 or 先後順序 =10000 or 先後順序 =99999) order by 組別,先後順序,ID", cnt  '要取代哪一組格式的文字
'rst.Open "《易》學書標書名號", CNT, adOpenKeyset, adLockReadOnly
rst.Open "select * from 《易》學書標書名號 where 組別<>64 and 組別<>2 and 組別<>3 and 組別<>4", cnt, adOpenKeyset, adLockReadOnly
With rst
    Do Until .EOF
        x = .Fields("須標書名號字詞").Value
        If InStr(d.Range, x) > 0 Then
            rstPass.Open "select 略過不標書名號,字長 from 《易》學書標書名號_略過不標者 where instr(略過不標書名號,""" & x & """)>0", cnt, adOpenKeyset, adLockOptimistic
            Set r = d.Range
            r.Find.ClearAllFuzzyOptions: r.Find.ClearFormatting
            Do While r.Find.Execute(x, , , , , , True, wdFindStop)
                If (r.Previous <> "《" And r.Previous <> "·" And r.Previous <> "‧") And (r.Next <> "·" And r.Next <> "》" And r.Next <> "‧") And r.HighlightColorIndex = 0 Then
                    e = r.End
'                    r.Select
'                    Stop
                    chkPass rstPass, r, e, x
                    'If rstPass.RecordCount > 0 Then rstPass.MoveFirst
                    r.SetRange e, d.Range.End
                End If
            Loop
            rstPass.Close
        End If
        .MoveNext
    Loop
End With
MsgBox "done!", vbInformation
End Sub
Function 比對略過不標書名號(rst As ADODB.Recordset, xR As Range) As Boolean
Dim r As Range, l As Byte, i As Integer, ps As Long
Set r = xR: ps = xR.End
With rst
    If rst.RecordCount > 0 Then
        Do Until .EOF
            l = Len(.Fields("略過不標書名號").Value) '擴充漢字，End屬性一樣是算二個長度
            For i = -l To l
                r.SetRange ps + i, ps + i + l
                If StrComp(r.Text, .Fields("略過不標書名號").Value) = 0 Then
                    比對略過不標書名號 = True
                    .MoveFirst
                    Exit Function
                End If
            Next i
            .MoveNext
        Loop
        .MoveFirst
    End If
End With
End Function
Sub 略過不標書名號(rst As ADODB.Recordset, xSelection As Range)
Dim rstp As New ADODB.Recordset
rstp.Open "select 略過不標書名號 from 《易》學書標書名號_略過不標者 where strcomp(略過不標書名號,""" & xSelection & """)=0", cnt, adOpenKeyset, adLockReadOnly
If rstp.RecordCount = 0 Then
    With rst
        .AddNew
        .Fields("略過不標書名號").Value = xSelection
        .Fields("字長").Value = xSelection.Characters.Count
        .Update
        .Requery
    End With
End If
rstp.Close
End Sub


Sub 檢查卦名不加書名號()
Dim rst As New ADODB.Recordset, rstPass As New ADODB.Recordset
Dim d As Document, rng As Range, e As Long, x As String
Set d = ActiveDocument
'Set rng = d.Range(Selection.End, d.Range.End) '只操作插入點之後的文本
Set rng = d.Range(1, d.Range.End) '只操作指定點之後的文本
rng.Find.ClearFormatting
rng.Find.ClearAllFuzzyOptions
If cnt.State = 0 Then cnt.Open "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=" & dbF
rst.Open "select * from 《易》學書標書名號 where (組別=" & 64 & " ) ", cnt
Application.ScreenUpdating = False

With rst
    Do Until .EOF
        x = .Fields("須標書名號字詞").Value
        If InStr(rng.Text, x) > 0 Then
            rstPass.Open "select 略過不標書名號,字長 from 《易》學書標書名號_略過不標者 where instr(略過不標書名號,""" & x & """)>0", cnt, adOpenKeyset, adLockOptimistic
            Do While rng.Find.Execute(x, , , , , , True, wdFindStop)
                If (rng.Previous = "《" Or rng.Previous = "·" Or rng.Previous = "‧") Or (rng.Next = "·" Or rng.Next = "》" Or rng.Next = "‧") Then
                    rng.Select
                    e = rng.End
                    chkPass rstPass, rng, e, x
                    rng.SetRange e, d.Range.End
                End If
            Loop
            rstPass.Close
        End If
        .MoveNext
        Set rng = d.Range
    Loop
End With
Application.ScreenUpdating = True
Application.ScreenRefresh
Beep
d.Save
MsgBox "done!", vbInformation
rst.Close: Set rst = Nothing
End Sub
Sub chkPass(rstPass As ADODB.Recordset, r As Range, e As Long, findWord As String)
If Not 比對略過不標書名號(rstPass, r) Then
    r.SetRange e - Len(findWord), e
    r.Select: Beep
    Stop
    If Selection.Type <> wdSelectionIP And VBA.Len(Selection.Text) > VBA.Len(findWord) Then 略過不標書名號 rstPass, Selection.Range
End If
End Sub

Option Explicit
Dim cnt As New ADODB.Connection
Const dbF As String = "E:\@@@華語文工具及資料@@@\Macros\說文資料庫原造字取代為系統字參照用.mdb"
Sub 易學書加書名號() '目前不止於易學書
Dim rst As New ADODB.Recordset ', i As Long
Dim d As Document, rng As Range, rText As String
Set d = ActiveDocument
Set rng = d.Range(1, d.Range.End) '只操作指定點之後的文本
'Set rng = d.Range(Selection.End, d.Range.End) '只操作插入點之後的文本
If cnt.State = 0 Then cnt.Open "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=" & dbF
'rst.Open "select * from 《易》學書標書名號 where (組別=" & 7 & " or 先後順序 =10000 or 先後順序 =99999) order by 先後順序,ID", cnt  '要取代哪一組格式的文字
rst.Open "select * from 《易》學書標書名號 where (組別=1 or 組別=7 or 組別=8 or 組別=9 or 先後順序 =10000 or 先後順序 =99999) order by 組別,先後順序,ID", cnt  '要取代哪一組格式的文字
Application.ScreenUpdating = False
With rst
    Do Until .EOF
        If InStr(rng.Text, .Fields("須標書名號字詞").Value) > 0 Then
'            i = i + 1
'            If i Mod 20 = 0 Then d.UndoClear
            rng.Find.ClearFormatting
            rng.Find.ClearAllFuzzyOptions
            If VBA.IsNull(.Fields("標成書名號結果").Value) Then
                rText = "《" & .Fields("須標書名號字詞").Value & "》"
            Else
                rText = .Fields("標成書名號結果").Value
            End If
            rng.Find.Execute .Fields("須標書名號字詞").Value, , , , , , True, wdFindStop, , rText, wdReplaceAll
            '若用 wdFindContinue仍會取代前面部分
        End If
        .MoveNext
    Loop
End With
Do While rng.Find.Execute("《《", , , , , , True, wdFindStop, , "《", wdReplaceAll)
Loop
Do While rng.Find.Execute("》》", , , , , , True, wdFindStop, , "》", wdReplaceAll)
Loop
Application.ScreenUpdating = True
Application.ScreenRefresh
Beep
d.Save
'MsgBox "done!", vbInformation
rst.Close: Set rst = Nothing
End Sub
Sub 檢查可能未標點者()
Dim rst As New ADODB.Recordset, d As Document, r As Range, x As String, e As Long
Dim rstPass As New ADODB.Recordset
If cnt.State = 0 Then cnt.Open "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=" & dbF
Set d = ActiveDocument
Set r = d.Range
'rst.Open "select * from 《易》學書標書名號 where (組別=1 or 組別=7 or 組別=8 or 組別=9 or 先後順序 =10000 or 先後順序 =99999) order by 組別,先後順序,ID", cnt  '要取代哪一組格式的文字
'rst.Open "《易》學書標書名號", CNT, adOpenKeyset, adLockReadOnly
rst.Open "select * from 《易》學書標書名號 where 組別<>64 and 組別<>2 and 組別<>3 and 組別<>4", cnt, adOpenKeyset, adLockReadOnly
With rst
    Do Until .EOF
        x = .Fields("須標書名號字詞").Value
        If InStr(d.Range, x) > 0 Then
            rstPass.Open "select 略過不標書名號,字長 from 《易》學書標書名號_略過不標者 where instr(略過不標書名號,""" & x & """)>0", cnt, adOpenKeyset, adLockOptimistic
            Set r = d.Range
            r.Find.ClearAllFuzzyOptions: r.Find.ClearFormatting
            Do While r.Find.Execute(x, , , , , , True, wdFindStop)
                If (r.Previous <> "《" And r.Previous <> "·" And r.Previous <> "‧") And (r.Next <> "·" And r.Next <> "》" And r.Next <> "‧") And r.HighlightColorIndex = 0 Then
                    e = r.End
'                    r.Select
'                    Stop
                    chkPass rstPass, r, e, x
                    'If rstPass.RecordCount > 0 Then rstPass.MoveFirst
                    r.SetRange e, d.Range.End
                End If
            Loop
            rstPass.Close
        End If
        .MoveNext
    Loop
End With
MsgBox "done!", vbInformation
End Sub
Function 比對略過不標書名號(rst As ADODB.Recordset, xR As Range) As Boolean
Dim r As Range, l As Byte, i As Integer, ps As Long
Set r = xR: ps = xR.End
With rst
    If rst.RecordCount > 0 Then
        Do Until .EOF
            l = Len(.Fields("略過不標書名號").Value) '擴充漢字，End屬性一樣是算二個長度
            For i = -l To l
                r.SetRange ps + i, ps + i + l
                If StrComp(r.Text, .Fields("略過不標書名號").Value) = 0 Then
                    比對略過不標書名號 = True
                    .MoveFirst
                    Exit Function
                End If
            Next i
            .MoveNext
        Loop
        .MoveFirst
    End If
End With
End Function
Sub 略過不標書名號(rst As ADODB.Recordset, xSelection As Range)
Dim rstp As New ADODB.Recordset
rstp.Open "select 略過不標書名號 from 《易》學書標書名號_略過不標者 where strcomp(略過不標書名號,""" & xSelection & """)=0", cnt, adOpenKeyset, adLockReadOnly
If rstp.RecordCount = 0 Then
    With rst
        .AddNew
        .Fields("略過不標書名號").Value = xSelection
        .Fields("字長").Value = xSelection.Characters.Count
        .Update
        .Requery
    End With
End If
rstp.Close
End Sub


Sub 檢查卦名不加書名號()
Dim rst As New ADODB.Recordset, rstPass As New ADODB.Recordset
Dim d As Document, rng As Range, e As Long, x As String
Set d = ActiveDocument
'Set rng = d.Range(Selection.End, d.Range.End) '只操作插入點之後的文本
Set rng = d.Range(1, d.Range.End) '只操作指定點之後的文本
rng.Find.ClearFormatting
rng.Find.ClearAllFuzzyOptions
If cnt.State = 0 Then cnt.Open "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=" & dbF
rst.Open "select * from 《易》學書標書名號 where (組別=" & 64 & " ) ", cnt
Application.ScreenUpdating = False

With rst
    Do Until .EOF
        x = .Fields("須標書名號字詞").Value
        If InStr(rng.Text, x) > 0 Then
            rstPass.Open "select 略過不標書名號,字長 from 《易》學書標書名號_略過不標者 where instr(略過不標書名號,""" & x & """)>0", cnt, adOpenKeyset, adLockOptimistic
            Do While rng.Find.Execute(x, , , , , , True, wdFindStop)
                If (rng.Previous = "《" Or rng.Previous = "·" Or rng.Previous = "‧") Or (rng.Next = "·" Or rng.Next = "》" Or rng.Next = "‧") Then
                    rng.Select
                    e = rng.End
                    chkPass rstPass, rng, e, x
                    rng.SetRange e, d.Range.End
                End If
            Loop
            rstPass.Close
        End If
        .MoveNext
        Set rng = d.Range
    Loop
End With
Application.ScreenUpdating = True
Application.ScreenRefresh
Beep
d.Save
MsgBox "done!", vbInformation
rst.Close: Set rst = Nothing
End Sub
Sub chkPass(rstPass As ADODB.Recordset, r As Range, e As Long, findWord As String)
If Not 比對略過不標書名號(rstPass, r) Then
    r.SetRange e - Len(findWord), e
    r.Select: Beep
    Stop
    If Selection.Type <> wdSelectionIP And VBA.Len(Selection.Text) > VBA.Len(findWord) Then 略過不標書名號 rstPass, Selection.Range
End If
End Sub

View Oscar's Profile