word vba 宏批量提取全部附件 到指定文件夾

#If VBA7 Then
'For 64-Bit MS Office
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)
#Else
'For 32-Bit MS Office
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As Long)
#End If


Sub 導(dǎo)出內(nèi)嵌文件()
    ' 導(dǎo)出的文件夾
    Dim 導(dǎo)出的文件夾 As String
    導(dǎo)出的文件夾 = "C:\Users\accou\Downloads\"
    Set 文檔 = ActiveDocument
    
    For Each 嵌入對象 In 文檔.InlineShapes
    
        Debug.Print "類型" & 嵌入對象.Type
    
        If 嵌入對象.Type = wdInlineShapeEmbeddedOLEObject Then
        
            類型 = 嵌入對象.OLEFormat.ClassType
            Debug.Print "輸出 " & 類型
            
            If InStr(1, 類型, "Excel") > 0 Then
            
                嵌入對象.Select
                
                完整路徑 = 導(dǎo)出的文件夾 & Rnd & "需求一覽表.xlsx"
                
                
                嵌入對象.OLEFormat.Open
                Sleep (3000)
                
                Set Excel對象 = GetObject(, "Excel.Application")
    
                Excel對象.Workbooks(1).SaveAs 完整路徑, 51
                Excel對象.Workbooks(1).Close savechanges:=False
                
                Sleep (1000)
                
            End If
            
        End If
    

    Next
End Sub