Excel中如何使用VBA搜索word文档中是否存在图片-CFANZ编程社区

我们有时候会遇到有非常多的Word文档，有的包含图片、有的没有。在此时如果你想查找哪些文档包含图片？你会怎么做，一个一个文档去打开，去看文档中是否有图片吗？这种方法对于大批量文件，显然是非常不合适的。所以我们想到使用Excel VBA代码能否取去实现这个小的功能。

首先附上我们已经写好的VBA代码：

PS：此代码可以直接粘贴过去使用即可.

Private Type EOCD
EOCDSignature As Long
NumberOfThisDisk As Integer
DiskDirectoryStarts As Integer
NumberOfCDRecordsOnThisDisk As Integer
TotalNumberOfCDRecords As Integer
SizeOfCD As Long
OffsetOfCD As Long
CommentLength As Integer
End Type
Private Type CDFheader
CDFHeaderSignature As Long
PlaceHolder(0 To 23) As Byte
FileNameLength As Integer
ExtraFieldLength As Integer
FileCommentLength As Integer
PlaceHolder1(0 To 11) As Byte
End Type
Dim wdApp
Sub CheckDoc()
Dim iRow As Integer
Dim item
iRow = 2
Sheet1.Columns(1).ClearContents
Sheet1.Columns(2).ClearContents
Sheet1.Cells(1, 1) = "文件名"
Sheet1.Cells(1, 2) = "有图/无图"
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
.Filters.Clear
.Filters.Add "Word文档(*.doc; *.docx; *.docm)", "*.doc;*.docx;*.docm"
.Show
For Each item In .SelectedItems
Sheet1.Cells(iRow, 1) = item
Sheet1.Cells(iRow, 2) = IIf(HasPicture(CStr(item)), "有图", "无图")
iRow = iRow + 1
Next
End With
If Not IsEmpty(wdApp) Then
If Not wdApp Is Nothing Then
wdApp.Quit
Set wdApp = Nothing
End If
End If
End Sub
Function HasPicture(sDocFile As String) As Boolean
Dim sExt As String
Dim wdDoc
Dim shp
Dim iFreefile As Integer
Dim bytBuffer() As Byte
Dim i As Integer
Dim lOffsetEOCD As Long
Dim lLOF As Long
Dim oEOCD As EOCD
Dim oCDFH As CDFheader
Dim lOffset As Long
Dim sOutput As String
sExt = Mid(sDocFile, InStrRev(sDocFile, ".") + 1)

'对于word 2003及更低版本的文档（*.doc后缀），用word程序打开后遍历所有的shapes和inlineshapes，判断是否为图片

'如果用二进制打开分析复合文档，速度会更快，且不要求电脑上安装word程序，但这种方法本人还没掌握，有兴趣可以上EH论坛找liucqa研究

If LCase(sExt) = "doc" Then
If IsEmpty(wdApp) Then
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = False
ElseIf wdApp Is Nothing Then
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = False
End If
Set wdDoc = wdApp.documents.Open(sDocFile, , , False) '用word程序打开，但不记录到word最近文件列表中
For Each shp In wdDoc.InlineShapes
If shp.Type = Office.msoPicture Then
HasPicture = True
wdDoc.Close
Exit Function
End If
Next
For Each shp In wdDoc.Shapes
If shp.Type = Office.msoPicture Then
HasPicture = True
wdDoc.Close
Exit Function
End If
Next

'word 2007及更高版本的文档（后缀为docx或docm)相当于一个zip文件，可用二进制打开读取里面的压缩文件列表

'如果文档里有图片，会放在word/media/下，文件名从image1开始到imageN

ElseIf LCase(sExt) = "docx" Or LCase(sExt) = "docm" Then
iFreefile = FreeFile
ReDim bytBuffer(255) As Byte
Open sDocFile For Binary As iFreefile
lLOF = LOF(iFreefile)
Get iFreefile, lLOF - 256, bytBuffer
For i = 0 To 252
If bytBuffer(i) = &H50 And bytBuffer(i + 1) = &H4B And bytBuffer(i + 2) = &H5 And bytBuffer(i + 3) = &H6 Then
lOffsetEOCD = lLOF - 256 + i
Exit For
End If
Next
If lOffsetEOCD = 0 Then
Err.Raise 1, , "zip文件格式可能有误，请检查"
Exit Function
End If
Get iFreefile, lOffsetEOCD, oEOCD
lOffset = oEOCD.OffsetOfCD + 1
For i = 0 To oEOCD.TotalNumberOfCDRecords - 1
Get iFreefile, lOffset, oCDFH
ReDim bytBuffer(0 To oCDFH.FileNameLength - 1) As Byte
Get iFreefile, lOffset + Len(oCDFH), bytBuffer
sOutput = StrConv(bytBuffer, vbUnicode)
If Left(sOutput, 16) = "word/media/image" Then
HasPicture = True
Exit For
End If
lOffset = lOffset + Len(oCDFH) + oCDFH.FileCommentLength + oCDFH.FileNameLength + oCDFH.ExtraFieldLength
Next
Close iFreefile
End If
End Function