教義和聖約

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