詞牌斷句ADO and Excel

                  Sub 詞牌斷句()

Dim p As Paragraph, Char, c, i As Long
Dim db As New adodb.Connection, DbFullname As String, 詞牌rst As New adodb.Recordset
Dim 詞牌 As String, CiPaiParagraph As Paragraph
Dim docText As String, myRngFlag As Boolean, UndoTimes As Long
Dim ds As Date, de As Date
Dim 詞文 As String, j As Integer, L As Byte
Dim DiaoShi As String, DiaoShiItem As String, DiaoShiCharscount As Integer, DiaoShiCount As Long
Dim addParagraphCount As Long
On Error GoTo ErrH

DbFullname = dbFile("詞學韻律資料庫*.xlsm", "")

If Dir(DbFullname) = "" Then
    DbFullname = InputBox("請輸入<歷代詞作韻律資料庫>全檔名(含路徑與副檔名)", "詞牌斷句", DbFullname)
End If
If DbFullname = "" Then Exit Sub
If MsgBox("執行此次""詞牌斷句標韻"",將會清除文本中任何符號(含空格,數字,英文)", vbExclamation + vbOKCancel, "<詞牌斷句標韻>程序") = vbCancel Then Exit Sub
ds = Timer
db.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                "Data Source=" & DbFullname & ";" & _
                    "Extended Properties=""Excel 8.0;HDR=Yes;"";"

Char = Array("◎", "。", "、", "，", "！", ";", ".", "．", """", "‘", "’", "『", "』", "「", "」", "？", "?", "〞", "〝", "!", " ", "…", _
                 "　", "[", "]", "〔", "〕", "﹝", "﹞", "﹝", "﹞", "（", "）", "{", "}", "｛", "｝", "‵", "'", _
                 "@", "#", "$", "%", "^", "&", "*", "_", "-", "+", "=", "｜", "：", "/", "~", "1", "2", "3", "4", "5", "6", "7", _
                 "8", "9", "0", "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", _
                 "w", "x", "y", "z", "﹗", "﹑", "﹖", VBA.Chr(9), ChrW(&H2460), ChrW(&H2461), ChrW(&H2462), ChrW(&H2463), ChrW(&H2464), _
                 ChrW(&H2465), ChrW(&H2466), ChrW(&H2467), ChrW(&H2468), ChrW(&H2469), ChrW(&H246A), ChrW(&H246B), ChrW(&H246C), _
                 ChrW(&H246D), ChrW(&H246E), ChrW(&H246F), ChrW(&H2470), ChrW(&H2471), ChrW(&H2472), ChrW(&H2473), ChrW(&H2474), ChrW(&H2475) _
                 , ChrW(&H2476), ChrW(&H2477), ChrW(&H2478), ChrW(&H2479), ChrW(&H247A), ChrW(&H247B), ChrW(&H247C), ChrW(&H247D), _
                 ChrW(&H247E), ChrW(&H247F), ChrW(&H2480), ChrW(&H2481), ChrW(&H2482), ChrW(&H2483), ChrW(&H2484), ChrW(&H2485) _
                   , ChrW(&H2486), ChrW(&H2487))
With d
    '先清理文本
    docText = .Content
    With .Content.Find
        .ClearAllFuzzyOptions: .ClearFormatting: .ClearHitHighlight
        For Each c In Char
'            If c = "﹑" Then Stop
            If InStr(docText, c) > 0 Then
                UndoTimes = UndoTimes + 1
               .Execute c, False, False, False, , , , , , "", wdReplaceAll
            End If
        Next
    End With
    docText = Empty:  Char = Empty
    For Each p In .Paragraphs '前一段是詞牌，後一段是詞文
        If addParagraphCount <> 0 Then
            addParagraphCount = addParagraphCount - 1
            GoTo NextParagraph
        End If
        If p.Range = Chr(13) Then GoTo NextParagraph '如果是一個空段
        i = i + 1 ' i 是專門用來判斷詞牌段落的
        If i Mod 2 = 1 Then '如果是詞牌段落
            p.Style = "標題 1"
            With p.Range.Font
                .Size = 18
                '.Bold = True
                '.Size = 18
                .NameFarEast = "標楷體"
            End With
            Set CiPaiParagraph = p '可見 Paragraph和Range不同，Range變數設定了就會跟著原Range跑，可見是reference type,而Paragraph 則不會，是(Value Type) instantiated object 執行個體
            詞牌 = Mid(p.Range, 1, Len(p.Range) - 1)
            詞牌rst.Open "select Top 1 詞牌 from [工作表1$] where strcomp(詞牌,""" & 詞牌 & """)=0;", db, adOpenKeyset, adLockReadOnly, 1 ' Top 1 、DISTINCT 和二者皆無者，取得記錄效率差不多
                If 詞牌rst.RecordCount > 0 Then '工作表有詞牌時
                    詞牌rst.Close
                    GoTo NextParagraph
                End If
        Else '如果是詞文段落
            If 詞牌rst.State = adStateOpen Then 詞牌rst.Close
            詞牌rst.Open "select DISTINCT 詞牌,調式,字數 from [工作表1$] GROUP BY 詞牌,調式,字數 HAVING strcomp([詞牌],""" & 詞牌 & """)=0 and strcomp([字數],""" & CStr(p.Range.Characters.Count - 1) & """)=0", db, adOpenKeyset, adLockReadOnly, 1
            DiaoShiCount = 詞牌rst.RecordCount
            If DiaoShiCount > 0 Then
                myRngFlag = True
                詞文 = Mid(p.Range, 1, Len(p.Range) - 1)
                If DiaoShiCount > 1 Then 'Stop
'                    With p.Previous.Range.Characters.last
'                        .InsertBefore " "
'                        With .Previous
'                            .Font.Size = 12
'                            .Bold = True
'                            .Text = "（共" & DiaoShiCount & "式）"
'                        End With
'                    End With
                    CiPaiParagraph.Range.Characters.last.InsertBefore " " '上面不行此下行，可見 每呼一次 p 即又一個 new p，如 C#裡的 string 或 instance 執行個體 一樣 。這個動作其實是建構了另一個 p 物件執行個體，而不是改了p
                    With CiPaiParagraph.Range.Characters.last.Previous '既然是重新建構一個 p 物件，那麼若不參照此新物件，此新物件便無用了。再 call 一次 p,即取得這個新的 p,而原p 即如舊的 string 被回收一樣
                        .Font.Size = 12
                        .Bold = True
                        .Text = "（共 " & DiaoShiCount & "式）" 'p.Parent.Range(p.Previous.Range.Characters.last.End- len("（共" & DiaoShiCount & " 種調式：）)-1,p.Previous.Range.Characters.last.previous.end).Font.Bold = True
                    End With
                End If
                Do
                    '開始標韻
                    DiaoShi = 詞牌rst("調式").Value
                    L = Len(DiaoShi)
                    For j = 1 To L '檢查調式的迴圈
                        DiaoShiItem = Mid(DiaoShi, j, 1) '取得調式中的各個單元元素
                        If IsNumeric(DiaoShiItem) Then '句讀
                            DiaoShiCharscount = DiaoShiCharscount + CByte(DiaoShiItem)
                            If DiaoShiCharscount > p.Range.Characters.Count - 1 Then
                                If MsgBox("調式與字數不合！是否繼續？", vbOKCancel + vbExclamation) = vbCancel Then
                                    p.Range.Paragraphs.Add
                                    If Not p.Next Is Nothing Then
                                        Set p = p.Next
                                    End If
                                    p.Range.Text = DiaoShi & Chr(13)
                                    Set p = p.Previous '因為插入了 chr(13) 分段符號，故須再回到前一段
                                    'addParagraphCount = addParagraphCount + 1 '加了2個段落
                                    p.Range.Font.Name = "Calibri"
                                    p.Range.HighlightColorIndex = wdYellow
                                    p.Range.Select
                                
                                    GoTo ExitExe
                                Else
                                    p.Range.HighlightColorIndex = wdYellow
                                    GoTo nextRecord
                                End If
                            End If
                            If j + 1 <= L Then
                                If Mid(DiaoShi, j + 1, 1) = "." Then
                                    p.Range.Characters(DiaoShiCharscount).InsertAfter "，" '暫訂用此符號
                                Else
                                    p.Range.Characters(DiaoShiCharscount).InsertAfter "。" '暫訂用此符號
                                    p.Range.Characters(DiaoShiCharscount + 1).Font.ColorIndex = wdRed '標韻色彩
                                End If
                            Else
                                p.Range.Characters(DiaoShiCharscount).InsertAfter "。" '最後一字應都是韻腳。暫訂用此符號
                                p.Range.Characters(DiaoShiCharscount + 1).Font.ColorIndex = wdRed '標韻色彩
                            End If
                            DiaoShiCharscount = DiaoShiCharscount + 1
                        ElseIf DiaoShiItem Like "[‧．]" Then '過片
                            If DiaoShiCharscount = 0 Then
                                'Stop 'check '過片不應出現在調式的一開始！
                                MsgBox "過片不應出現在調式的一開始！請檢查原 excel 工作表是否有誤！" & vbCr & vbCr & vbCr & _
                                    "〈" & 詞牌 & "〉調式「" & DiaoShi & "」"
                                Exit For
                            End If
                            p.Range.Characters(DiaoShiCharscount).InsertAfter "　　"
                            DiaoShiCharscount = DiaoShiCharscount + 2
                        ElseIf DiaoShiItem = "." Then '？未知，先不處理
                            If DiaoShiCharscount = 0 Then
                                'Stop
                                MsgBox "小數點「.」不應出現在調式的一開始！請檢查原 excel 工作表是否有誤！" & _
                                    "〈" & 詞牌 & "〉調式「" & DiaoShi & "」"
                                Exit For
                            End If
                        Else
                            Stop 'check
                        End If
                    Next j
nextRecord:
                    DiaoShiCharscount = 0
                    詞牌rst.MoveNext
                    
                    p.Range.Paragraphs.Add
                    If Not p.Next Is Nothing Then
                        Set p = p.Next
                    End If
                    p.Range.Text = DiaoShi & Chr(13) '插入調式欄位值 要注意多插入一個段落，i 不能增動，否則會影響詞牌段落的判斷
                    Set p = p.Previous '因為插入了 chr(13) 分段符號，故須再回到前一段
                    addParagraphCount = addParagraphCount + 1 '加了1個段落
                    p.Range.Font.Name = "Calibri"
                    
                    If Not 詞牌rst.EOF Then
                        p.Range.Paragraphs.Add
                        Set p = p.Range.Paragraphs.Add
                        addParagraphCount = addParagraphCount + 2 '加了2個段落
                        If Not p.Next Is Nothing Then
                            Set p = p.Next
                        End If
                        p.Range.Text = 詞文 & Chr(13) '要注意多插入一個段落，i 不能增動，否則會影響詞牌段落的判斷
                        Set p = p.Previous '因為插入了 chr(13) 分段符號，故須再回到前一段
                        p.Range.Select '檢查用
                    Else
                        If Not p.Next Is Nothing Then
                            詞牌rst.Close
                            GoTo NextParagraph
                        Else
                            Exit For
                        End If
                    End If
                Loop
            Else
                p.Range.Select
                If MsgBox("沒有符合的調式可套用！" & vbCr & vbCr & "是否繼續？", vbExclamation + vbOKCancel) = vbCancel Then Exit For
                詞牌rst.Close
                GoTo NextParagraph
            End If
        End If

NextParagraph:
   Next
ExitExe:
    If myRngFlag = False Then '若都沒有吻合的，則還原文件原樣
        Do Until UndoTimes = 0
            UndoTimes = UndoTimes - 1
            .Undo
        Loop
    End If
End With
de = Timer
MsgBox "完成！" & vbCr & vbCr & "費時" & VBA.Left(de - ds, 5) & "秒!", vbInformation
CommandBars("Navigation").Visible = True
d.ActiveWindow.DocumentMap = True
If 詞牌rst.State = adStateOpen Then 詞牌rst.Close
db.Close
Set 詞牌rst = Nothing: Set db = Nothing
Exit Sub
ErrH:
Select Case Err.Number
    Case Else
        MsgBox Err.Number & Err.Description, vbCritical
        Resume 'Next
        'Stop
End Select

End Sub

Sub 詞牌斷句()

Dim p As Paragraph, Char, c, i As Long
Dim db As New adodb.Connection, DbFullname As String, 詞牌rst As New adodb.Recordset
Dim 詞牌 As String, CiPaiParagraph As Paragraph
Dim docText As String, myRngFlag As Boolean, UndoTimes As Long
Dim ds As Date, de As Date
Dim 詞文 As String, j As Integer, L As Byte
Dim DiaoShi As String, DiaoShiItem As String, DiaoShiCharscount As Integer, DiaoShiCount As Long
Dim addParagraphCount As Long
On Error GoTo ErrH

DbFullname = dbFile("詞學韻律資料庫*.xlsm", "")

If Dir(DbFullname) = "" Then
    DbFullname = InputBox("請輸入<歷代詞作韻律資料庫>全檔名(含路徑與副檔名)", "詞牌斷句", DbFullname)
End If
If DbFullname = "" Then Exit Sub
If MsgBox("執行此次""詞牌斷句標韻"",將會清除文本中任何符號(含空格,數字,英文)", vbExclamation + vbOKCancel, "<詞牌斷句標韻>程序") = vbCancel Then Exit Sub
ds = Timer
db.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                "Data Source=" & DbFullname & ";" & _
                    "Extended Properties=""Excel 8.0;HDR=Yes;"";"

Char = Array("◎", "。", "、", "，", "！", ";", ".", "．", """", "‘", "’", "『", "』", "「", "」", "？", "?", "〞", "〝", "!", " ", "…", _
                 "　", "[", "]", "〔", "〕", "﹝", "﹞", "﹝", "﹞", "（", "）", "{", "}", "｛", "｝", "‵", "'", _
                 "@", "#", "$", "%", "^", "&", "*", "_", "-", "+", "=", "｜", "：", "/", "~", "1", "2", "3", "4", "5", "6", "7", _
                 "8", "9", "0", "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", _
                 "w", "x", "y", "z", "﹗", "﹑", "﹖", VBA.Chr(9), ChrW(&H2460), ChrW(&H2461), ChrW(&H2462), ChrW(&H2463), ChrW(&H2464), _
                 ChrW(&H2465), ChrW(&H2466), ChrW(&H2467), ChrW(&H2468), ChrW(&H2469), ChrW(&H246A), ChrW(&H246B), ChrW(&H246C), _
                 ChrW(&H246D), ChrW(&H246E), ChrW(&H246F), ChrW(&H2470), ChrW(&H2471), ChrW(&H2472), ChrW(&H2473), ChrW(&H2474), ChrW(&H2475) _
                 , ChrW(&H2476), ChrW(&H2477), ChrW(&H2478), ChrW(&H2479), ChrW(&H247A), ChrW(&H247B), ChrW(&H247C), ChrW(&H247D), _
                 ChrW(&H247E), ChrW(&H247F), ChrW(&H2480), ChrW(&H2481), ChrW(&H2482), ChrW(&H2483), ChrW(&H2484), ChrW(&H2485) _
                   , ChrW(&H2486), ChrW(&H2487))
With d
    '先清理文本
    docText = .Content
    With .Content.Find
        .ClearAllFuzzyOptions: .ClearFormatting: .ClearHitHighlight
        For Each c In Char
'            If c = "﹑" Then Stop
            If InStr(docText, c) > 0 Then
                UndoTimes = UndoTimes + 1
               .Execute c, False, False, False, , , , , , "", wdReplaceAll
            End If
        Next
    End With
    docText = Empty:  Char = Empty
    For Each p In .Paragraphs '前一段是詞牌，後一段是詞文
        If addParagraphCount <> 0 Then
            addParagraphCount = addParagraphCount - 1
            GoTo NextParagraph
        End If
        If p.Range = Chr(13) Then GoTo NextParagraph '如果是一個空段
        i = i + 1 ' i 是專門用來判斷詞牌段落的
        If i Mod 2 = 1 Then '如果是詞牌段落
            p.Style = "標題 1"
            With p.Range.Font
                .Size = 18
                '.Bold = True
                '.Size = 18
                .NameFarEast = "標楷體"
            End With
            Set CiPaiParagraph = p '可見 Paragraph和Range不同，Range變數設定了就會跟著原Range跑，可見是reference type,而Paragraph 則不會，是(Value Type) instantiated object 執行個體
            詞牌 = Mid(p.Range, 1, Len(p.Range) - 1)
            詞牌rst.Open "select Top 1 詞牌 from [工作表1$] where strcomp(詞牌,""" & 詞牌 & """)=0;", db, adOpenKeyset, adLockReadOnly, 1 ' Top 1 、DISTINCT 和二者皆無者，取得記錄效率差不多
                If 詞牌rst.RecordCount > 0 Then '工作表有詞牌時
                    詞牌rst.Close
                    GoTo NextParagraph
                End If
        Else '如果是詞文段落
            If 詞牌rst.State = adStateOpen Then 詞牌rst.Close
            詞牌rst.Open "select DISTINCT 詞牌,調式,字數 from [工作表1$] GROUP BY 詞牌,調式,字數 HAVING strcomp([詞牌],""" & 詞牌 & """)=0 and strcomp([字數],""" & CStr(p.Range.Characters.Count - 1) & """)=0", db, adOpenKeyset, adLockReadOnly, 1
            DiaoShiCount = 詞牌rst.RecordCount
            If DiaoShiCount > 0 Then
                myRngFlag = True
                詞文 = Mid(p.Range, 1, Len(p.Range) - 1)
                If DiaoShiCount > 1 Then 'Stop
'                    With p.Previous.Range.Characters.last
'                        .InsertBefore " "
'                        With .Previous
'                            .Font.Size = 12
'                            .Bold = True
'                            .Text = "（共" & DiaoShiCount & "式）"
'                        End With
'                    End With
                    CiPaiParagraph.Range.Characters.last.InsertBefore " " '上面不行此下行，可見 每呼一次 p 即又一個 new p，如 C#裡的 string 或 instance 執行個體 一樣 。這個動作其實是建構了另一個 p 物件執行個體，而不是改了p
                    With CiPaiParagraph.Range.Characters.last.Previous '既然是重新建構一個 p 物件，那麼若不參照此新物件，此新物件便無用了。再 call 一次 p,即取得這個新的 p,而原p 即如舊的 string 被回收一樣
                        .Font.Size = 12
                        .Bold = True
                        .Text = "（共 " & DiaoShiCount & "式）" 'p.Parent.Range(p.Previous.Range.Characters.last.End- len("（共" & DiaoShiCount & " 種調式：）)-1,p.Previous.Range.Characters.last.previous.end).Font.Bold = True
                    End With
                End If
                Do
                    '開始標韻
                    DiaoShi = 詞牌rst("調式").Value
                    L = Len(DiaoShi)
                    For j = 1 To L '檢查調式的迴圈
                        DiaoShiItem = Mid(DiaoShi, j, 1) '取得調式中的各個單元元素
                        If IsNumeric(DiaoShiItem) Then '句讀
                            DiaoShiCharscount = DiaoShiCharscount + CByte(DiaoShiItem)
                            If DiaoShiCharscount > p.Range.Characters.Count - 1 Then
                                If MsgBox("調式與字數不合！是否繼續？", vbOKCancel + vbExclamation) = vbCancel Then
                                    p.Range.Paragraphs.Add
                                    If Not p.Next Is Nothing Then
                                        Set p = p.Next
                                    End If
                                    p.Range.Text = DiaoShi & Chr(13)
                                    Set p = p.Previous '因為插入了 chr(13) 分段符號，故須再回到前一段
                                    'addParagraphCount = addParagraphCount + 1 '加了2個段落
                                    p.Range.Font.Name = "Calibri"
                                    p.Range.HighlightColorIndex = wdYellow
                                    p.Range.Select
                                
                                    GoTo ExitExe
                                Else
                                    p.Range.HighlightColorIndex = wdYellow
                                    GoTo nextRecord
                                End If
                            End If
                            If j + 1 <= L Then
                                If Mid(DiaoShi, j + 1, 1) = "." Then
                                    p.Range.Characters(DiaoShiCharscount).InsertAfter "，" '暫訂用此符號
                                Else
                                    p.Range.Characters(DiaoShiCharscount).InsertAfter "。" '暫訂用此符號
                                    p.Range.Characters(DiaoShiCharscount + 1).Font.ColorIndex = wdRed '標韻色彩
                                End If
                            Else
                                p.Range.Characters(DiaoShiCharscount).InsertAfter "。" '最後一字應都是韻腳。暫訂用此符號
                                p.Range.Characters(DiaoShiCharscount + 1).Font.ColorIndex = wdRed '標韻色彩
                            End If
                            DiaoShiCharscount = DiaoShiCharscount + 1
                        ElseIf DiaoShiItem Like "[‧．]" Then '過片
                            If DiaoShiCharscount = 0 Then
                                'Stop 'check '過片不應出現在調式的一開始！
                                MsgBox "過片不應出現在調式的一開始！請檢查原 excel 工作表是否有誤！" & vbCr & vbCr & vbCr & _
                                    "〈" & 詞牌 & "〉調式「" & DiaoShi & "」"
                                Exit For
                            End If
                            p.Range.Characters(DiaoShiCharscount).InsertAfter "　　"
                            DiaoShiCharscount = DiaoShiCharscount + 2
                        ElseIf DiaoShiItem = "." Then '？未知，先不處理
                            If DiaoShiCharscount = 0 Then
                                'Stop
                                MsgBox "小數點「.」不應出現在調式的一開始！請檢查原 excel 工作表是否有誤！" & _
                                    "〈" & 詞牌 & "〉調式「" & DiaoShi & "」"
                                Exit For
                            End If
                        Else
                            Stop 'check
                        End If
                    Next j
nextRecord:
                    DiaoShiCharscount = 0
                    詞牌rst.MoveNext
                    
                    p.Range.Paragraphs.Add
                    If Not p.Next Is Nothing Then
                        Set p = p.Next
                    End If
                    p.Range.Text = DiaoShi & Chr(13) '插入調式欄位值 要注意多插入一個段落，i 不能增動，否則會影響詞牌段落的判斷
                    Set p = p.Previous '因為插入了 chr(13) 分段符號，故須再回到前一段
                    addParagraphCount = addParagraphCount + 1 '加了1個段落
                    p.Range.Font.Name = "Calibri"
                    
                    If Not 詞牌rst.EOF Then
                        p.Range.Paragraphs.Add
                        Set p = p.Range.Paragraphs.Add
                        addParagraphCount = addParagraphCount + 2 '加了2個段落
                        If Not p.Next Is Nothing Then
                            Set p = p.Next
                        End If
                        p.Range.Text = 詞文 & Chr(13) '要注意多插入一個段落，i 不能增動，否則會影響詞牌段落的判斷
                        Set p = p.Previous '因為插入了 chr(13) 分段符號，故須再回到前一段
                        p.Range.Select '檢查用
                    Else
                        If Not p.Next Is Nothing Then
                            詞牌rst.Close
                            GoTo NextParagraph
                        Else
                            Exit For
                        End If
                    End If
                Loop
            Else
                p.Range.Select
                If MsgBox("沒有符合的調式可套用！" & vbCr & vbCr & "是否繼續？", vbExclamation + vbOKCancel) = vbCancel Then Exit For
                詞牌rst.Close
                GoTo NextParagraph
            End If
        End If

NextParagraph:
   Next
ExitExe:
    If myRngFlag = False Then '若都沒有吻合的，則還原文件原樣
        Do Until UndoTimes = 0
            UndoTimes = UndoTimes - 1
            .Undo
        Loop
    End If
End With
de = Timer
MsgBox "完成！" & vbCr & vbCr & "費時" & VBA.Left(de - ds, 5) & "秒!", vbInformation
CommandBars("Navigation").Visible = True
d.ActiveWindow.DocumentMap = True
If 詞牌rst.State = adStateOpen Then 詞牌rst.Close
db.Close
Set 詞牌rst = Nothing: Set db = Nothing
Exit Sub
ErrH:
Select Case Err.Number
    Case Else
        MsgBox Err.Number & Err.Description, vbCritical
        Resume 'Next
        'Stop
End Select

End Sub

View Oscar's Profile