|
Sub smiletwo()
Dim Excel_Shape As Shape, MyFile, path
Dim i%, m%
Dim Word, Myword As Object
On Error Resume Next
path = ThisWorkbook.path & "\"
MyFile = Dir(path & "*.doc*")
Set Word = CreateObject("word.application")
Do While MyFile <> ""
Set Myword = Word.Documents.Open(path & MyFile)
Word.Visible = flase
Application.DisplayAlerts = False
m = 0
If Myword.Shapes.Count > 0 Then
For i = 1 To Myword.Shapes.Count
Myword.Shapes(i).Select
Word.Selection.Copy
ActiveSheet.Cells(i, 1).Activate
ActiveSheet.PasteSpecial Format:="图片(增强型图元文件)", Link:=False, DisplayAsIcon:=False
Set Excel_Shape = ActiveSheet.Shapes(1)
Excel_Shape.Copy
With ActiveSheet.ChartObjects.Add(0, 0, Excel_Shape.Width, Excel_Shape.Height).Chart
.Paste
m = m + 1
.Export path & "pic" & Split(MyFile, ".")(0) & Format(m, "000") & "A.jpg"
.Parent.Delete
End With
Excel_Shape.Delete
Next i
End If
If Myword.InlineShapes.Count > 0 Then
For i = 1 To Myword.InlineShapes.Count
Myword.InlineShapes(i).Select
Word.Selection.Copy
ActiveSheet.Cells(i, 1).Activate
ActiveSheet.PasteSpecial Format:="图片(增强型图元文件)", Link:=False, DisplayAsIcon:=False
Set Excel_Shape = ActiveSheet.Shapes(1)
Excel_Shape.Copy
With ActiveSheet.ChartObjects.Add(0, 0, Excel_Shape.Width, Excel_Shape.Height).Chart
.Paste
m = m + 1
.Export path & "pic\" & Split(MyFile, ".")(0) & Format(m, "000") & "A.png"
.Parent.Delete
End With
Excel_Shape.Delete
Next i
End If
Myword.Close
MyFile = Dir
Loop
Set Myword = Nothing
Word.Quit
Set Word = Nothing
End Sub
|
|