Word

Word，參照：『維基百科～Microsoft_Word』

技術文件

• Word VBA 參考
• The Word MVP Site

應用

用戶端

IE瀏覽器專用的ActiveX

• OWC

唯讀的檢視器

• Word Viewer

.NET

• VSTO（Visual Studio Tools for Office）
• Open XML SDK
• Generating Word Reports / Documents - CodeProject

Java

• Apache POI
• docx4j

PHP

• PHPWord

FAQ

Word的簡体字轉繁體字功能罷工？

• 根據MS官方的解釋是要安裝Office的校對工具的簡体中文版？
• Office 的語言附屬套件
• 或是Word把簡體字誤以為是日文漢字？所以才沒有做轉換？（解法是轉換前先全選把語言改成「中文（中國）」）

如何將Word內容直接呈現在網頁上？

• 如何將Word內容直接呈現在網頁上？
• Office Web Apps

建立Word Web App配合SharePoint使用，可存寫，但需購買Office 2010。

• VSTO（Visual Studio Tools for Office）

以VSTO在Web-Server端進行轉檔成HTML，Web-Server端需事先安裝Word，基本上須先將Word檔上傳到Web-Server端。

以唯讀模式顯示放在Web-Server端的Word檔，免費。

其他相關

• 将Word文档转化为HTML格式的文档
• 無法複製，並將浮動物件貼上 Word 檢視器

常用快捷鍵

• Ctrl + F9 插入功能變數
• Ctrl + = 插入方程式
• Ctrl + B 粗體
• Ctrl + C 複製
• Ctrl + H 取代
• Ctrl + I 斜體
• Ctrl + V 貼上
• Ctrl + Z 取消最近一次的操作
• Ctrl + Shift + F 字型
• Ctrl + Enter = 插入分頁
• Alt + Shift + → = 縮排
• Alt + Shift + ← = 取消縮排

檔案分割

• 如何將文檔分成多個文檔？

巨集

取代

• 參考資料: Find 物件 (Word)

    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ","
        .Replacement.Text = "，"
        .Forward = True        'True (向下搜尋整個文件), False (往上搜尋整個文件)
        .Wrap = wdFindContinue 'wdFindAsk(超過範圍時詢問), wdFindContinue(超過範圍時繼續), wdFindStop(超過範圍時停止)
        .Format = False
        .MatchCase = False     'True (搜尋時區分英文大小寫)
        .MatchWholeWord = False
        .MatchByte = True      'True (搜尋時區分全形及半形)
        .MatchWildcards = False 'True (搜尋時包含萬用字元*)
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll

搜尋"^p第", 並套用樣式"標題 1"

• 版本1 (可能誤判, 須小心使用)

    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "^p第"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
        .MatchFuzzy = False
    End With
 
    Do While Selection.Find.Execute
        Selection.Style = ActiveDocument.Styles("標題 1")
    Loop

• 版本2 (可能誤判, 須小心使用)

    Dim sArray(3) As String
    Dim FindStr As Variant
 
    sArray(0) = "^p第^#話"
    sArray(1) = "^p第^#^#話"
    sArray(2) = "^p第^#^#^#話"
 
    For Each FindStr In sArray
       Selection.HomeKey Unit:=wdStory, Extend:=wdMove
       Selection.Find.ClearFormatting
       With Selection.Find
           .Text = FindStr
           .Replacement.Text = ""
           .Forward = True
           .Wrap = wdFindContinue
           .Format = False
           .MatchCase = False
           .MatchWholeWord = False
           .MatchByte = True
           .MatchAllWordForms = False
           .MatchSoundsLike = False
           .MatchWildcards = False
           .MatchFuzzy = False
       End With
 
       Do While Selection.Find.Execute
           Selection.EndKey Unit:=wdLine, Extend:=wdExtend
           Selection.Style = ActiveDocument.Styles("標題 1")
           Selection.MoveDown Unit:=wdLine, Count:=1
           DoEvents
       Loop
    Next FindStr

檔案分割自動存成Txt檔

• (可能誤判, 須小心使用)

Function CInt2(str As String) As Integer
    Dim strTemp As String
    Dim i As Integer
    strTemp = ""
 
    For i = 1 To Len(str) Step 1
        strTemp = Mid(str, 1, i)
        If (IsNumeric(strTemp)) Then
            CInt2 = CInt(strTemp)
        End If
    Next i
End Function
 
Sub 分割另存Txt檔()
'
' 分割另存Txt檔 巨集
'
'
    Dim iFile As Long
    Dim iIndex As Long
    Dim iStart As Long
    Dim iEnd As Long
    Dim strTitle As String
    Dim strTitle2 As String
    Dim docSrc As Document
    Dim docDest As Document
 
    Set docSrc = ActiveDocument
 
    iFile = 1
    iStart = 0
    iEnd = 0
    strTitle = ""
 
    Selection.HomeKey Unit:=wdStory, Extend:=wdMove
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "^p第^#"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
        .MatchFuzzy = False
    End With
    iStart = Selection.start
 
    Do While Selection.Find.Execute
        Selection.EndKey Unit:=wdLine, Extend:=wdExtend
        If (Selection.Style Is Nothing) Then
        Else
            'If (Selection.Style = ActiveDocument.Styles("標題 1")) Then
                strTitle2 = Selection.Text
                strTitle2 = Replace(Replace(strTitle2, Chr(10), ""), Chr(13), "")
                strTitle2 = Trim(strTitle2)
                iEnd = Selection.start - 1
                iIndex = Selection.End
 
                If (strTitle = "") Then strTitle = strTitle2
            'End If
        End If
        Selection.MoveDown Unit:=wdLine, Count:=1
 
        If (iEnd > iStart) Then
            Set docDest = Documents.Add
 
            docDest.Range = docSrc.Range(iStart, iEnd)
 
            'strName = docSrc.Path & Application.PathSeparator & "txt" & Application.PathSeparator & Format(iFile, "0000") & "0_" & strTitle & ".txt"
            strName = docSrc.Path & Application.PathSeparator & "txt" & Application.PathSeparator & Format(CInt2(Mid(strTitle, 2, 3)), "0000") & "0_" & strTitle & ".txt"
            docDest.SaveAs2 FileName:=strName, FileFormat:=wdFormatText, Encoding:=msoEncodingUTF8
            docDest.Close
 
            iFile = iFile + 1
            iStart = iIndex
            strTitle = strTitle2
        End If
 
        DoEvents
    Loop
 
   iEnd = docSrc.Range.End
 
    Set docDest = Documents.Add
 
    docDest.Range = docSrc.Range(iStart, iEnd)
 
    'strName = docSrc.Path & Application.PathSeparator & "txt" & Application.PathSeparator & Format(iFile, "0000") & "0_" & strTitle & ".txt"
    strName = docSrc.Path & Application.PathSeparator & "txt" & Application.PathSeparator & Format(CInt2(Mid(strTitle, 2, 3)), "0000") & "0_" & strTitle & ".txt"
    docDest.SaveAs2 FileName:=strName, FileFormat:=wdFormatText, Encoding:=msoEncodingUTF8
    docDest.Close
End Sub

大量取代(UTF8修正版)

• 原始出處: 如何用findeplace做大量不同字串的取代

Sub MassReplace()
'
' MassReplace 巨集
'
'
    Dim arrStr() As String          '替換前與替換後的內容(分割後的字串陣列)
    Dim InputStr As Variant         '替換前與替換後的內容(分割前的字串)
    Dim ReplaceTxtFile As String    '替換對照檔的路徑與檔名
    Dim LineNum As Integer          '替換對照檔用的第幾行計數(除錯用)
    Dim sArray() As String          '替換對照檔的內容(依各行切割後的字串陣列)
    Dim adoStream As Object         'ADO (讀取UTF8的txt檔用)
 
    'ReplaceTxtFile = CurDir + "\Replace.txt"
    'ReplaceTxtFile = "C:\Work\Replace.txt"
    ReplaceTxtFile = ActiveDocument.Path & Application.PathSeparator & "Replace.txt"    '從開啟的Word檔的同一資料夾裡取得Replace.txt
 
    If Dir(ReplaceTxtFile) = "" Then
        MsgBox ("替換對照檔不存在 " & ReplaceTxtFile)
        Exit Sub
    End If
 
    '讀取UTF8格式的替換對照檔
    Set adoStream = CreateObject("ADODB.Stream")
    If IsNull(adoStream) Then
        MsgBox ("請先至MS官網下載與安裝MDAC, 安裝後請重新啟動Word")
        Exit Sub
    End If
    adoStream.Charset = "UTF-8"
    adoStream.Open
        adoStream.LoadFromFile ReplaceTxtFile 'change this to point to your text file
        sArray = Split(adoStream.ReadText, vbCrLf) 'split entire file into array - lines delimited by CRLF
    adoStream.Close
    Set adoStream = Nothing
 
    Application.ScreenUpdating = False  '畫面暫停更新
    LineNum = 1
    For Each InputStr In sArray
        If Len(InputStr) > 0 And Mid(InputStr, 1, 1) <> "'" Then '若第一個字元是'就跳過此列
            arrStr = Split(InputStr, ",")  '把讀入的文字列依逗號分成兩個字串, 置於 arrStr 陣列裡
            If (GetArrayLength(arrStr) = 2) Then
                Call ReplaceText(arrStr(0), arrStr(1))
            Else
                MsgBox ("警告! 替換對照檔的第" & Str(LineNum) & "行異常, 請自行檢查!")
            End If
        End If
        LineNum = LineNum + 1
    Next InputStr
    Application.ScreenUpdating = True  '畫面恢復更新
End Sub
 
Function ReplaceText(Src As String, Rpl As String)
'這個函式會在整個檔案裡搜尋 Src 字串, 將它取代為 Rpl 字串
 
    Selection.HomeKey Unit:=wdStory, Extend:=wdMove
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = Src
        .Replacement.Text = Rpl
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
        .MatchFuzzy = False
        .Execute Replace:=wdReplaceAll  '全部取代
    End With
End Function
 
Function GetArrayLength(a As Variant) As Integer
   If IsEmpty(a) Then
      GetArrayLength = 0
   Else
      GetArrayLength = UBound(a) - LBound(a) + 1
   End If
End Function

取得資料夾路徑

• 原始出處: Folder Picker for MS Word

Function GetFolder(strPath As String) As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function

存檔成篩選的HTML格式(以UTF8編碼)

• 原始出處: Document.SaveAs2 方法 (Word)

Sub SaveAsFilteredHTMLFile() 
    Dim strDocName As String 
    Dim intPos As Integer 
 
    ' Find position of extension in file name 
    strDocName = ActiveDocument.Name 
    intPos = InStrRev(strDocName, ".") 
 
    If intPos = 0 Then 
 
        ' If the document has not yet been saved 
        ' Ask the user to provide a file name 
        strDocName = InputBox("Please enter the name " & _ 
            "of your document.") 
    Else 
 
        ' Strip off extension and add ".html" extension 
        strDocName = Left(strDocName, intPos - 1) 
        strDocName = strDocName & ".html" 
    End If 
 
    ' Save file with new extension 
    ActiveDocument.SaveAs2 FileName:=strDocName, _ 
        FileFormat:=wdFormatFilteredHTML, _
        Encoding:=msoEncodingUTF8
End Sub

選擇資料夾大量轉檔存檔成篩選的HTML格式(以UTF8編碼)

• 參考資料: Excel VBA to Open Multiple Word files in a loop

Function GetFolder(strPath As String) As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function
 
 
Sub SaveAsFormatFilteredHtmlFiles()
    Dim PathName As String
    Dim fso As Object           'FileSystemObject
    Dim objFile As Variant      'File
    Dim objFolder As Object     'Folder
    Dim objWordDoc As Document
 
    Dim strDocName As String
    Dim strExt As String
    Dim intPos As Integer
 
    On Error GoTo Err_Handler
 
    PathName = GetFolder("")
 
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set objFolder = fso.GetFolder(PathName)
 
 
    For Each objFile In objFolder.Files
        ' Find position of extension in file name
        strDocName = objFile.Path
        intPos = InStrRev(strDocName, ".")
        strExt = Right(strDocName, Len(strDocName) - intPos)
 
 
        If StrComp(strExt, "docx", vbTextCompare) = 0 Then
            Set objWordDoc = Documents.Open(strDocName)
            If Not (objWordDoc Is Nothing) Then
 
                If intPos <> 0 Then
                    ' Strip off extension and add ".html" extension
                    strDocName = Left(strDocName, intPos - 1)
                    strDocName = strDocName & ".html"
 
 
                    ' Save file with new extension
                    objWordDoc.SaveAs2 FileName:=strDocName, _
                        FileFormat:=wdFormatFilteredHTML, _
                        Encoding:=msoEncodingUTF8
                End If
 
                objWordDoc.Close 'savechanges:=wdDoNotSaveChanges
                Set objWordDoc = Nothing
            End If
        End If
    Next
 
Exit_Handler:
  Exit Sub
 
Err_Handler:
  MsgBox "Error " & Err.Number & ": " & Err.Description
  Resume Exit_Handler
 
End Sub

擷取某網站一頁的文字內容

Function GetHttpRequestText(strUrl As String) As String
    Dim xmlHttpReq As Object
    Set xmlHttpReq = CreateObject("MSXML2.XMLHTTP.6.0")
 
    xmlHttpReq.Open "GET", strUrl, False
    xmlHttpReq.send
 
    If (xmlHttpReq.readyState = 4) Then
        If (xmlHttpReq.Status = 200) Then
            GetHttpRequestText = xmlHttpReq.responseText
        End If
    End If
 
    Set xmlHttpReq = Nothing
End Function
 
 
Sub 擷取某網站一頁的文字內容()
'
' 擷取某網站一頁的文字內容 巨集
'
'
 
    Dim strUrl As String
    Dim strText As String
    strUrl = InputBox("Please enter the Url.")
 
    '取得網頁內容
    strText = GetHttpRequestText(strUrl)
 
    '插入分頁
    ActiveDocument.Paragraphs.Add
    ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range.Select
    Selection.InsertBreak Type:=wdPageBreak
 
 
 
    Dim iPos1 As Integer
    Dim iPos2 As Integer
    Dim strFind1 As String
    Dim strFind2 As String
 
    '文章標題
    strFind1 = "<h3>"
    strFind2 = "</h3>"
    iPos1 = InStr(strText, strFind1)
    iPos2 = InStr(strText, strFind2)
    ActiveDocument.Paragraphs.Add
    ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range.Select
    Selection.InsertAfter Mid(strText, iPos1 + Len(strFind1), iPos2 - iPos1 - Len(strFind1))
    Selection.Style = ActiveDocument.Styles("標題 1")
 
    '下一個段落
    ActiveDocument.Paragraphs.Add
    ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range.Select
 
   '文章內文
    strFind1 = "<div class=""col-xs-12 m-b-30 forum-content"""
    strFind2 = "</div>"
    iPos1 = InStr(strText, strFind1)
    If (iPos1 <> 0) Then
        iPos1 = InStr(iPos1, strText, ">")
    End If
    If (iPos1 <> 0) Then
        iPos2 = InStr(iPos1, strText, strFind2)
        strText = Mid(strText, iPos1 + Len(strFind1), iPos2 - iPos1 - Len(strFind1))
    End If
    Selection.InsertAfter strText
    Selection.Style = ActiveDocument.Styles("內文")
 
    '以下是取代文章內文裡殘留的HTML標籤
    'Dim strReplaceConfig As String
    'Dim sArray() As String          '替換對照檔的內容(依各行切割後的字串陣列)
    Dim sArray(6) As String          '替換對照檔的內容(依各行切割後的字串陣列)
    Dim arrStr() As String          '替換前與替換後的內容(分割後的字串陣列)
    Dim InputStr As Variant         '替換前與替換後的內容(分割前的字串)
 
 
    'strReplaceConfig = "<p>,^p;</p>,;<br>,^p;^p&nbsp;^p,^p"
    'sArray = Split(strReplaceConfig, ";")
    sArray(0) = "<p>,^p"
    sArray(1) = "</p>,"
    sArray(2) = "<br>,^p"
    sArray(3) = "^p&nbsp;^p,^p"
    sArray(4) = "&hellip;,…"
    sArray(5) = "^p^p^p,^p^p"
 
    Application.ScreenUpdating = False  '畫面暫停更新
    For Each InputStr In sArray
        If Len(InputStr) > 0 Then
            arrStr = Split(InputStr, ",")  '把讀入的文字列依逗號分成兩個字串, 置於 arrStr 陣列裡
            If (GetArrayLength(arrStr) = 2) Then
                Call ReplaceText(arrStr(0), arrStr(1))
            End If
        End If
    Next InputStr
    Application.ScreenUpdating = True  '畫面恢復更新
 
End Sub

大量擷取某網站的文字內容

Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function GetClipboardData Lib "User32" (ByVal wFormat As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags&, ByVal dwBytes As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
 
Public Const GHND = &H42
Public Const CF_TEXT = 1
Public Const MAXSIZE = 32000
 
Function ClipBoard_GetData()
   Dim hClipMemory As Long
   Dim lpClipMemory As Long
   Dim MyString As String
   Dim RetVal As Long
 
   If OpenClipboard(0&) = 0 Then
      MsgBox "Cannot open Clipboard. Another app. may have it open"
      Exit Function
   End If
 
   ' Obtain the handle to the global memory
   ' block that is referencing the text.
   hClipMemory = GetClipboardData(CF_TEXT)
   If IsNull(hClipMemory) Then
      MsgBox "Could not allocate memory"
      GoTo OutOfHere
   End If
 
   ' Lock Clipboard memory so we can reference
   ' the actual data string.
   lpClipMemory = GlobalLock(hClipMemory)
 
   If Not IsNull(lpClipMemory) Then
      MyString = Space$(MAXSIZE)
      RetVal = lstrcpy(MyString, lpClipMemory)
      RetVal = GlobalUnlock(hClipMemory)
 
      ' Peel off the null terminating character.
      MyString = Mid(MyString, 1, InStr(1, MyString, Chr$(0), 0) - 1)
   Else
      MsgBox "Could not lock memory to copy string from."
   End If
 
OutOfHere:
 
   RetVal = CloseClipboard()
   ClipBoard_GetData = MyString
 
End Function
 
 
 
Function GetHttpRequestText(strUrl As String) As String
    Dim xmlHttpReq As Object
    Set xmlHttpReq = CreateObject("MSXML2.XMLHTTP.6.0")
 
    xmlHttpReq.Open "GET", strUrl, False
    xmlHttpReq.send
 
    If (xmlHttpReq.readyState = 4) Then
        If (xmlHttpReq.Status = 200) Then
            GetHttpRequestText = xmlHttpReq.responseText
        End If
    End If
 
    Set xmlHttpReq = Nothing
End Function
 
 
Sub 大量擷取某網站的文字內容()
'
' 大量擷取某網站的文字內容 巨集
'
'
    Dim strUrl As Variant
    Dim strUrl2 As String
    Dim sArrayUrl() As String
    Dim strText As String
    Dim iPos1 As Integer
    Dim iPos2 As Integer
    Dim strFind1 As String
    Dim strFind2 As String
 
 
    strUrl = ClipBoard_GetData()
    If IsNull(strUrl) Then
        MsgBox ("剪貼簿是空的, 請複製網址後再執行此巨集")
        Exit Sub
    End If
    sArrayUrl = Split(strUrl, vbCrLf) 'split entire file into array - lines delimited by CRLF
 
    For Each strUrl In sArrayUrl
        strUrl = Trim(strUrl)
 
        If Len(strUrl) > 0 Then
 
            strFind1 = "http"
            strFind2 = "</p>"
            iPos1 = InStr(strUrl, strFind1)
            iPos2 = InStr(strUrl, strFind2)
 
            If (iPos1 <> 0) Then
                strUrl2 = Mid(strUrl, iPos1, iPos2 - iPos1)
                strText = GetHttpRequestText(strUrl2)
 
                ActiveDocument.Paragraphs.Add
                ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range.Select
                Selection.InsertBreak Type:=wdPageBreak
 
 
                strFind1 = "<h3>"
                strFind2 = "</h3>"
                iPos1 = InStr(strText, strFind1)
                iPos2 = InStr(strText, strFind2)
 
                ActiveDocument.Paragraphs.Add
                ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range.Select
                Selection.InsertAfter Mid(strText, iPos1 + Len(strFind1), iPos2 - iPos1 - Len(strFind1))
                Selection.Style = ActiveDocument.Styles("標題 1")
 
 
                ActiveDocument.Paragraphs.Add
                ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range.Select
 
                strFind1 = "<div class=""col-xs-12 m-b-30 forum-content"""
                strFind2 = "</div>"
                iPos1 = InStr(strText, strFind1)
                If (iPos1 <> 0) Then
                    iPos1 = InStr(iPos1, strText, ">")
                End If
                If (iPos1 <> 0) Then
                    iPos2 = InStr(iPos1, strText, strFind2)
                    strText = Mid(strText, iPos1 + Len(strFind1), iPos2 - iPos1 - Len(strFind1))
                End If
 
                Selection.InsertAfter strText
                Selection.Style = ActiveDocument.Styles("內文")
 
            End If
 
        End If
    Next strUrl
 
 
    '以下是取代文章內文裡殘留的HTML標籤
    'Dim strReplaceConfig As String
    'Dim sArray() As String          '替換對照檔的內容(依各行切割後的字串陣列)
    Dim sArray(6) As String          '替換對照檔的內容(依各行切割後的字串陣列)
    Dim arrStr() As String          '替換前與替換後的內容(分割後的字串陣列)
    Dim InputStr As Variant         '替換前與替換後的內容(分割前的字串)
 
 
 
    'strReplaceConfig = "<p>,^p;</p>,;<br>,^p;^p&nbsp;^p,^p"
    'sArray = Split(strReplaceConfig, ";")
    sArray(0) = "<p>,^p"
    sArray(1) = "</p>,"
    sArray(2) = "<br>,^p"
    sArray(3) = "^p&nbsp;^p,^p"
    sArray(4) = "&hellip;,…"
    sArray(5) = "^p^p^p,^p^p"
 
    Application.ScreenUpdating = False  '畫面暫停更新
    For Each InputStr In sArray
        If Len(InputStr) > 0 Then
            arrStr = Split(InputStr, ",")  '把讀入的文字列依逗號分成兩個字串, 置於 arrStr 陣列裡
            If (GetArrayLength(arrStr) = 2) Then
                Call ReplaceText(arrStr(0), arrStr(1))
            End If
        End If
    Next InputStr
    Application.ScreenUpdating = True  '畫面恢復更新
 
 
End Sub

大量擷取某網站的文字內容(強化版)

Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function GetClipboardData Lib "User32" (ByVal wFormat As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags&, ByVal dwBytes As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
 
Public Const GHND = &H42
Public Const CF_TEXT = 1
Public Const MAXSIZE = 32000
 
Public Const WebTypeESJ = 1
Public Const WebTypeSyosetu = 2
Public Const WebTypeOther = -1
 
Function ReplaceText(Src As String, Rpl As String)
'這個函式會在整個檔案裡搜尋 Src 字串, 將它取代為 Rpl 字串
 
    Selection.HomeKey Unit:=wdStory, Extend:=wdMove
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = Src
        .Replacement.Text = Rpl
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
        .MatchFuzzy = False
        .Execute Replace:=wdReplaceAll  '全部取代
    End With
End Function
 
Function GetHttpRequestText(strUrl As String) As String
    GetHttpRequestText = ""
    Dim xmlHttpReq As Object
    Set xmlHttpReq = CreateObject("MSXML2.XMLHTTP.6.0")
 
    xmlHttpReq.Open "GET", strUrl, False
    xmlHttpReq.send
 
    If (xmlHttpReq.readyState = 4) Then
        If (xmlHttpReq.Status = 200) Then
            GetHttpRequestText = xmlHttpReq.responseText
        End If
    End If
 
    Set xmlHttpReq = Nothing
End Function
 
Function ClipBoard_GetData()
   Dim hClipMemory As Long
   Dim lpClipMemory As Long
   Dim MyString As String
   Dim RetVal As Long
 
   If OpenClipboard(0&) = 0 Then
      MsgBox "Cannot open Clipboard. Another app. may have it open"
      Exit Function
   End If
 
   ' Obtain the handle to the global memory
   ' block that is referencing the text.
   hClipMemory = GetClipboardData(CF_TEXT)
   If IsNull(hClipMemory) Then
      MsgBox "Could not allocate memory"
      GoTo OutOfHere
   End If
 
   ' Lock Clipboard memory so we can reference
   ' the actual data string.
   lpClipMemory = GlobalLock(hClipMemory)
 
   If Not IsNull(lpClipMemory) Then
      MyString = Space$(MAXSIZE)
      RetVal = lstrcpy(MyString, lpClipMemory)
      RetVal = GlobalUnlock(hClipMemory)
 
      ' Peel off the null terminating character.
      MyString = Mid(MyString, 1, InStr(1, MyString, Chr$(0), 0) - 1)
   Else
      MsgBox "Could not lock memory to copy string from."
   End If
 
OutOfHere:
 
   RetVal = CloseClipboard()
   ClipBoard_GetData = MyString
 
End Function
 
 
 
Function FindString(iPos As Long, Src As String) As Long
    If (iPos = 0) Then
        Selection.HomeKey Unit:=wdStory, Extend:=wdMove
    Else
        Selection.Start = iPos
    End If
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = Src
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
        .MatchFuzzy = False
    End With
 
    If (Selection.Find.Execute) Then
        FindString = Selection.Start
    Else
        FindString = -1
    End If
 
End Function
 
 
Sub 大量擷取某網站的文字內容()
'
' 大量擷取某網站的文字內容 巨集
'
'
    Dim strUrl As Variant
    Dim strUrl2 As String
    Dim sArrayUrl() As String
    Dim strText As String
    Dim iPos1 As Long
    Dim iPos2 As Long
    Dim strFind1 As String
    Dim strFind2 As String
 
    strUrl = ClipBoard_GetData()
    If IsNull(strUrl) Then
        MsgBox ("剪貼簿是空的, 請複製網址後再執行此巨集")
        Exit Sub
    End If
    sArrayUrl = Split(strUrl, vbCrLf) 'split entire file into array - lines delimited by CRLF
    'MsgBox (GetArrayLength(sArrayUrl))
 
    Dim WebType As Integer
    Dim strChapterTitle0 As String
    Dim strChapterTitle As String
    Dim strSubTitle As String
    Dim strNovelText As String
    strChapterTitle0 = ""
    strChapterTitle = ""
 
    For Each strUrl In sArrayUrl
        strUrl = Trim(strUrl)
        strUrl2 = ""
 
        strText = ""        
        strSubTitle = ""
        strNovelText = ""
 
        If Len(strUrl) > 0 Then
 
            If (InStr(strUrl, "https://www.esj") > 0) Then
                WebType = WebTypeESJ
                strFind1 = "http"
                strFind2 = ".html"
                iPos1 = InStr(strUrl, strFind1)
                iPos2 = InStr(iPos1, strUrl, strFind2)
                strUrl2 = Mid(strUrl, iPos1, iPos2 - iPos1 + Len(strFind2))
            ElseIf (InStr(strUrl, "<a href=""/") > 0) Then
                WebType = WebTypeSyosetu
                strFind1 = "<a href="""
                strFind2 = """>"
                iPos1 = InStr(strUrl, strFind1)
                iPos2 = InStr(iPos1, strUrl, strFind2)
                strUrl2 = "https://ncode.syosetu.com" + Mid(strUrl, iPos1 + Len(strFind1), iPos2 - iPos1 - Len(strFind1))
            Else
                WebType = WebTypeOther
                strFind1 = "http"
                iPos1 = InStr(strUrl, strFind1)
                If (iPos1 <> 0) Then
                    strFind2 = ".html"
                    iPos2 = InStr(iPos1, strUrl, strFind2)
                    If (iPos1 <> 0 And iPos2 <> 0) Then strUrl2 = Mid(strUrl, iPos1 + Len(strFind1), iPos2 - iPos1)
                    If (Len(strUrl2) = 0) Then
                        strFind2 = ".htm"
                        iPos2 = InStr(iPos1, strUrl, strFind2)
                        If (iPos1 <> 0 And iPos2 <> 0) Then strUrl2 = Mid(strUrl, iPos1 + Len(strFind1), iPos2 - iPos1)
                    End If
                    If (Len(strUrl2) = 0) Then
                        strUrl2 = Left(strUrl, Len(strUrl) - iPos1 + 1)
                    End If
                End If
            End If
 
 
            If (Len(strUrl2) <> 0) Then
                'MsgBox (strUrl2)
                'Exit Sub
 
 
                strText = GetHttpRequestText(strUrl2)
                'MsgBox (Len(strText))
                'Exit Sub
            End If
 
 
            If (WebType = WebTypeOther) Then
                strFind1 = "<div class=""col-xs-12 m-b-30 forum-content"">"
                iPos1 = InStr(strText, strFind1)
                If (iPos1 > 0) Then WebType = WebTypeESJ
 
                strFind1 = "<p class=""novel_subtitle"">"
                iPos1 = InStr(strText, strFind1)
                If (iPos1 > 0) Then WebType = WebTypeSyosetu
            End If
 
 
            If (Len(strText) <> 0) Then
                If (WebType = WebTypeESJ) Then
 
                    strFind1 = "<h3>"
                    strFind2 = "</h3>"
                    iPos1 = InStr(strText, strFind1)
                    iPos2 = InStr(iPos1, strText, strFind2)
                    strSubTitle = Mid(strText, iPos1 + Len(strFind1), iPos2 - iPos1 - Len(strFind1))
 
                    strFind1 = "<div class=""col-xs-12 m-b-30 forum-content"""
                    strFind2 = "</div>"
                    iPos1 = InStr(strText, strFind1)
                    If (iPos1 <> 0) Then
                        iPos1 = InStr(iPos1, strText, ">")
                    End If
                    If (iPos1 <> 0) Then
                        iPos2 = InStr(iPos1, strText, strFind2)
                        strNovelText = Mid(strText, iPos1 + Len(strFind1), iPos2 - iPos1 - Len(strFind1))
                    End If
 
 
                ElseIf (WebType = WebTypeSyosetu) Then
                    strFind1 = "<p class=""chapter_title"">"
                    strFind2 = "</p>"
                    iPos1 = InStr(strText, strFind1)
                    iPos2 = InStr(iPos1, strText, strFind2)
                    strChapterTitle = Mid(strText, iPos1 + Len(strFind1), iPos2 - iPos1 - Len(strFind1))
 
                    strFind1 = "<p class=""novel_subtitle"">"
                    strFind2 = "</p>"
                    iPos1 = InStr(strText, strFind1)
                    iPos2 = InStr(iPos1, strText, strFind2)
                    strSubTitle = Mid(strText, iPos1 + Len(strFind1), iPos2 - iPos1 - Len(strFind1))
 
                    strFind1 = "<div id=""novel_honbun"" class=""novel_view"">"
                    strFind2 = "</div>"
                    iPos1 = InStr(strText, strFind1)
                    iPos2 = InStr(iPos1, strText, strFind2)
                    strNovelText = Mid(strText, iPos1 + Len(strFind1), iPos2 - iPos1 - Len(strFind1))
 
 
                ElseIf (WebType = WebTypeOther) Then
                    strFind1 = "<title>"
                    strFind2 = "</title>"
                    iPos1 = InStr(strText, strFind1)
                    iPos2 = InStr(iPos1, strText, strFind2)
                    strSubTitle = Mid(strText, iPos1 + Len(strFind1), iPos2 - iPos1 - Len(strFind1))
 
                    strFind1 = "<body"
                    strFind2 = "</body>"
                    iPos1 = InStr(strText, strFind1)
                    iPos2 = InStr(iPos1, strText, strFind2)
                    strNovelText = Mid(strText, iPos1 + Len(strFind1), iPos2 - iPos1 - Len(strFind1))
                End If
            End If
 
 
            If (Len(strNovelText) <> 0) Then
                ActiveDocument.Paragraphs.Add
                ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range.Select
                Selection.InsertBreak Type:=wdPageBreak
 
                If (WebType = WebTypeSyosetu) Then
                    If (strChapterTitle0 <> strChapterTitle) Then
                        ActiveDocument.Paragraphs.Add
                        ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range.Select
                        Selection.InsertAfter strChapterTitle
                        Selection.Style = ActiveDocument.Styles("標題 1")
                        strChapterTitle0 = strChapterTitle
                    End If
                End If
 
                ActiveDocument.Paragraphs.Add
                ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range.Select
                Selection.InsertAfter strSubTitle
                If (WebType = WebTypeSyosetu) Then
                    Selection.Style = ActiveDocument.Styles("標題 2")
                Else
                    Selection.Style = ActiveDocument.Styles("標題 1")
                End If
 
                ActiveDocument.Paragraphs.Add
                ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range.Select
 
                Selection.InsertAfter strNovelText
                Selection.Style = ActiveDocument.Styles("內文")
 
            End If
 
        End If
    Next strUrl
 
 
 
    Application.ScreenUpdating = False  '畫面暫停更新
 
    If (WebType = WebTypeSyosetu) Then
        '需要清理 <p id="L^#"> 與 <p id="L^#^#"> 與 <p id="L^#^#^#">
        Call ReplaceText("<p id=""L^#"">", "")
        Call ReplaceText("<p id=""L^#^#"">", "")
        Call ReplaceText("<p id=""L^#^#^#"">", "")
        Call ReplaceText("<br />", "")
    End If
 
    If (WebType = WebTypeESJ) Then
        '需要清理 <script 與 </script> 以及 <ins 與 </ins>
        Call CutString("<script", "</script>")
        Call CutString("<ins", "</ins>")
        Call CutString("<p class=", ">")
    End If
 
    'Dim strReplaceConfig As String
    'Dim sArray() As String          '替換對照檔的內容(依各行切割後的字串陣列)
    Dim sArray(6) As String          '替換對照檔的內容(依各行切割後的字串陣列)
    Dim arrStr() As String          '替換前與替換後的內容(分割後的字串陣列)
    Dim InputStr As Variant         '替換前與替換後的內容(分割前的字串)
 
 
 
    'strReplaceConfig = "<p>,^p;</p>,;<br>,^p;^p&nbsp;^p,^p"
    'sArray = Split(strReplaceConfig, ";")
    sArray(0) = "<p>,^p"
    sArray(1) = "</p>,"
    sArray(2) = "<br>,^p"
    sArray(3) = "^p&nbsp;^p,^p"
    sArray(4) = "&hellip;,…"
    sArray(5) = "^p^p^p,^p^p"
 
 
 
    For Each InputStr In sArray
        If Len(InputStr) > 0 Then
            arrStr = Split(InputStr, ",")  '把讀入的文字列依逗號分成兩個字串, 置於 arrStr 陣列裡
            If (GetArrayLength(arrStr) = 2) Then
                Call ReplaceText(arrStr(0), arrStr(1))
            End If
        End If
    Next InputStr
    Application.ScreenUpdating = True  '畫面恢復更新
End Sub
 
 
Function CutString(strFind1 As String, strFind2 As String)
    Dim iPos1 As Long
    Dim iPos2 As Long
 
    iPos1 = FindString(0, strFind1)
    Do While (iPos1 <> -1)
 
        iPos2 = FindString(iPos1, strFind2)
        If (iPos2 <> -1) Then
            Selection.Start = iPos1
            Selection.End = iPos2 + Len(strFind2)
            Selection.Cut
 
            iPos1 = FindString(iPos1, strFind1)
        Else
            iPos1 = -1
        End If
    Loop
End Function

大量擷取某網站的文字內容(強化版2)

• 需引用【Microsoft HTML Object Library】與【Microsoft Internet Controls】
• IE需安裝檔廣告的外掛Adblock Plus

Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function GetClipboardData Lib "User32" (ByVal wFormat As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags&, ByVal dwBytes As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
 
Public Const GHND = &H42
Public Const CF_TEXT = 1
Public Const MAXSIZE = 32000
 
Public Const WebTypeESJ = 1
Public Const WebTypeSyosetu = 2
Public Const WebTypekakuyomu = 3
Public Const WebTypeOther = -1
 
Function ClipBoard_GetData()
   Dim hClipMemory As Long
   Dim lpClipMemory As Long
   Dim MyString As String
   Dim RetVal As Long
 
   If OpenClipboard(0&) = 0 Then
      MsgBox "Cannot open Clipboard. Another app. may have it open"
      Exit Function
   End If
 
   ' Obtain the handle to the global memory
   ' block that is referencing the text.
   hClipMemory = GetClipboardData(CF_TEXT)
   If IsNull(hClipMemory) Then
      MsgBox "Could not allocate memory"
      GoTo OutOfHere
   End If
 
   ' Lock Clipboard memory so we can reference
   ' the actual data string.
   lpClipMemory = GlobalLock(hClipMemory)
 
   If Not IsNull(lpClipMemory) Then
      MyString = Space$(MAXSIZE)
      RetVal = lstrcpy(MyString, lpClipMemory)
      RetVal = GlobalUnlock(hClipMemory)
 
      ' Peel off the null terminating character.
      MyString = Mid(MyString, 1, InStr(1, MyString, Chr$(0), 0) - 1)
   Else
      MsgBox "Could not lock memory to copy string from."
   End If
 
OutOfHere:
 
   RetVal = CloseClipboard()
   ClipBoard_GetData = MyString
 
End Function
 
Sub 大量擷取某網站的文字內容2()
'
' 大量擷取某網站的文字內容2 巨集
'
'
    On Error GoTo Err
 
    Dim HTMLDoc As HTMLDocument
    Dim oBrowser As InternetExplorer
    Dim oDocument As HTMLDocument
    Dim oCollection As IHTMLElementCollection
    Dim oElement As IHTMLElement
 
    Set oBrowser = New InternetExplorer
    oBrowser.Height = 400
    oBrowser.Width = 400
    oBrowser.Silent = False
    oBrowser.Visible = True 'False
 
 
    Dim strUrl As Variant
    Dim strUrl2 As String
    Dim sArrayUrl() As String
    Dim strText As String
    Dim iPos1 As Long
    Dim iPos2 As Long
    Dim strFind1 As String
    Dim strFind2 As String
 
    strUrl = ClipBoard_GetData()
    If IsNull(strUrl) Then
        MsgBox ("剪貼簿是空的, 請複製網址後再執行此巨集")
        Exit Sub
    End If
    sArrayUrl = Split(strUrl, vbCr) 'split entire file into array - lines delimited by CR
 
 
    Dim WebType As Integer
    Dim strChapterTitle0 As String
    Dim strChapterTitle As String
    Dim strSubTitle As String
    Dim strNovelText As String
    strChapterTitle0 = ""
    strChapterTitle = ""
 
    For Each strUrl In sArrayUrl
        strUrl = Trim(strUrl)
        strUrl2 = ""
 
 
        strText = ""
        strSubTitle = ""
        strNovelText = ""
 
        If Len(strUrl) > 0 Then
 
            If (InStr(strUrl, "https://www.esj") > 0) Then
                WebType = WebTypeESJ
                strFind1 = "http"
                strFind2 = ".html"
                iPos1 = InStr(strUrl, strFind1)
                iPos2 = InStr(iPos1, strUrl, strFind2)
                strUrl2 = Mid(strUrl, iPos1, iPos2 - iPos1 + Len(strFind2))
            ElseIf ((InStr(strUrl, "<a href=""/works/") > 0) And (InStr(strUrl, "/episodes/") > 0)) Then
                WebType = WebTypekakuyomu
                strFind1 = "<a href="""
                strFind2 = """>"
                iPos1 = InStr(strUrl, strFind1)
                iPos2 = InStr(iPos1, strUrl, strFind2)
                strUrl2 = "https://kakuyomu.jp/works/works/" + Mid(strUrl, iPos1 + Len(strFind1), iPos2 - iPos1 - Len(strFind1))
            ElseIf (InStr(strUrl, "kakuyomu.jp") > 0) Then
                WebType = WebTypekakuyomu
                strUrl2 = Trim(strUrl)
            ElseIf (InStr(strUrl, "<a href=""/") > 0) Then
                WebType = WebTypeSyosetu
                strFind1 = "<a href="""
                strFind2 = """>"
                iPos1 = InStr(strUrl, strFind1)
                iPos2 = InStr(iPos1, strUrl, strFind2)
                strUrl2 = "https://ncode.syosetu.com" + Mid(strUrl, iPos1 + Len(strFind1), iPos2 - iPos1 - Len(strFind1))
            ElseIf (InStr(strUrl, "ncode.syosetu.com") > 0) Then
                WebType = WebTypeSyosetu
                strUrl2 = Trim(strUrl)
            Else
                WebType = WebTypeOther
                strFind1 = "http"
                iPos1 = InStr(strUrl, strFind1)
                If (iPos1 <> 0) Then
                    strFind2 = ".html"
                    iPos2 = InStr(iPos1, strUrl, strFind2)
                    If (iPos1 <> 0 And iPos2 <> 0) Then strUrl2 = Mid(strUrl, iPos1 + Len(strFind1), iPos2 - iPos1)
                    If (Len(strUrl2) = 0) Then
                        strFind2 = ".htm"
                        iPos2 = InStr(iPos1, strUrl, strFind2)
                        If (iPos1 <> 0 And iPos2 <> 0) Then strUrl2 = Mid(strUrl, iPos1 + Len(strFind1), iPos2 - iPos1)
                    End If
                    If (Len(strUrl2) = 0) Then
                        strUrl2 = Left(strUrl, Len(strUrl) - iPos1 + 1)
                    End If
                End If
            End If
 
 
            If (Len(strUrl2) <> 0) Then
 
                oBrowser.navigate strUrl2
 
                Do Until oBrowser.Busy = False
                    DoEvents
                Loop
 
 
                Do
                    DoEvents
                Loop Until oBrowser.readyState = READYSTATE_COMPLETE
 
                Set oDocument = oBrowser.Document
            End If
 
 
 
            If (oBrowser.readyState = tagREADYSTATE.READYSTATE_COMPLETE) Then
                If (WebType = WebTypeESJ) Then
 
                    Set oCollection = oDocument.getElementsByTagName("h3")
                    If (oCollection.Length > 0) Then
                        strSubTitle = oCollection.Item(0).innerText
                    Else
                        strSubTitle = ""
                    End If
                    strNovelText = ""
 
                    Set oCollection = oDocument.getElementsByTagName("div")
                    For Each oElement In oCollection
 
                        If ((InStr(oElement.ClassName, "col-xs-12") <> 0) And _
                            (InStr(oElement.ClassName, "m-b-30") <> 0) And _
                            (InStr(oElement.ClassName, "forum-content") <> 0)) Then
                            strNovelText = strNovelText + oElement.innerText
                            'Exit For
                        End If
 
                    Next oElement
 
 
 
                ElseIf (WebType = WebTypeSyosetu) Then
                    Set oCollection = oDocument.getElementsByClassName("chapter_title")
                    If (oCollection.Length > 0) Then
                        strChapterTitle = oCollection.Item(0).innerText
                    Else
                        strChapterTitle = ""
                    End If
 
                    Set oCollection = oDocument.getElementsByClassName("novel_subtitle")
                    If (oCollection.Length > 0) Then
                        strSubTitle = oCollection.Item(0).innerText
                    Else
                        strSubTitle = ""
                    End If
 
                    Set oCollection = oDocument.getElementsByClassName("novel_view")
                    strNovelText = ""
                    For Each oElement In oCollection
                        strNovelText = strNovelText + oElement.innerText + Chr(13)
                    Next oElement
 
 
                ElseIf (WebType = WebTypekakuyomu) Then
                    Set oCollection = oDocument.getElementsByClassName("chapterTitle")
                    If (oCollection.Length > 0) Then
                        strChapterTitle = oCollection.Item(0).innerText
                    Else
                        strChapterTitle = ""
                    End If
 
                    Set oCollection = oDocument.getElementsByClassName("widget-episodeTitle")
                    If (oCollection.Length > 0) Then
                        strSubTitle = oCollection.Item(0).innerText
                    Else
                        strSubTitle = ""
                    End If
 
                    Set oCollection = oDocument.getElementsByClassName("widget-episodeBody")
                    strNovelText = ""
                    For Each oElement In oCollection
                        strNovelText = strNovelText + oElement.innerText + Chr(13)
                    Next oElement
 
                ElseIf (WebType = WebTypeOther) Then
                    strChapterTitle = ""
 
                    Set oCollection = oDocument.getElementsByTagName("title")
                    If (oCollection.Length > 0) Then
                        strSubTitle = oCollection.Item(0).innerText
                    Else
                        strSubTitle = ""
                    End If
 
                    Set oCollection = oDocument.getElementsByTagName("body")
                    If (oCollection.Length > 0) Then
                        strSubTitle = oCollection.Item(0).innerText
                    Else
                        strSubTitle = ""
                    End If
 
                End If
            End If
 
 
            If (Len(strNovelText) <> 0) Then
                ActiveDocument.Paragraphs.Add
                ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range.Select
                Selection.InsertBreak Type:=wdPageBreak
 
                If (WebType = WebTypeSyosetu) Then
                    If (strChapterTitle0 <> strChapterTitle) Then
                        ActiveDocument.Paragraphs.Add
                        ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range.Select
                        Selection.InsertAfter strChapterTitle
                        Selection.Style = ActiveDocument.Styles("標題 1")
                        strChapterTitle0 = strChapterTitle
                    End If
                End If
 
                ActiveDocument.Paragraphs.Add
                ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range.Select
                Selection.InsertAfter strSubTitle
                If (WebType = WebTypeSyosetu) Then
                    Selection.Style = ActiveDocument.Styles("標題 2")
                Else
                    Selection.Style = ActiveDocument.Styles("標題 1")
                End If
 
                ActiveDocument.Paragraphs.Add
                ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range.Select
 
                Selection.InsertAfter strNovelText
                Selection.Style = ActiveDocument.Styles("內文")
 
            End If
 
        End If
    Next strUrl
 
 
 
    Dim sArray(3) As String          '替換對照檔的內容(依各行切割後的字串陣列)
    Dim arrStr() As String          '替換前與替換後的內容(分割後的字串陣列)
    Dim InputStr As Variant         '替換前與替換後的內容(分割前的字串)
 
 
    sArray(0) = "^m^p^p,^m^p"
    sArray(1) = "(adsbygoogle = window.adsbygoogle || []).push({});,"
    sArray(2) = "^p^p^p,^p^p"
 
    For Each InputStr In sArray
        If Len(InputStr) > 0 Then
            arrStr = Split(InputStr, ",")  '把讀入的文字列依逗號分成兩個字串, 置於 arrStr 陣列裡
            If (GetArrayLength(arrStr) = 2) Then
                Call ReplaceText(arrStr(0), arrStr(1))
            End If
        End If
    Next InputStr
    Application.ScreenUpdating = True  '畫面恢復更新
 
 
Err:
    oBrowser.Quit
 
 
End Sub

其他

'避免Word像是當掉, 工作繁重的迴圈裡必須使用
    DoEvents
 
'全選
    Selection.WholeStory
 
'取消選取範圍
    Selection.StartOf
 
'將選取範圍延伸至段落結尾
    Selection.EndOf(Unit:=wdParagraph, Extend:=wdExtend) 
 
'將選取範圍延伸至文件結尾
    Selection.SetRange Start:=Selection.Start, End:=ActiveDocument.Content.End
 
'整段選取
    Selection.HomeKey Unit:=wdParagraph
    Selection.EndKey Unit:=wdParagraph
 
'選取第1個段落
    ActiveDocument.Paragraphs(1).Range.Select 
 
'在文件最後加入空白段落
    ActiveDocument.Paragraphs.Add
 
'插入分頁
    Selection.InsertBreak Type:=wdPageBreak
 
'剪下
    Selection.Cut
 
'複製
    Selection.Copy
 
'貼上
    Selection.Paste
 
'選取範圍之後插入文字
    Selection.InsertAfter Text:="Hello " 
 
'選取範圍的文字上方插入上標文字
    Selection.Range.PhoneticGuide Text:="測試", Alignment:=wdPhoneticGuideAlignmentCenter, Raise:=11, FontSize:=12, FontName:="新細明體"
 
'選取範圍套用粗體
    Selection.Font.Bold = True 
 
'清除字元格式(此方法不會移除使用者手動套用的字元格式)
    Selection.ClearCharacterStyle
 
'清除字元格式
    Selection.ClearCharacterAllFormatting
 
'清除樣式
    Selection.ClearFormatting
 
'套用樣式
    Selection.Style = ActiveDocument.Styles("標題 1")
 
'簡體字轉繁體字
    Selection.Range.TCSCConverter WdTCSCConverterDirection:=wdTCSCConverterDirectionSCTC, CommonTerms:=True, UseVariants:=True
 
'繁體字轉簡體字
    Selection.Range.TCSCConverter WdTCSCConverterDirection:=wdTCSCConverterDirectionTCSC, CommonTerms:=True, UseVariants:=False
 
'更新整個目錄
    ActiveDocument.TablesOfContents(1).Update
 
'只更新目錄的頁碼
    ActiveDocument.TablesOfContents(1).UpdatePageNumbers
 
'檢視切換到整頁模式
    If ActiveWindow.View.SplitSpecial = wdPaneNone Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    Else
        ActiveWindow.View.Type = wdPrintView
    End If
 
'儲存檔案
    ActiveDocument.Save
 
'關閉檔案
    ActiveDocument.Close
 
'畫面暫停更新
    Application.ScreenUpdating = False
 
'畫面恢復更新
    Application.ScreenUpdating = True

相關

• VBA
• .doc
• .docx