Word VBA/利阿賀拿

Module1

Option Explicit
Public cname As String
Public ename As String

Sub testCopyByCharacters()
' 用 character (字) 為單位複製文件，統計數字顯示完整抄錄
    Dim myDoc As Document
    Dim newDoc As Document
    
    Dim char As Variant
    Dim word As Variant
    Dim para As Variant
    
    Dim response As Integer
    
    Set myDoc = Documents("文件1")
'    Set newDoc = Documents.Add
    
    For Each para In myDoc.Paragraphs
'        newDoc.Content.InsertAfter Text:=word
        response = MsgBox(para, vbOKCancel)
        If response = vbCancel Then Exit For
    Next

End Sub
Sub convertChineseToWiki()
    Dim myDoc As Document
    Dim newDoc As Document
    
    Dim char As Variant
    Dim word As Variant
    Dim para As Variant
    
    Dim periodFound As Boolean
'    Dim openDoubleQuoteFound As Boolean     '發現第一個雙引號

    Dim charSaved As String
    
    Dim response As Integer
    Dim cntLink As Integer
    Dim i As Integer
    
    Set myDoc = ThisDocument
    Set newDoc = Documents.Add
    cname = newDoc.Name
    
    cntLink = myDoc.Hyperlinks.Count
    
    For i = cntLink To 1 Step -1
        myDoc.Hyperlinks(i).Range.Delete
    Next
    
    charSaved = ""
    periodFound = False
'    openDoubleQuoteFound = False
    newDoc.Content.InsertAfter Text:="<p class='chinese'>"
    
    For Each char In myDoc.Characters


        Select Case char
            Case vbCr, vbLf, Chr(11)                        '分行符號

                If periodFound Then
                    newDoc.Content.InsertAfter Text:=charSaved
                    newDoc.Content.InsertAfter Text:="</p>" & vbCrLf '& vbCrLf
                    newDoc.Content.InsertAfter Text:="<p class='chinese'>"
                    periodFound = False
                End If
            Case "。", ".", "！", "!", "？", "?"            ', "；"斷句符號
                charSaved = char                            '斷句符號暫存
                periodFound = True

            Case "」", "』", ")", Chr(41384)                '右引號
                If periodFound Then
                    newDoc.Content.InsertAfter Text:=charSaved
                    newDoc.Content.InsertAfter Text:=char & "</p>" & vbCrLf '& vbCrLf
                    newDoc.Content.InsertAfter Text:="<p class='chinese'>"
                    periodFound = False
                Else
                    newDoc.Content.InsertAfter Text:=char
                End If
            Case Else                                       '其它文字或符號
                If periodFound Then
                    newDoc.Content.InsertAfter Text:=charSaved
                    newDoc.Content.InsertAfter Text:="</p>" & vbCrLf '& vbCrLf
                    newDoc.Content.InsertAfter Text:="<p class='chinese'>"
                    newDoc.Content.InsertAfter Text:=char
                    periodFound = False
                Else
                    newDoc.Content.InsertAfter Text:=char
                End If
        End Select
    
    Next

End Sub
Sub convertEnglishToWiki()
    Dim myDoc As Document
    Dim newDoc As Document
    
    Dim char As Variant
    Dim word As Variant
    Dim para As Variant
    
    Dim periodFound As Boolean
'    Dim openDoubleQuoteFound As Boolean     '發現第一個雙引號

    Dim charSaved As String
    
    Dim response As Integer
    Dim cntLink As Integer
    Dim i As Integer
    
    Set myDoc = ThisDocument
    Set newDoc = Documents.Add
    ename = newDoc.Name
    

    cntLink = myDoc.Hyperlinks.Count

    For i = cntLink To 1 Step -1
        myDoc.Hyperlinks(i).Range.Delete
    Next

    charSaved = ""
    periodFound = False
    newDoc.Content.InsertAfter Text:="<p class='english'>"
    
    i = 1
    For Each char In myDoc.Characters
'        char = myDoc.Characters(i)
        Select Case char
            Case vbCr, vbLf, Chr(11)                        '分行符號

                If periodFound Then
                    newDoc.Content.InsertAfter Text:=charSaved
                    newDoc.Content.InsertAfter Text:="</p>" & vbCrLf '& vbCrLf
                    newDoc.Content.InsertAfter Text:="<p class='english'>"
                    periodFound = False
                End If
            Case "."
                If (Asc(myDoc.Characters(i - 2)) < 65) Or (Asc(myDoc.Characters(i - 2)) > 122) Then
                    newDoc.Content.InsertAfter Text:=char
                Else
                    charSaved = char                            '斷句符號暫存
                    periodFound = True
                End If
            Case "!", "?"    '斷句符號
                charSaved = char                            '斷句符號暫存
                periodFound = True

            Case ")", Chr(41384)                '右引號
                If periodFound Then
                    newDoc.Content.InsertAfter Text:=charSaved
                    newDoc.Content.InsertAfter Text:=char & "</p>" & vbCrLf '& vbCrLf
                    newDoc.Content.InsertAfter Text:="<p class='english'>"
                    periodFound = False
                Else
                    newDoc.Content.InsertAfter Text:=char
                End If
            Case Else                                       '其它文字或符號
                If periodFound Then
                    newDoc.Content.InsertAfter Text:=charSaved
                    newDoc.Content.InsertAfter Text:="</p>" & vbCrLf '& vbCrLf
                    newDoc.Content.InsertAfter Text:="<p class='english'>"
                    newDoc.Content.InsertAfter Text:=char
                    periodFound = False
                Else
                    newDoc.Content.InsertAfter Text:=char
                End If
        End Select
        i = i + 1
    Next


End Sub
Public Sub mergeEnglishChinese()
'合併中英對照摩爾門經
'先開英文摩爾門經(wiki)，後開中文摩爾門經(wiki)
    Dim cDoc As Document
    Dim eDoc As Document
    Dim newDoc As Document
    
    Dim i As Integer
    
    Set eDoc = Documents(ename)
    Set cDoc = Documents(cname)
    Set newDoc = Documents.Add
    
    If cDoc.Paragraphs.Count <> eDoc.Paragraphs.Count Then
        MsgBox ("chinese:=" & cDoc.Paragraphs.Count & "  english:=" & eDoc.Paragraphs.Count)
        Exit Sub
    End If
    
    For i = 1 To cDoc.Paragraphs.Count
        newDoc.Content.InsertAfter Text:=eDoc.Paragraphs(i).Range.Text
        newDoc.Content.InsertAfter Text:=cDoc.Paragraphs(i).Range.Text
    Next

'    eDoc.Close (wdDoNotSaveChanges)
'    cDoc.Close (wdDoNotSaveChanges)

'新增2個檔案
'    Documents.Add
'    Documents.Add

End Sub