詞牌斷句DAO 

                  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
View Oscar's Profile