取得 PPT 投影片中的所有文字

PowerPoint中似乎沒有方便的工具可以取出投影片上所有的文字,搜尋之後, 找到了高手的 VBA 程式, 簡單修改加上存成文字檔的功能後, 就可以使用了。完整程式碼如下：

Sub 取出文字()
    Dim p As Presentation: Set p = ActivePresentation
    Dim s As Slide
    Dim sh As Shape
    
    FName = ActivePresentation.FullName 'Word檔名
    txtFname = Left(FName, Len(FName) - 4) & "_shapes.txt" 'txt檔名

    Set objStream = CreateObject("ADODB.Stream")
    objStream.Open
    objStream.Position = 0
    objStream.Charset = "UTF-8"
    
    For Each s In p.Slides
        For Each sh In s.Shapes
            If sh.HasTextFrame Then
                If sh.TextFrame.HasText Then
                    objStream.WriteText sh.TextFrame.TextRange.Text
                End If
            End If
        Next
    Next
    objStream.SaveToFile txtFname, 2
    objStream.Close
End Sub

它會把所有投影片中的文字取出後, 存在與 PPT 檔相同資料夾下,與 PPT 檔同名的 .TXT 文字檔中。

Excel VBA中Sort物件的SortMethod屬性值xlPinYin與xlStroke意義顛倒了？

今天在校對一本書時，發現Excel VBA中Sort物件的SortMethod屬性值xlPinYin與xlStroke意義似乎顛倒了？請看下圖，先以xlStroke為SortMethod屬性的值排序，結果筆畫多的「台北」排在「台中」之前：



再來以xlPinYin為屬性值排序，結果「台中（ㄓ）」排在「台北（ㄅ）」之前：



如果此時點選「資料」頁次的「排序」，在「排序」交談窗按下「選項」，會看到是「依筆畫排序」，而實際上排序結果的確是依據筆畫順序：



若回頭去看之前用xlStroke為屬性值排序的結果，顯然是依據注音符號排序，所以似乎這兩個常數在VBA中弄反了。

再進一步印證，如果用錄製巨集的方式，採用注音方式排序，錄製下來的巨集如下圖：



可以看到實際採用的是xlStroke常數，這樣看來，我的猜測應該是正確的。


PS：這目前在2007與2010中都測試過，都是同樣的結果。在網路上搜尋的結果，似乎在Office XP中的Excel 2002就會出現錄製結果常數值相反的問題，不過已經在Office SP3修正了。不曉得現在這個問題以後是否會修正？

依照日期排列WORD追蹤修訂資訊

我的工作常常需要用到WORD的追蹤修訂功能，追蹤修訂功能雖然可以標示出修改日期與時間，但是卻沒有依照日期排列追蹤修訂資訊的功能，上網找了半天，似乎也沒有適當的解法，不過找到了一個可以擷取追蹤修訂資訊，整理在一份新的WORD文件上的VBA程式。它會建立一份新文件，並且以表格的方式擷取出增刪的修訂資訊，這樣一來，我就可以貼到EXCEL上，依據日期欄位排序，得到我需要的資料了。

取出WORD文件中所有文字框的文字

我的工作因為要整理作者提供的稿件，因此一直有個需求就是把WORD文件中所有文字框（有加上文字的快取圖形、水平或是垂直的文字框）中的文字取出來，這樣我就不需要一個一個文字框作Copy貼的動作，今天剛好找到了一個合用的範例如下：

Dim sh As Shape
Dim txt As String
For Each sh In ActiveDocument.Shapes
   If sh.TextFrame.HasText Then
   txt = sh.TextFrame.TextRange.Text
   MsgBox (txt)
   End If
Next sh

只要把MsgBox那行換成你需要的動作，就可以將取出的文字再利用了，我自己是把所有文字匯集到一個跟WORD文件同名，但加上 "_shape" 字尾的文字檔：

Sub 匯出文字框的文字()
'
fname = ActiveDocument.FullName 'Word檔名
txtFname = Left(fname, Len(fname) - 4) & _
    "_shapes.txt" 'txt檔名
Set fs = CreateObject("Scripting.FileSystemObject")
Set txtfile = fs.CreateTextFile(txtFname, True) '建立文字檔

Dim sh As Shape
Dim txt As String

For Each sh In ActiveDocument.Shapes
   If sh.TextFrame.HasText Then
   txt = sh.TextFrame.TextRange.Text
   txtfile.writeline txt
End If
Next sh
txtfile.Close
End Sub

延伸閱讀：

• Select a SINGLE Shape using VBA