如何从 Word 中提取嵌入的文件

如何解决如何从 Word 中提取嵌入的文件

我编写了一个 Word 宏 (VBA)，它从 Word 文档（docx 或 docm，而不是 doc）中提取以下 (Ole) 嵌入文件：

• 文档、文档、文档
• xls、xlsx、xlsm（xlsb 已复制但无效）
• ppt、pptx
• pdf
• txt
• exe
• 压缩包，rar
• mp3、wav
• mp4、avi
• html

如果您有任何建议，请告诉我。

您可以将此宏复制到 Word 模块中，例如“正常”并在菜单栏中创建一个链接。

Option Explicit
Sub ExtractFilesFromWord()
    Dim Home,Tmp,Word As String
    Dim sh,FSO As Object
    
    Home = ActiveDocument.Path & "\"
    If Home = "" Then
        MsgBox "No document open. Do nothing."
        Exit Sub
    ElseIf LCase$(Mid$(ActiveDocument.Name,Len(ActiveDocument.Name) - 3,3)) <> "doc" Then
        MsgBox "Not a docx or a docm. Do nothing."
        Exit Sub
    End If
    Tmp = Home & "tmp-" & Format(Date,"YY-MM-DD") & "\"
    Word = Tmp & "word\"
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(IIf(Right(Tmp,1) = "\",Left(Tmp,Len(Tmp) - 1),Tmp)) Then FSO.DeleteFolder IIf(Right(Tmp,Tmp)
    MkDir Tmp
    
    If Len(Dir(Tmp & ActiveDocument.Name & ".zip")) > 0 Then Kill Tmp & ActiveDocument.Name & ".zip"
    WordBasic.copyFileA FileName:=ActiveDocument.FullName,Directory:=Tmp & ActiveDocument.Name & ".zip"
    Set sh = CreateObject("Shell.Application")
    sh.Namespace(IIf(Right(Tmp,Tmp)).copyHere sh.Namespace(Tmp & ActiveDocument.Name & ".zip").items
    Call ExtractFilesFromUnZip(Word,Home)
    If FSO.FolderExists(IIf(Right(Tmp,Tmp)
    
    Set FSO = nothing
    Set sh = nothing
    
    MsgBox "Files written to:" & vbCr & vbCr & Home,64

End Sub
Sub ExtractFilesFromUnZip(Word,Target)
    Dim XDoc,Node,Node1,Node2 As Object
    Dim OleHN,ShapeHN,OrgN As String
    Dim ridOle,ridShape As String

    Set XDoc = CreateObject("Microsoft.XMLDOM")
    XDoc.async = False
    XDoc.validateOnParse = False
    XDoc.Load (Word & "document.xml")
    For Each Node In XDoc.getElementsByTagName("*/w:object")
        OrgN = ""
        ridOle = ""
        ridShape = ""
        For Each Node1 In Node.ChildNodes
            If LCase(Node1.BaseName) = "oleobject" Then
                ridOle = Node1.Attributes.getNamedItem("r:id").Text
            ElseIf LCase(Node1.BaseName) = "shape" Then
                Set Node2 = Node1.SelectSingleNode("v:imagedata")
                If Not (Node2 Is nothing) Then ridShape = Node2.Attributes.getNamedItem("r:id").Text
            End If
            If ridOle <> "" And ridShape <> "" Then
                Call ParseRels(Word,ridOle,ridShape,OleHN,ShapeHN)
                If ShapeHN <> "" Then
                    Call GetNameFromIcon(Word & ShapeHN,OrgN)
                    Select Case LCase$(Mid$("???" & OrgN,IIf(InStrRev(OrgN,".") < 1,1,InStrRev(OrgN,".") + 4),3))
                    Case "pdf"
                        Call ExtractFile(37,80,68,70,45,Word & OleHN,999,Target & OrgN,0)
                    Case "htm"
                        Call ExtractFile(-33,60,33,256,-1)
                    Case "wav"
                        Call ExtractFile(0,82,73,93,-2)
                    Case "txt"
                        Call ExtractFile(116,10,6,-6)
                    Case "rar"
                        Call ExtractFile(82,97,114,26,92,-1)
                    Case "exe"
                        Call ExtractFile(77,90,144,3,-1)
                    Case "zip"
                        Call ExtractFile(80,75,4,40,7)
                    Case "mp4"
                        Call ExtractFile(0,32,102,116,121,85,67,-2,1)
                    Case "avi"
                        Call ExtractFile(0,-1)
                    Case "???"
                    Case Else
                        Call copyWithDateTime(Word & OleHN,Target,OrgN)
                    End Select
                End If
                Exit For
            End If
        Next Node1
    Next Node
    Set XDoc = nothing
    Set Node = nothing
    Set Node1 = nothing
    Set Node2 = nothing

End Sub
Sub ExtractFile(ByVal A0,ByVal A1,ByVal A2,ByVal A3,ByVal A4,ByVal OleFN,ByVal Z0,ByVal Z1,ByVal Z2,ByVal Z3,ByVal Z4,ByVal Z5,ByVal TextFN,ByVal offset,ByVal length)
    Dim i,j,nFile As Long
    Dim L() As Byte
    Dim B() As Byte
    
    If Not FileOpen(OleFN,B) Then Exit Sub
    For i = 0 To UBound(B) - 64
        If IIf(A0 < 0,B(i) < A0 * -1,B(i) = A0) And IIf(A1 = 256,B(i + 1) > 0,B(i + 1) = A1) And IIf(A2 = 256,B(i + 2) > 0,B(i + 2) = A2) And IIf(A3 = 256,B(i + 3) > 0,B(i + 3) = A3) And IIf(A4 = 256,B(i + 4) > 0,B(i + 4) = A4) Then Exit For
    Next
    If Z0 < 257 Then
        For j = UBound(B) - 16 To i - 64 Step -1
            If IIf(Z0 = 256,B(j) > 0,B(j) = Z0) And IIf(Z1 = 256,B(j + 1) > 0,B(j + 1) = Z1) And IIf(Z2 = 256,B(j + 2) > 0,B(j + 2) = Z2) And B(j + 3) = Z3 And IIf(Z4 = 256,B(j + 4) > 0,B(j + 4) = Z4) And IIf(Z5 = 256,B(j + 5) > 0,B(j + 5) = Z5) Then Exit For
        Next
    Else
        j = UBound(B)
    End If
    ReDim L(0 To j - i + length)
    For j = 0 To IIf(UBound(L) + i + offset > UBound(B),UBound(L) + i - length,UBound(L))
        L(j) = B(i + j + offset)
    Next
    nFile = FreeFile
    Open TextFN For Binary Access Write As nFile
    Put nFile,L
    Close nFile
    
End Sub
Sub ParseRels(Word,ShapeHN)
    Dim RDoc,RNode As Object
    
    OleHN = ""
    ShapeHN = ""
    Set RDoc = CreateObject("Microsoft.XMLDOM")
    RDoc.async = False
    RDoc.validateOnParse = False
    RDoc.Load (Word & "_rels\document.xml.rels")
    For Each RNode In RDoc.getElementsByTagName("*/Relationship")
        Select Case RNode.Attributes.getNamedItem("Id").Text
        Case ridOle
            OleHN = Replace(RNode.Attributes.getNamedItem("Target").Text,"/","\")
        Case ridShape
            ShapeHN = Replace(RNode.Attributes.getNamedItem("Target").Text,"\")
        End Select
    Next
    Set RDoc = nothing
    Set RNode = nothing
    
End Sub
Sub GetNameFromIcon(ByVal ShapeFN,OrgN)
    Dim Fstart,Fstopp As Long
    Dim S As String
    Dim B() As Byte
    
    If Dir(ShapeFN) = vbNullString Then Exit Sub
    If Not FileOpen(ShapeFN,B) Then Exit Sub
    S = B
    If InStrRev(S,"IconOnly") > 0 Then
        Fstopp = InStrRev(S,Chr(0) & Chr(70) & Chr(0) & Chr(16) & Chr(0) & Chr(2) & Chr(0)) - 1
    Else
        Fstopp = InStrRev(S,Chr(9) & Chr(0) & Chr(9) & Chr(0)) - 1
    End If
    Fstart = InStrRev(S,Chr(0),Fstopp - 1)
    OrgN = Trimstr(Mid$(S,Fstart,Fstopp - Fstart + 1))
    
End Sub
Function FileOpen(FN,B() As Byte) As Boolean
    Dim nFile As Integer
    
    FileOpen = False
    nFile = FreeFile
    Open FN For Binary Access Read As nFile
    If LOF(nFile) > 0 Then
        ReDim B(LOF(nFile) - 1)
        Get nFile,B
        FileOpen = True
    End If
    Close nFile
    
End Function
Function Trimstr(OrgN)
    Dim j,j0 As Long
    
    For j = Len(OrgN) To 1 Step -1
        If Asc(Mid$(OrgN,1)) > 32 Then Exit For
    Next
    OrgN = Mid$(OrgN,j)
    For j = 1 To Len(OrgN)
        If Asc(Mid$(OrgN,1)) > 32 Then Exit For
    Next
    Trimstr = Mid$(OrgN,Len(OrgN) - j + 1)
    
End Function
Sub copyWithDateTime(Source,Name)
    Dim oFile,FSO As Object
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Call FSO.copyFile(Source,Target & Name,True)
    Set oFile = CreateObject("Shell.Application").Namespace(Target).ParseName(Name)
    oFile.ModifyDate = FormatDateTime(Date,2) & " " & FormatDateTime(Time,3)
    Set oFile = nothing
    Set FSO = nothing
    
End Sub