如何用VBA将Word文档中的域代码公式复制为图片，求大家指点

过客fppt · 发表于 2023-8-16 17:15

zhanglei1371 发表于 2023-8-16 14:20
test代码没有测试？找不到库无所谓，关键是代码能运行，结果是一样的。群友已经测试成功了，

还是不可以

zhanglei1371 · 发表于 2023-8-16 18:12

换3台电脑试试。不行就算了。

过客fppt · 发表于 2023-8-17 08:46

zhanglei1371 发表于 2023-8-16 18:12
换3台电脑试试。不行就算了。

好，谢谢 zhanglei1371 老师，后面我找其他人的电脑再试试看

过客fppt · 发表于 2023-8-17 19:02

本帖最后由过客fppt 于 2023-8-18 10:23 编辑

各位大佬，我终于搞定了，但是不够完善，比如：
1、我不知道如何自动获取域代码公式的高度
2、复制为图片的那个代码总是间歇性报错，导致有时候粘贴不了图片，还希望各位老师们指点一下

Option Explicit
Dim 输出 As Double
Dim leftDistance As Double
Dim 公式边距 As Integer
Dim 原来高度 As Double
Sub 选中内容转图片()
Dim j, k As Long
Dim rng As Range
Set rng = Selection.Range
j = rng.Start
k = rng.End
'检查是否有选中内容
If Selection.Type <> wdSelectionNormal Then
MsgBox "请选中要处理的内容！"
Exit Sub
End If
With Selection
' 前后插入换行符
.SetRange Start:=k, End:=k
.TypeParagraph '回车
.SetRange Start:=j, End:=j
.TypeParagraph '回车
rng.Start = rng.Start + 1
rng.Select
原来高度 = 30
Call 自动放大字体并转化为图片(15)
Call 按比例调整选中的图片高度V10

复制代码

过客fppt · 发表于 2023-8-18 09:00

过客fppt 发表于 2023-8-17 19:02
各位大佬，我终于搞定了，但是不够完善，比如：
1、我不知道如何自动获取域代码公式的高度
2、复制为图片 ...

搞错了，我以为代码能全部粘贴过来，详细的代码请看附件

batmanbbs · 发表于 2023-8-18 19:35

本帖最后由 batmanbbs 于 2023-8-18 19:37 编辑

按照我自己的思路，已搞定批量将域代码转图片，代码已经通过QQ发给你了。
PS：转换结果附后

过客fppt · 发表于 2023-8-19 10:03

batmanbbs 发表于 2023-8-18 19:35
按照我自己的思路，已搞定批量将域代码转图片，代码已经通过QQ发给你了。
PS：转换结果附后

收到，非常感谢batmanbbs 老师！

loquat · 发表于 2023-8-19 23:19

本帖最后由 loquat 于 2023-8-20 00:23 编辑

楼主这个思路有新意。

Option Explicit
#If VBA7 And Win64 Then
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Sub EQ域转图片(oField As Word.Field)
If oField.Type <> wdFieldFormula Then Exit Sub '仅处理EQ域
Dim rng As Word.Range
Dim i As Long
Dim j As Long
Dim k As Long
Dim NewFontSize As Double
Dim iWidth As Double
Dim iStep As Double
Dim leftDistance As Double
Dim rightDistance As Double
Dim lMargin As Double
Dim ratio As Double
Set rng = oField.Code
rng.SetRange rng.Start - 1, rng.End + 1 '扩展到域的外面
rng.InsertBefore vbLf '前后插入换行
rng.InsertAfter vbLf
j = rng.Start + 1 '记住当前位置，一会儿要用到
k = rng.End - 1 '记住当前位置，一会儿要用到
rng.SetRange j, k '铲掉前后换行符
rng.ParagraphFormat.Reset '去除编号、项目符号等
rng.Paragraphs(1).CharacterUnitFirstLineIndent = 0
rng.Paragraphs(1).FirstLineIndent = 0
rng.Paragraphs(1).Alignment = wdAlignParagraphCenter '居中对齐
Do
i = i + 1
lMargin = rng.PageSetup.LeftMargin
rng.Document.Range(j, j).Select '竟然不用Select得不出来正确的值，BUG
leftDistance = Selection.Information(wdHorizontalPositionRelativeToPage) - lMargin ' 获取选定区域左侧与页面左边缘的距离（以磅为单位）
If iWidth = 0 Then
rng.Document.Range(k, k).Select
rightDistance = Selection.Information(wdHorizontalPositionRelativeToPage) - lMargin
iWidth = rightDistance - leftDistance '记录原来宽度
End If
If leftDistance < 5 Or i >= 128 Then
rng.CopyAsPicture
Sleep 1000
rng.PasteSpecial DataType:=wdPasteMetafilePicture, Placement:=wdInLine
rng.SetRange rng.Start - 1, rng.End '设置为图片范围
With rng.InlineShapes(1)
ratio = .Height / .Width
.Width = iWidth
.Height = iWidth * ratio
End With
rng.Document.Range(j + 1, j + 2).Delete
rng.Document.Range(j - 1, j).Delete
Exit Do
End If
NewFontSize = rng.Font.Size '当前字体大小
iStep = leftDistance * 0.6 '放大60%
'改天优化
If leftDistance < 30 And iStep > 0 Then
If iStep < 10 Then
iStep = 10
ElseIf iStep < 5 Then
iStep = 5
End If
End If
rng.Font.Size = NewFontSize + iStep
Loop
End Sub

复制代码

过客fppt · 发表于 2023-8-20 09:10

本帖最后由过客fppt 于 2023-8-20 09:20 编辑

loquat 发表于 2023-8-19 23:19
楼主这个思路有新意。

感谢loquat老师对我这个想法的评价，不过看了batmanbbs老师提供的嵌入式图片右侧空白裁剪掉的方法。我才知道原来Vba里面本本身就有对嵌入式图片进行处理的方法。感觉我的方法就是不够好。且在不断的调整字体大小比较难做到所有的域公式都能统一，有些分式放太大了，转化为图片后，底下的分母有一半不在页面内也会消失。

tcdatongye · 发表于 2023-8-20 16:56

本帖最后由 tcdatongye 于 2023-8-20 16:57 编辑

嵌入式图片位置在文字里怎样居中？把域转化为图片并裁剪，有的图片在文字中位置偏上了。我用的是office

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

[求助] 如何用VBA将Word文档中的域代码公式复制为图片，求大家指点

评分

评分

评分