Oscar Sun

                    Option Explicit

Sub 第集前後時間軸()'https://youtu.be/bOEaor57ajw 20190902
Const sTxt As String = "第39集"
Dim p As Paragraph, s1 As Long, end1 As Long
Dim rng第集 As Range, d As Document, ActiveD As Document
'set rng=ActiveDocument.Range.Find.Execute("^#",)
Set rng第集 = Selection.Range
Set ActiveD = ActiveDocument
Set d = Documents.Add()
For Each p In ActiveD.Paragraphs
    s1 = InStr(p.Range, sTxt)
    If s1 > 0 And p.Range.End > end1 Then
        If Not p.Range.Style Like "標題*" And InStr(p.Previous.Range.Text, "臉書直播") = 0 Then
            rng第集.SetRange p.Previous.Previous.Previous.Previous.Previous.Previous.Range.Start, p.Next.Next.Next.Next.Next.Next.Range.End
            d.Range.Text = d.Range.Text & Chr(13) & rng第集.Text
            end1 = p.Next.Next.Range.End
        End If
    End If
Next p
End Sub

                  

                    Sub 將inlineshape中的替代文字擷出至次欄()
Dim c As Cell
For Each c In ActiveDocument.Tables(1).Columns(1).Cells
    If c.Range.InlineShapes.Count > 0 Then
        c.Next.Range.Text = c.Range.InlineShapes(1).AlternativeText
    Else
        c.Next.Range.Text = c.Range.Text
    End If
Next c
End Sub

                  

                    Sub 只留下5031常用字_未選取則以paragraph為單位()
'Selection.Style = "標題 1"
'If Selection.Type <> wdSelectionIP Then Selection.Collapse wdCollapseEnd
'Selection.Move wdStory
'Selection.InsertParagraphAfter
'Selection.Move wdStory
'Selection.PasteSpecial DataType:=wdPasteText

Dim rng As Range, cnt As New ADODB.Connection, rst As New ADODB.Recordset, a
Static dbf As String
If Selection.Type = wdSelectionIP Then
    Set rng = Selection.Paragraphs(1).Range
Else
    Set rng = Selection.Range
End If
If dbf = "" Then dbf = system.dbFile("@@諧聲字檢索系統（唯一）20170518.mdb", "") ' "E:\@@@華語文工具及資料@@@\@@諧聲字檢索系統（唯一）20170518.mdb
cnt.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbf
If rng.Characters.Count > 1 Then
    Application.ScreenUpdating = False
    For Each a In rng.Characters
        If Not a Like "[" & Chr(13) & Chr(10) & Chr(8) & Chr(7) & Chr(9) & "]" Then
            rst.Open "select 漢字 from 5031常用字 where strcomp(漢字,""" & a & """)=0", cnt, adOpenKeyset
            If rst.RecordCount = 0 Then
                a.Delete
            End If
            rst.Close
        End If
    Next a
    Application.ScreenUpdating = True
    
'    If rng.Characters.Count > 1 Then
'        rng.Select
'        If d Is Nothing Then Set d = rng.Document
'        Str.字集筆畫排序
'        Selection.Collapse wdCollapseStart
'        Selection.MoveUp
'        Selection.Delete
'        If rng.Document.path <> "" Then rng.Document.Save
'    End If
End If
End Sub

                  

                    Sub selectShpae()
Dim sld As Slide
Dim sp As Shape
Dim dw As DocumentWindow
Dim sw As SlideShowWindow
'On Error GoTo eH
For Each sld In ActivePresentation.Slides
    For Each sp In sld.Shapes
'        Select Case sp.Type
'            Case 1, 17
'            Case Else
'                Stop
'        End Select
        If sp.Type = msoPicture Then 'https://docs.microsoft.com/zh-tw/office/vba/api/office.msoshapetype
            sld.Select
            sp.Select
            Stop
        End If
    Next sp
Next sld
Exit Sub
eH:
Select Case Err.Number
    Case 4198
        sld.Select
        Resume Next
    Case Else
        MsgBox Err.Number & Err.Description
End Select
End Sub


                  

                    Function 漢字轉注音(x As String)
Dim rst As New ADODB.Recordset, cnt As New ADODB.Connection
cnt.Open "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=E:\@@@華語文工具及資料@@@\Macros\chinesewords.mdb"
rst.Open "select 字,注音 from words where strcomp(字,""" & x & """)=0", cnt, adOpenKeyset
If rst.RecordCount > 0 Then
    漢字轉注音 = rst.Fields("注音").Value
Else
    漢字轉注音 = Null
End If
rst.Close: cnt.Close
End Function


Function 漢字轉拼音(x As String)
Dim rst As New ADODB.Recordset, cnt As New ADODB.Connection
cnt.Open "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=E:\@@@華語文工具及資料@@@\Macros\chinesewordsVBA.mdb"
rst.Open "select F2,F3 from superpy where strcomp(F2,""" & x & """)=0", cnt, adOpenKeyset
If rst.RecordCount > 0 Then
    If rst.RecordCount > 1 Then
        Do Until InStr(rst.Fields("F3").Value, "◆") > 0
            rst.MoveNext
            If rst.EOF Then
                rst.MoveFirst
                Exit Do
            End If
        Loop
        漢字轉拼音 = rst.Fields("F3").Value
    Else
        漢字轉拼音 = rst.Fields("F3").Value
    End If
Else
    漢字轉拼音 = Null
End If
rst.Close: cnt.Close
End Function