Oscar Sun

                  Sub 開新視窗到臉書直播()
Dim heading  As Paragraph, a, docName As String, s As Integer, docOpened As Boolean
Dim d主控文件 As Document
s = InStr(ActiveDocument.Name, "_子文件")
docName = Mid(ActiveDocument.Name, 1, s - 1) '取得主控文件的檔名
If s Then
    For Each a In Documents
        If a.Name = docName Then '主控文件有開啟
            docOpened = True
            Exit For
        End If
    Next a
    If Not docOpened Then Set d主控文件 = Documents.Open(ActiveDocument.Path & "\" & docName & ".docm")
    With Documents(docName)
        .Activate
        If docOpened Then .Windows.Add
    End With
Else
    Windows.Add
End If

For Each heading In ActiveWindow.Document.Paragraphs
    If heading.Style = "標題 4" And heading.Range = "臉書直播" & Chr(13) Then
        heading.Next.Range.Select
        Selection.Collapse wdCollapseStart
        For Each a In heading.Next.Range.Characters
            If a = Chr(9) Then
                If a.Next.Hyperlinks.Count = 0 Then
                    a.Next.Select '開始選取
                    If Selection.MoveEndUntil(Chr(9), 6) <> 0 Then
                        If VBA.Left(系統處理.GetClipboard(), 43) = "https://www.facebook.com/oscarsun72/videos/" Then _
                            Selection.Hyperlinks.Add Selection.Range, 系統處理.GetClipboard
                            d主控文件.Subdocuments.Expanded = True
                            d主控文件.SaveAs2 d主控文件.FullName
                        Exit Sub
                    End If
                End If
            End If
        Next a
        Exit For
    End If
Next
End Sub