|
楼主 |
发表于 2018-2-14 00:45
|
显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
走个弯路,自己搞掂:
- Sub TableToPic()
- Dim Myapp As Object
- Dim Myappwork, i, j, k, m, n, nm, shp, myFolder
- On Error Resume Next
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- myFolder = ThisDocument.Path & "\WPic"
- If Len(Dir(myFolder, vbDirectory)) = 0 Then
- MkDir myFolder
- End If
- Set Myapp = CreateObject("Excel.Application")
- Set Myappwork = Myapp.Workbooks.Add
- Myappwork.Sheets(1).Name = "Temp"
- For i = 1 To ActiveDocument.Tables.Count
- ActiveDocument.Tables(i).Select
- Selection.Copy
- Myappwork.Sheets("Temp").Pictures.Paste
- For Each shp In Myappwork.Sheets("Temp").Shapes
- n = n + 1
- shp.CopyPicture
- Myappwork.Sheets("Temp").Range("A1").Select
- With Myappwork.Sheets("Temp").ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart
- .Paste
- .Export myFolder & "WordTable-" & n & ".jpg", "JPG"
- .Parent.Delete
- End With
- shp.Delete
- Next
- Next
- 'Myapp.Visible = True
- Myappwork.Close False
- Myapp.Quit
- MsgBox ("已保存到图片文件夹下")
- Set mMyapp = Nothing
- Set Myappwork = Nothing
- Application.DisplayAlerts = True
- Application.ScreenUpdating = True
- End Sub
复制代码 |
|