詞牌斷句ADO and Excel

View Snippet 
                    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

文字符號_括弧、頓號_分離器（X（X1、X2）=> \'X,X1,X2）

View Snippet 
                    '例如：「多麗（綠頭鴨、鴨頭綠）」=>此一字串可以分出「多麗」,「綠頭鴨」,「鴨頭綠」三個字串）
'又如:「x（x1、x2、x3、……）」可析離出「x」「x1」「x2」「x3」……

Private Sub List2_AfterUpdate() 'List2=詞牌名清單
Dim x As String, xList2() As String, i As Integer'x : 原字串、xList2: 新字串
x = List2.Value
List2.Enabled = False

If x Like "*[（、]*" Then '多麗（綠頭鴨、鴨頭綠）
    If InStr(x, "、") > 0 Then ' 有頓號
        i = 1
        ReDim Preserve xList2(i)
        xList2(0) = Mid(x, 1, InStr(x, "（") - 1)
        xList2(1) = Mid(x, InStr(x, "（") + 1, InStr(x, "、") - InStr(x, "（") - 1)
        Do Until InStr(x, "、") = 0
            i = i + 1
            ReDim Preserve xList2(i)
            x = Mid(x, InStr(x, "、") + 1)
            If InStr(x, "、") = 0 Then
                x = Replace(x, "）", "")
                xList2(i) = x
            Else
                xList2(i) = Mid(x, 1, InStr(x, "、") - 1)
            End If
        Loop
        
    Else
        ReDim xList2(1)
        If InStr(x, "）") > 0 Then '只有（）
            x = Mid(x, InStr(x, "（") + 1, Len(x) - InStr(x, "（") - 1)
            xList2(1) = x
            xList2(0) = Replace(List2.Value, "（" & x & "）", "")
        Else
            xList2(0) = x
            x = Mid(x, InStr(x, "（") + 1)
            xList2(1) = x
            xList2(0) = Replace(List2.Value, "（" & x, "")
        End If
    End If
    qy1FieldValuesOr List2.Tag, xList2, False
Else
    testADO List2.Tag, x
End If

List2.Enabled = True
End Sub

造字置換

View Snippet 
                    Sub 造字置換()
Dim i As Long
Dim r As Long
r = Sheets(2).UsedRange.Rows.Count
For i = 2 To r
    Sheets(1).Cells.Replace Sheets(2).Cells(i, 1), Sheets(2).Cells(i, 2)
Next i
End Sub

倒序文字

View Snippet 
                    Sub 倒序文字() ' 2017/7/12 將選取文字次序倒轉；若無選取，則處理整份文件內容
Dim wCount As Long, oRange As Range, i As Long, j As Long, dChars As Characters
'Set d = ActiveDocument
If Selection.Type = wdNoSelection Or Selection.Type = wdSelectionIP Then '如果沒有選取則處理整個文件
    Set oRange = d.Content: Set dChars = oRange.Characters: wCount = oRange.Characters.Count
    If wCount = Len(oRange.Text) Then '如果沒有2個字元長的漢字
        d.Range = oRange + VBA.StrReverse(oRange)
    Else
        d.Range.InsertParagraphAfter
        GoSub forChar
    End If
Else '如果有選取範圍，則只處理選取的內容
    Set oRange = Selection.Range: Set dChars = oRange.Characters: wCount = oRange.Characters.Count
    If wCount = Len(oRange.Text) Then '如果沒有2個字元長的漢字
        d.Range = d.Range + VBA.StrReverse(oRange)
    Else
        wCount = wCount + 1
        d.Range.Paragraphs.Add
        GoSub forChar
    End If
End If
Exit Sub

forChar:
    Selection.EndKey wdStory
    For i = wCount - 1 To 1 Step -1
        j = j + 1
        Selection.Font.Name = oRange.Characters(wCount - j).Font.Name
        Selection.Font.Size = oRange.Characters(wCount - j).Font.Size
        Selection.Font.NameFarEast = oRange.Characters(wCount - j).Font.NameFarEast
        Selection.Font.ColorIndex = wdDarkRed
        Selection.TypeText oRange.Characters(wCount - j)
    Next i
    Exit Sub
Return
End Sub

詞牌斷句DAO

View Snippet 
                    Sub 詞牌斷句()
Dim p As Paragraph, Char, i As Integer ', j As Byte ',Yun, yunColor, cp, pNext As Paragraph
Dim db As Database, DbFullname As String, 詞牌rst As DAO.Recordset, 詞牌_調式rst As DAO.Recordset, 詞牌_調式Crst As DAO.Recordset
'dim 用韻rst As dao.Recordset, 韻字rst As dao.Recordset
Dim 有詞牌 As Boolean, Np有詞牌 As Boolean, 韻字 As String, 詞牌 As String ', 詞牌ID As Long, 韻字ID As Long,
Dim 詞牌_調式查詢 As QueryDef
Dim pL As Long '檢查內容長度是否與調式不同!
Dim x As String, myRngFlag As Boolean, UndoTimes As Long
'Dim 調式 As Byte ', 調式pre As Byte
Dim ds As Date, de As Date
On Error GoTo ErrH
'If Dir("D:\千慮一得齋\書信\圖書管理\黃沛榮老師助理\歷代詞作韻律資料庫.mdb") <> "" Then
'    DbFullname = "D:\千慮一得齋\書信\圖書管理\黃沛榮老師助理\歷代詞作韻律資料庫.mdb"
'Else
    'DbFullname = "C:\Documents and Settings\Superwings\桌面\歷代詞作韻律資料庫.mdb"
    'DbFullname = "D:\!!!!!我的研究\!!!!研究工具\歷代詞作韻律資料庫.mdb"
    DbFullname = dbFile("歷代詞作韻律資料庫", "")
'End If


If Dir(DbFullname) = "" Then
    DbFullname = InputBox("請輸入<歷代詞作韻律資料庫>全檔名(含路徑與副檔名)", "詞牌斷句", DbFullname)
End If
If DbFullname = "" Then Exit Sub
If MsgBox("執行此次""詞牌斷句標韻"",將會清除文本中任何符號(含空格,數字,英文)", vbExclamation + vbOKCancel, "<詞牌斷句標韻>程序") = vbCancel Then Exit Sub
ds = Timer
Set db = DBEngine.Workspaces(0).OpenDatabase(DbFullname)
'Set 用韻rst = Db.OpenRecordset("用韻")
'Set 韻字rst = Db.OpenRecordset("韻字")
Set 詞牌rst = db.OpenRecordset("詞牌")
'cp = Array("菩薩蠻")
'Yun = Array(7, 7, 5, 5, 5, 5, 5, 5)
'yunColor = Array(wdColorRed, wdColorBlue, wdColorGreen, wdColorDarkRed)
With ActiveDocument

    
    For Each Char In .Range.Characters
        If InStr("◎。、，;.""‘’""『』「」？?〞〝! …" & _
                "　[]〔〕﹝﹞﹝﹞（）{}｛｝‵'@#$%^&*_-+=｜：/~1234567890abcdefghijklmnopqrstuvwxyz" _
                & VBA.Chr(9), Char) Then
            Char.Delete 'vba.Chr(9)為表單定位字元(Tab鍵鍵入者)
            UndoTimes = UndoTimes + 1 '若未處理，則還原原文件內容
        End If
    Next Char
    .Range.MoveEnd wdStory
    For Each p In .Paragraphs
        If p.Range.End = .Range.End Then Exit For '因為下一段沒有了.(此是處理詞牌一段,下一段為詞內容故)
        If Len(p.Range) = 1 Then GoTo Np
        With 詞牌rst
            Do Until .EOF
                If InStr(p.Range, .Fields("詞牌")) = 1 And VBA.Left(p.Range, Len(.Fields("詞牌"))) = .Fields("詞牌") Then  '找到詞牌,且必在段首,否則在句中將誤判矣
                    '詞牌ID = .Fields("詞牌ID")
                    詞牌 = .Fields("詞牌")
                    有詞牌 = True
                    Exit Do
                End If
                .MoveNext '歸零
            Loop
            .MoveFirst
        End With
'        If 詞牌 = "江城子" Then Stop'檢查不含內容之詞牌!
        If 有詞牌 Then '有詞牌才處理
            If Len(p.Next.Range) = 1 Then GoTo Np '詞牌後無內容時
                With 詞牌rst
                    Do Until .EOF
                        'If InStr(p.Next.Range, .Fields("詞牌")) Then '檢查下一段是否是詞牌
                        If InStr(p.Next.Range, .Fields("詞牌")) = 1 And VBA.Left(p.Range.Next, Len(.Fields("詞牌"))) = .Fields("詞牌") Then
                            Np有詞牌 = True: Exit Do
                        Else
                            Np有詞牌 = False '處理時則歸零
                        End If
                        .MoveNext
                    Loop
                    .MoveFirst '歸零
                End With
            If Np有詞牌 Then GoTo Np '可見前一詞牌無內容,不處理
            Set 詞牌_調式查詢 = db.QueryDefs("詞牌_調式查詢") '已內含用韻、韻字了
            With 詞牌_調式查詢
                '.Parameters("詞牌IDP") = 詞牌ID
                .Parameters("詞牌斷句") = 詞牌
                Set 詞牌_調式rst = .OpenRecordset
                Set 詞牌_調式Crst = .OpenRecordset
                With 詞牌_調式rst
                    Do Until .EOF
                        pL = pL + .Fields("調式")
                        .MoveNext
                    Loop
                    If pL = 0 Then GoTo Np '表示尚無句式資料也.
                    myRngFlag = True
                    x = p.Next.Range
                    Do Until Right(x, 1) <> VBA.Chr(13)
                        x = Mid(x, 1, Len(x) - 1)
                    Loop
                    'If Pl <> Len(p.Next.Range) - 1 Then '去掉分段符號chr(13)
                    If pL <> Len(x) Then '後留有空段時,上一行不成.只好把空段刪去來計算
                        MsgBox "〈" & 詞牌 & "〉詞作內容與調式不符,請檢查後再重來!!", vbCritical: Exit Sub
                    End If
                    .MoveFirst
                    pL = 0 '歸零
                    Do Until .EOF
                        '用韻rst.Index = "詞牌_調式ID"'QueryDefs("詞牌_調式查詢") '已內含用韻、韻字了
                        '用韻rst.Seek "=", .Fields("詞牌_調式ID")
                        '韻字ID = 用韻rst.Fields("韻字ID")
                        韻字 = .Fields("韻字")
                        '韻字rst.Index = "韻字ID"
                        '韻字rst.Seek "=", 韻字ID
                        '韻字 = 韻字rst.Fields("韻字")
                        '調式 = .Fields("調式")
                        If i = 0 Then i = .Fields("調式") '調式'第一筆要先記(另外記)
                        With 詞牌_調式Crst
                            Do Until .AbsolutePosition = 詞牌_調式rst.AbsolutePosition
                                .MoveNext
                                i = i + .Fields("調式")
                                    
                            Loop
                            '.MoveFirst
                        End With
                        p.Next.Range.Characters(i).InsertAfter .Fields("符號") '"◎"
                        p.Next.Range.Characters(i + 1).Font.Color = 韻字
                        i = i + Len(.Fields("符號")) '1 '作為加了幾個"◎"的記數
                        If i > p.Next.Range.Characters.Count Then Exit Do
                        .MoveNext
                    Loop
                End With
            End With
        End If
            
'            With 用韻rst
'                .Index "詞"
'            End With
'        End If
'        If InStr(.Range, cp(0)) Then '如果找到詞牌
'            Set pNext = p.Next
'            For Each Char In pNext.Range.Characters
'                i = i + 1
'                If i = Yun(j) + j Then
'                    Char.InsertAfter "◎"
'                    'Char.Next.Range.Font.Color = yunColor(j)
'                    pNext.Range.Characters(Yun(j - 1) + i + 1).Font.Color = yunColor(j)
'                    j = j + 1
''                    i = i + j
''                    pNext.Range.SetRange i + 12, pNext.Range.End
'                    i = 0
'                End If
'            Next Char
'        End If
        有詞牌 = False: i = 0 '歸零
Np: Next p

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
db.Close
Exit Sub
ErrH:
Select Case Err.Number
    Case Else
        MsgBox Err.Number & Err.Description, vbCritical: Resume Next
End Select

End Sub
← Prev Page Next Page →