vba - 如何从Word中提取嵌入的文件
问题描述
我编写了一个 Word 宏 (VBA),它从 Word 文档(docx 或 docm,而不是 doc)中提取以下(Ole)嵌入文件:
- 文档,文档,文档
- xls、xlsx、xlsm(xlsb 被复制但不工作)
- ppt, pptx
- 文本
- 可执行程序
- 压缩包,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, 1) = "\", Left(Tmp, Len(Tmp) - 1), 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, 1) = "\", Left(Tmp, Len(Tmp) - 1), Tmp)).CopyHere sh.Namespace(Tmp & ActiveDocument.Name & ".zip").items
Call ExtractFilesFromUnZip(Word, Tmp, Home)
If FSO.FolderExists(IIf(Right(Tmp, 1) = "\", Left(Tmp, Len(Tmp) - 1), Tmp)) Then FSO.DeleteFolder IIf(Right(Tmp, 1) = "\", Left(Tmp, Len(Tmp) - 1), Tmp)
Set FSO = Nothing
Set sh = Nothing
MsgBox "Files written to:" & vbCr & vbCr & Home, 64
End Sub
Sub ExtractFilesFromUnZip(Word, Tmp, 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, 0, 0, 0, 0, 0, Target & OrgN, 0, 0)
Case "htm"
Call ExtractFile(-33, 60, 33, 256, 256, Word & OleHN, 256, 256, 0, 0, 0, 256, Target & OrgN, 1, -1)
Case "wav"
Call ExtractFile(0, 82, 73, 70, 70, Word & OleHN, 93, 0, 0, 0, 256, 0, Target & OrgN, 1, -2)
Case "txt"
Call ExtractFile(116, 0, 256, 256, 0, Word & OleHN, 10, 256, 0, 0, 0, 256, Target & OrgN, 6, -6)
Case "rar"
Call ExtractFile(82, 97, 114, 33, 26, Word & OleHN, 92, 0, 0, 0, 256, 0, Target & OrgN, 0, -1)
Case "exe"
Call ExtractFile(77, 90, 144, 0, 3, Word & OleHN, 97, 0, 0, 0, 256, 0, Target & OrgN, 0, -1)
Case "zip"
Call ExtractFile(80, 75, 3, 4, 256, Word & OleHN, 0, 0, 256, 40, 0, 0, Target & OrgN, 0, 7)
Case "mp4"
Call ExtractFile(0, 32, 102, 116, 121, Word & OleHN, 85, 0, 0, 0, 67, 0, Target & OrgN, -2, 1)
Case "avi"
Call ExtractFile(0, 82, 73, 70, 70, Word & OleHN, 0, 85, 0, 0, 0, 67, Target & OrgN, 1, -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, ridOle, ridShape, OleHN, 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, j, 1)) > 32 Then Exit For
Next
OrgN = Mid$(OrgN, 1, j)
For j = 1 To Len(OrgN)
If Asc(Mid$(OrgN, j, 1)) > 32 Then Exit For
Next
TrimStr = Mid$(OrgN, j, Len(OrgN) - j + 1)
End Function
Sub CopyWithDateTime(Source, Target, 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
解决方案
推荐阅读
- javascript - 使用变量在组件中设置样式背景图像
- arrays - Python:附加一个列表,其中包含在函数中评估为真的元素
- javascript - 使用 JavaScript 从每个元素中删除隐藏类
- flutter - 如何在 Flutter 中设置默认选中的单选按钮?
- java - 使用自定义 JDBC 驱动程序与使用 HTTP 通信的 Zuul-Eureka Spring-Boot 应用程序一起工作时出现问题
- powershell - PowerShell脚本使用数组检查文件/文件夹是否存在
- sql - 查找低于子集 min() 的集合的所有值
- database - 数据建模 Microsoft Office
- rest - Meteor simple:rest 包不认天文包方法
- c# - 无法将带有 [] 的索引应用于“int”类型的表达式