文档中表格批量转化为图片

过客fppt · 发表于 2023-8-25 15:49

本帖最后由过客fppt 于 2023-8-25 17:53 编辑

各位老师，我又来了，因为表格上传到系统之后会直接消失，所以我还需要将表格也批量转化为图片，我目前完成的代码如下，遇到的问题有：
1、有些表格能居中，但是有些不能居中，代码会报错
2、生成图片之后，两边的区域不对称，导致对图片进行裁剪之后不准确

希望各位老师指点一下，先谢谢各位了

Sub 全部表格转化为图片()
Dim CropWidth As Double
Dim myDoc, tempDoc As Document
Dim tbl As Table
Dim yuanRange As Range
Dim l As Long
Dim isNO1 As Boolean
Dim i As Integer
Set myDoc = ActiveDocument
isNO1 = True
For Each tbl In myDoc.Tables
tbl.Select
l = Selection.Range.Start
'选中内容之后
Set yuanRange = Selection.Range
If isNO1 Then
Set tempDoc = Documents.Add()
isNO1 = False
End If
'将选中的内容到临时文档
tempDoc.Content.FormattedText = yuanRange
With Selection
.WholeStory ' 选中全部
.Range.Rows.Alignment = wdAlignRowCenter
.ParagraphFormat.Alignment = wdAlignParagraphCenter
'获取裁剪宽度CropWidth
CropWidth = tempDoc.Content.Information(wdHorizontalPositionRelativeToTextBoundary)
tempDoc.Tables(1).Select
.Copy
.EndKey Unit:=wdStory, Extend:=wdMove '到文档末端
.PasteSpecial DataType:=wdPasteMetafilePicture
End With
If CropWidth > 0 Then
tempDoc.InlineShapes(1).PictureFormat.CropRight = CropWidth
tempDoc.InlineShapes(1).PictureFormat.CropLeft = CropWidth
End If
tbl.Delete
myDoc.Range(l, l).FormattedText = tempDoc.InlineShapes(1).Range.FormattedText
i = i + 1
Next
Set myDoc = Nothing
Set tempDoc = Nothing
MsgBox "已完成" & i & "个表格转化为图片！"
End Sub

复制代码

过客fppt · 发表于 2023-8-25 16:40

本帖最后由过客fppt 于 2023-8-25 16:48 编辑

备注：在WPS中，有些表格无法居中操作；在Word中，会提示此位置无表格

zhanglei1371 · 发表于 2023-8-26 13:16

过客fppt 发表于 2023-8-25 16:40
备注：在WPS中，有些表格无法居中操作；在Word中，会提示此位置无表格

Sub fdf()
Dim ta As Table
For Each ta In ActiveDocument.Range.Tables
ta.Range.Select
Shell "C:\ZLPicCrop.exe", vbHide
t = Timer
Do While Timer - t < 1
DoEvents
Loop
Next
MsgBox "已完成！"
End Sub

复制代码

宽度调整未加入

表格转化为图片0.7z (135.27 KB, 下载次数: 22)

ZLPicCrop.rar (213.49 KB, 下载次数: 25)

过客fppt · 发表于 2023-8-26 13:46

zhanglei1371 发表于 2023-8-26 13:16
宽度调整未加入

感谢 zhanglei1371 老师的帮助，但是在Word和WPS中运行都会弹出调用异常的弹窗，会不会是Win10系统的原因

zhanglei1371 · 发表于 2023-8-26 14:39

这个需要有C盘写入的权限。若系统权限太高，不让写入C盘就会失败。
手动单步运行若还是失败就没办法了。
可以试试下面这个：拖动带有透明边的png图片上去，看看是否会自动裁掉透明区域：

A.rar (30.97 KB, 下载次数: 18)
若这个都无法运行，或出错，那就看其他高手的了。

过客fppt · 发表于 2023-8-26 16:03

zhanglei1371 发表于 2023-8-26 14:39
这个需要有C盘写入的权限。若系统权限太高，不让写入C盘就会失败。
手动单步运行若还是失败就没办法了。
...

好的谢谢。或者那个C盘写入，那可以改成其他盘吗？

zhanglei1371 · 发表于 2023-8-26 17:42

本帖最后由 zhanglei1371 于 2023-8-26 18:39 编辑

过客fppt 发表于 2023-8-26 16:03
好的谢谢。或者那个C盘写入，那可以改成其他盘吗？

有，以后有时间了再优化。
不过这个似乎有规律，下面固定出现一个高度的空白，裁切掉，两侧的空白一样，完全可以安装omath的处理。

batmanbbs · 发表于 2023-8-26 18:13

第二张表格好像有问题，WORD和WPS之间有存在不兼容的问题，晕死啊

过客fppt · 发表于 2023-8-26 18:36

zhanglei1371 发表于 2023-8-26 14:39
这个需要有C盘写入的权限。若系统权限太高，不让写入C盘就会失败。
手动单步运行若还是失败就没办法了。
...

zhanglei1371老师，这个可以，图片拖进去透明部分就自动去掉了

过客fppt · 发表于 2023-8-26 18:38

batmanbbs 发表于 2023-8-26 18:13
第二张表格好像有问题，WORD和WPS之间有存在不兼容的问题，晕死啊

谢谢batmanbbs 老师，不兼容的就不管它先了吧

		自动登录	找回密码
密码			免费注册

[求助] 文档中表格批量转化为图片

评分

评分

评分