Word VBA/教義和聖約

Option Explicit

Public Sub gothroughDocument()
    Dim myDoc As Document
    
    Dim para As Variant
    Dim char As Variant
    Dim hlink As Variant
    
    Dim txtPara As Variant
    
    Dim cntPara As Integer
    Dim cntChar As Integer
    Dim cntSup As Integer
    Dim cntLink As Integer
    Dim saveLink(200) As String
    Dim i As Integer

    
    Set myDoc = Documents("Doctrine and Covenant Sec1.docx")
    
'    cntLink = myDoc.Hyperlinks.Count
'    For i = 1 To cntLink
'        saveLink(i) = "[" & myDoc.Hyperlinks(i).Address & " " & myDoc.Hyperlinks(i).Range.Text & "]"
'    Next
'
'    For i = 1 To cntLink
'        If MsgBox(i & ":=" & saveLink(i), vbOKCancel) = vbCancel Then Exit For
'    Next
'
    
'    For i = cntLink To 1 Step -1
'        myDoc.Hyperlinks(i).Range.Delete
'    Next
    
'    For Each char In myDoc.Characters
'    Next
    
    
'    MsgBox ("Paragraphs:=" & myDoc.Paragraphs.Count & "  Words:=" & myDoc.Words.Count & "  Characters:=" & myDoc.Characters.Count & "  Superscripts:=" & cntSup)
'
    cntPara = 0
    For Each para In myDoc.Paragraphs
        cntPara = cntPara + 1
        txtPara = myDoc.Paragraphs(cntPara).Range.Text
        If MsgBox("Paragraph " & cntPara & ":=" & txtPara, vbOKCancel) = vbCancel Then Exit For
    Next
        
'    For Each char In myDoc.Characters
'        If MsgBox(char & "田" & Asc(char), vbOKCancel) = vbCancel Then Exit For
'        If char.Font.Superscript = True Then
'            MsgBox (char & " is superscript")
'        End If
'    Next
    
End Sub
Public Sub findHighLight()
'這段程式從選取範圍開始往下尋找有提醒文字的區塊，找到了就加入<span>標籤，然後把選取範圍收攏到標籤之後。
'如此反覆直到找不到提醒文字為止

    Dim myDoc As Document
    
'    Set myDoc = Documents.Open(FileName:="C:\Users\Liming\Google 雲端硬碟\02 高材生\0202 網站\Word VBA 程式設計\Becoming Goodly Parents.docx")
    Set myDoc = Documents("Becoming Goodly Parents.docx")
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst
    
    Do
        With Selection.Find
            .ClearFormatting
            .Highlight = True
            .Execute Forward:=True
        End With
        If Selection.Find.Found = True Then
            Selection.InsertBefore "<span class='highlight'>"
            Selection.InsertAfter "</span>"
            Selection.Collapse Direction:=wdCollapseEnd
        End If
    Loop While Selection.Find.Found = True
End Sub
Public Sub convertToWikiEnglish()
'本程式將英文的文章轉換為具有Wiki標籤的文章
'目前加入的標籤只限於在段落前加入 <p class='english'>，段落後加入 </p>
    Dim myDoc As Document
    Dim newDoc As Document
    
    Dim para As Variant
    Dim char As Variant
    
    Dim txtPara As Variant
    Dim cntPara As Integer
    Dim cntChar As Integer
    Dim cntSup As Integer
    Dim cntLink As Integer
    Dim cntLinkPreSec As Integer
    Dim txtLink As String
    Dim saveLink(350) As String
    Dim i As Integer
    
    Set myDoc = Documents("Doctrine and Covenant Sec027.docx")
    Set newDoc = Documents.Add
    
    If myDoc.Hyperlinks.Count > 350 Then
        MsgBox ("Hyperlinks.Count=" & myDoc.Hyperlinks.Count)
    End If
    
    cntLinkPreSec = 3
    cntPara = 0
    cntSup = cntLinkPreSec
    
    cntLink = myDoc.Hyperlinks.Count
    For i = cntLinkPreSec + 1 To cntLink
        saveLink(i) = "[" & myDoc.Hyperlinks(i).Address & " " & myDoc.Hyperlinks(i).Range.Text & "]"
    Next
    
    For i = cntLink To (cntLinkPreSec + 1) Step -1
        myDoc.Hyperlinks(i).Range.Delete
    Next
    
    
    For Each para In myDoc.Paragraphs
    
        cntPara = cntPara + 1
        txtPara = para.Range.Text
        newDoc.Content.InsertAfter Text:="<p class='english'>"
        
        If Asc(Mid(txtPara, 1, 1)) = 63 Then '節
        
            i = 2 '捨去前1個?號
            '處理節號
            
            newDoc.Content.InsertAfter Text:="<span class='englishVerse'>"
            Do Until (IsNumeric(Mid(txtPara, i, 1)) = False) Or (i = Len(txtPara))
                newDoc.Content.InsertAfter Text:=Mid(txtPara, i, 1)
                i = i + 1
            Loop
            newDoc.Content.InsertAfter Text:="</span>"
            
            '處理節號之後的文字
            
            Do Until i = Len(txtPara)
                Set char = myDoc.Paragraphs(cntPara).Range.Characters(i)
                If char.Font.Superscript = True Then
'                    If myDoc.Paragraphs(cntPara).Range.Characters(i - 1) = " " Then '如果此上標的前面已經有空白
                        cntSup = cntSup + 1
                        newDoc.Content.InsertAfter Text:="<sup class='englishSup'>" & char & "</sup>" '就不補寫空白
                        newDoc.Content.InsertAfter Text:=saveLink(cntSup)
'                    Else
'                        newDoc.Content.InsertAfter Text:=" <sup class='englishSup'>" & char & "</sup>" '否則就補寫一個空白
'                    End If
                Else
                    newDoc.Content.InsertAfter Text:=Mid(txtPara, i, 1)
                End If
                i = i + 1
            Loop

        Else '非節
            i = 1
            Do Until i = Len(txtPara)
                Set char = myDoc.Paragraphs(cntPara).Range.Characters(i)
                If char.Font.Superscript = True Then
'                    If myDoc.Paragraphs(cntPara).Range.Characters(i - 1) = " " Then '如果此上標的前面已經有空白
                        cntSup = cntSup + 1
                        newDoc.Content.InsertAfter Text:="<sup class='englishSup'>" & char & "</sup>" '就不補寫空白
                        newDoc.Content.InsertAfter Text:=saveLink(cntSup)
'                    Else
'                        newDoc.Content.InsertAfter Text:=" <sup class='englishSup'>" & char & "</sup>" '否則就補寫一個空白
'                    End If
                Else
                    newDoc.Content.InsertAfter Text:=Mid(txtPara, i, 1)
                End If
                i = i + 1
            Loop
        
        End If
        newDoc.Content.InsertAfter Text:="</p>"
        newDoc.Content.InsertAfter Text:=vbCr

    Next 'Paragraph
    
    myDoc.Close (wdDoNotSaveChanges)
    
End Sub
Public Sub convertToWikiChinese()
'本程式將中文的文章轉換為具有Wiki標籤的文章
'目前加入的標籤只限於在段落前加入 <p class='chinese'>，段落後加入 </p>
'加入標籤的方法是：
'
    Dim myDoc As Document
    Dim newDoc As Document
    
    Dim para As Variant
    Dim char As Variant
    
    Dim txtPara As Variant
    Dim cntPara As Integer
    Dim cntChar As Integer
    Dim cntSup As Integer
    Dim cntLink As Integer
    Dim cntLinkPreSec As Integer
    Dim txtLink As String
    Dim saveLink(350) As String
    Dim i As Integer
    
    
    Set myDoc = Documents("教義和聖約第027篇.docx")
    Set newDoc = Documents.Add
    
    If myDoc.Hyperlinks.Count > 350 Then
        MsgBox ("Hyperlinks.Count=" & myDoc.Hyperlinks.Count)
    End If

    
    cntLinkPreSec = 3
    cntPara = 0
    cntSup = cntLinkPreSec
    
    cntLink = myDoc.Hyperlinks.Count
    For i = (cntLinkPreSec + 1) To cntLink
        saveLink(i) = "[" & myDoc.Hyperlinks(i).Address & " " & myDoc.Hyperlinks(i).Range.Text & "]"
    Next
    
    For i = cntLink To (cntLinkPreSec + 1) Step -1
        myDoc.Hyperlinks(i).Range.Delete
    Next
    
    For Each para In myDoc.Paragraphs
    
        cntPara = cntPara + 1
        txtPara = para.Range.Text
        newDoc.Content.InsertAfter Text:="<p class='chinese'>"
        
        If Asc(Mid(txtPara, 1, 1)) = 63 Then '節
        
            i = 3 '捨去前2個?號
            '處理節號
            
            newDoc.Content.InsertAfter Text:="<span class='chineseVerse'>"
            Do Until (IsNumeric(Mid(txtPara, i, 1)) = False) Or (i = Len(txtPara))
                newDoc.Content.InsertAfter Text:=Mid(txtPara, i, 1)
                i = i + 1
            Loop
            newDoc.Content.InsertAfter Text:="</span>"
            
            '處理節號之後的文字
            
            Do Until i = Len(txtPara)
                Set char = myDoc.Paragraphs(cntPara).Range.Characters(i)
                If char.Font.Superscript = True Then
                    cntSup = cntSup + 1
                    newDoc.Content.InsertAfter Text:="<sup class='chineseSup'>" & char & "</sup>"
                    newDoc.Content.InsertAfter Text:=saveLink(cntSup)
                Else
                    newDoc.Content.InsertAfter Text:=Mid(txtPara, i, 1)
                End If
                i = i + 1
            Loop

        Else '非節
            i = 1
            Do Until i = Len(txtPara)
                Set char = myDoc.Paragraphs(cntPara).Range.Characters(i)
                If char.Font.Superscript = True Then
                    cntSup = cntSup + 1
                    newDoc.Content.InsertAfter Text:="<sup class='chineseSup'>" & char & "</sup>"
                    newDoc.Content.InsertAfter Text:=saveLink(cntSup)
                Else
                    newDoc.Content.InsertAfter Text:=Mid(txtPara, i, 1)
                End If
                i = i + 1
            Loop
        
        End If
        newDoc.Content.InsertAfter Text:="</p>"
        newDoc.Content.InsertAfter Text:=vbCr

    Next 'Paragraph
    
    myDoc.Close (wdDoNotSaveChanges)


End Sub

Public Sub mergeChineseEnglish()
'合併中英對照摩爾門經
'先開英文摩爾門經(wiki)，後開中文摩爾門經(wiki)
    Dim cDoc As Document
    Dim eDoc As Document
    Dim newDoc As Document
    
    Dim i As Integer
    
    Set cDoc = Documents(1)
    Set eDoc = Documents(2)
    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:=cDoc.Paragraphs(i).Range.Text
        newDoc.Content.InsertAfter Text:=eDoc.Paragraphs(i).Range.Text
    Next

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

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

End Sub
Public Sub convertToWikiDeutsch()
'本程式將中文的文章轉換為具有Wiki標籤的文章
'目前加入的標籤只限於在段落前加入 <p class='deutsch'>，段落後加入 </p>
'加入標籤的方法是：
'
    Dim myDoc As Document
    Dim newDoc As Document
    
    Dim para As Variant
    Dim char As Variant
    
    Dim txtPara As Variant
    Dim cntPara As Integer
    Dim cntChar As Integer
    Dim cntSup As Integer
    Dim cntLink As Integer
    Dim txtLink As String
    Dim saveLink(100) As String
    Dim i As Integer
    
    Set myDoc = Documents("1Nephi ch3 jp.docx")
    Set newDoc = Documents.Add
    
    cntPara = 0
    cntSup = 0
    
    cntLink = myDoc.Hyperlinks.Count
    For i = 1 To cntLink
        saveLink(i) = "[" & myDoc.Hyperlinks(i).Address & " " & myDoc.Hyperlinks(i).Range.Text & "]"
    Next
    
    For i = cntLink To 1 Step -1
        myDoc.Hyperlinks(i).Range.Delete
    Next
    
    For Each para In myDoc.Paragraphs
    
        cntPara = cntPara + 1
        txtPara = para.Range.Text
        newDoc.Content.InsertAfter Text:="<p class='deutsch'>"
        
        If Asc(Mid(txtPara, 1, 1)) = 63 Then '節
        
            i = 2 '捨去前1個?號
            '處理節號
            
            newDoc.Content.InsertAfter Text:="<span class='deutschVerse'>"
            Do Until (IsNumeric(Mid(txtPara, i, 1)) = False) Or (i = Len(txtPara))
                newDoc.Content.InsertAfter Text:=Mid(txtPara, i, 1)
                i = i + 1
            Loop
            newDoc.Content.InsertAfter Text:="</span>"
            
            '處理節號之後的文字
            
            Do Until i = Len(txtPara)
                Set char = myDoc.Paragraphs(cntPara).Range.Characters(i)
                If char.Font.Superscript = True Then
                    cntSup = cntSup + 1
                    newDoc.Content.InsertAfter Text:="<sup class='deutschSup'>" & char & "</sup>"
                    newDoc.Content.InsertAfter Text:=saveLink(cntSup)
                Else
                    newDoc.Content.InsertAfter Text:=Mid(txtPara, i, 1)
                End If
                i = i + 1
            Loop

        Else '非節
            i = 1
            Do Until i = Len(txtPara)
                Set char = myDoc.Paragraphs(cntPara).Range.Characters(i)
                If char.Font.Superscript = True Then
                    cntSup = cntSup + 1
                    newDoc.Content.InsertAfter Text:="<sup class='deutschSup'>" & char & "</sup>"
                    newDoc.Content.InsertAfter Text:=saveLink(cntSup)
                Else
                    newDoc.Content.InsertAfter Text:=Mid(txtPara, i, 1)
                End If
                i = i + 1
            Loop
        
        End If
        newDoc.Content.InsertAfter Text:="</p>"
        newDoc.Content.InsertAfter Text:=vbCr

    Next 'Paragraph
    

End Sub