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

wdpfox

batmanbbs 发表于 2023-10-22 12:15
当时间为0时，Timer函数返回0，这时timer-timer1为负数，会造成无限循环。因此，timer2需要重新计数（一 ...

谢谢两位老师指教

常扬帆

谢谢楼主！留个记号……

t2251618

大佬，可以把代码分享一下吗

过客fppt

1. Sub EQ公式转图形V30(Optional ByVal waittime As Single = 0.2)
   
2.     '
   
3.     ' EQ公式转嵌入式图形
   
4.     '
   
5.     If Selection.Fields.count = 0 Then MsgBox "请选择含有公式的内容！": End
   
6.    
   
7.     '    On Error Resume Next
   
8.     'On Error GoTo ErrorEnd
   
9.     Application.ScreenUpdating = False
   
10.     Application.DisplayAlerts = False
    
11.    
    
12.     Dim count%, rStart&, pos&, i&, Zoom!, isWord As Boolean
    
13.     Dim PSize%, PWidth%, LMargin%, RMargin%, LayoutWidth%, CropWidth%
    
14.     Dim Mydoc, MyDoc1, tempDoc As Document, myField As Field
    
15.    
    
16.    
    
17.     Set Mydoc = ActiveDocument
    
18.    
    
19.     Dim yuanRange As Range
    
20.     '选中内容之后
    
21.     Set yuanRange = Selection.Range
    
22.    
    
23.     '    With Selection.PageSetup
    
24.     '        PSize = .PaperSize: PWidth = .PageWidth
    
25.     '        LMargin = .leftMargin: RMargin = .rightMargin
    
26.     '        LayoutWidth = PWidth - LMargin - RMargin
    
27.     '    End With
    
28.     '    输入标准宽度
    
29.     PSize = 7: PWidth = 595
    
30.     LMargin = 90: RMargin = 90
    
31.     LayoutWidth = PWidth - LMargin - RMargin
    
32.    
    
33.     Set MyDoc1 = Documents.Add(Visible:=True)
    
34.    
    
35.     '将选中的内容赋值给mydoc1
    
36.     MyDoc1.Content.FormattedText = yuanRange
    
37.    
    
38.     Selection.WholeStory ' 选中全部
    
39.    
    
40.    
    
41.     Set tempDoc = Documents.Add(Visible:=False)
    
42.     With tempDoc.PageSetup
    
43.         .PaperSize = PSize: .PageWidth = PWidth
    
44.         .leftMargin = LMargin: .rightMargin = RMargin
    
45.     End With
    
46.    
    
47.     MyDoc1.Activate
    
48.     MyDoc1.ActiveWindow.DisplayVerticalScrollBar = False        ' 隐藏垂直滚动条（提高速度）
    
49.     isWord = CheckApplicationisword
    
50.     i = 1: rStart = -1
    
51.     zhunhuaCo = 0
    
52.     Call 是加图(True)
    
53.    
    
54.     With Selection
    
55.         ' 添加辅助段落符（解决当选区开始就是域代码时，只能转换第一个的问题）
    
56.         If .Start <> .End And .Start >= .Fields(1).Code.Start - 1 Then
    
57.             rStart = .Fields(1).Code.Start - 1
    
58.             ActiveDocument.Range(rStart, rStart).InsertParagraphBefore
    
59.             .SetRange rStart, .End
    
60.         End If
    
61.         .ParagraphFormat.BaseLineAlignment = wdBaselineAlignCenter        ' 段落中心对齐
    
62.         Do
    
63.             Set myField = .Fields(i)
    
64.             If myField.Type <> wdFieldFormula Then
    
65.                 i = i + 1
    
66.             Else
    
67.                 ' 计算公式宽度
    
68.                 With tempDoc
    
69.                     .Fields.Add .Content, wdFieldEmpty, "", False
    
70.                     .Fields(1).Code.FormattedText = myField.Code
    
71.                     .Fields(1).ShowCodes = False
    
72.                     With .Content
    
73.                         .ParagraphFormat.Alignment = wdAlignParagraphRight
    
74.                         CropWidth = .Information(wdHorizontalPositionRelativeToTextBoundary) - 1
    
75.                         '                        CropWidth = CropWidth * 0.85213 '适配在WPS中的运行
    
76.                     End With
    
77.                 End With
    
78. Line1:
    
79.                
    
80.                 ' 公式转图形
    
81.                 With myField
    
82.                     pos = .result.Start: .Copy: Wait (IIf(isWord, 0.05, waittime))
    
83.                 End With
    
84.                 MyDoc1.Range(pos, pos).PasteSpecial _
    
85.                     DataType:=wdPasteEnhancedMetafile, Placement:=wdInLine
    
86.                
    
87.                 Dim i1 As Integer
    
88.                
    
89.                 If 是加图(False) = 0 Then
    
90.                     i1 = i1 + 1
    
91.                     If i1 > 16 Then
    
92.                         MsgBox "无法粘贴为图片，请检查！"
    
93.                     End If
    
94.                     GoTo Line1
    
95.                 End If
    
96.                
    
97.                 count = MyDoc1.Range(0, pos).InlineShapes.count + 1
    
98.                 MyDoc1.InlineShapes(count).Title = "QQ84299244_EQ"        ' 设置名称便于以后统一对图形进行再处理
    
99.                
    
100.                 If CropWidth > 0 Then
     
101.                     With MyDoc1.InlineShapes(count)
     
102.                         If isWord Then
     
103.                             .PictureFormat.CropRight = CropWidth
     
104.                         Else
     
105.                             .Reset: Zoom = .Width / LayoutWidth
     
106.                             .PictureFormat.CropRight = CropWidth * Zoom
     
107.                             .Width = .Width / Zoom: Wait (0.1)
     
108.                         End If
     
109.                     End With
     
110.                 End If
     
111.                 zhunhuaCo = zhunhuaCo + 1
     
112.                
     
113.                 If zhunhuaCo Mod 20 = 0 Then
     
114.                     Wait (2)
     
115.                     Debug.Print "累计已完成公式转化数量：" & zhunhuaCo
     
116.                 End If
     
117.                
     
118.                 myField.Delete
     
119.             End If
     
120.         Loop Until i > .Fields.count
     
121.         If rStart >= 0 Then ActiveDocument.Range(rStart, rStart).Delete        ' 删除辅助段落符
     
122.     End With
     
123.     tempDoc.Close False
     
124.     MyDoc1.ActiveWindow.DisplayVerticalScrollBar = True        ' 恢复垂直滚动条
     
125.    
     
126. ErrorEnd:
     
127.     Set Mydoc = Nothing
     
128.     Set MyDoc1 = Nothing
     
129.     Set tempDoc = Nothing
     
130.     Application.ScreenUpdating = True
     
131.     Application.DisplayAlerts = True
     
132.     Err.Clear: On Error GoTo 0
     
133.     Debug.Print "已完成" & zhunhuaCo & "个公式的转化！请注意另存文件，用于上传到系统！"
     
134.     '    MsgBox "已完成" & zhunhuaCo & "个公式的转化！请注意另存文件，用于上传到系统！"
     
135. End Sub
     
136. 
     
137. 
     
138. Function 是加图(初始化 As Boolean) As Boolean
     
139.     '        '初始化
     
140.     '        If 初始化 = True Then
     
141.     '            tupianCo0 = 现在图片总数(100)
     
142.     '            tupianCo1 = 0
     
143.     '            tupianCo2 = 0
     
144.     '            index = 0
     
145.     '            是加图 = False
     
146.     '        Else
     
147.     '            tupianCo2 = 现在图片总数(100) - tupianCo0 + tupianCo2
     
148.     '            '逻辑判断
     
149.     '            If tupianCo2 > tupianCo1 Then
     
150.     是加图 = True
     
151.     '            Else
     
152.     '                是加图 = False
     
153.     '            End If
     
154.     '            index = index + 1
     
155.     '            tupianCo1 = tupianCo2
     
156.     '        End If
     
157.     '        Debug.Print "运行第" & index & "次，图片增加了？  " & 是加图
     
158. End Function
     
159. 
     
160. Public Function 现在图片总数(宽度大于 As Integer) As Integer
     
161.     Dim shp As InlineShape
     
162.     Dim i As Integer
     
163.     For Each shp In ActiveDocument.InlineShapes
     
164.         If shp.Width > 宽度大于 Then
     
165.             i = i + 1
     
166.         End If
     
167.     Next shp
     
168.     现在图片总数 = i
     
169. End Function
     
170. 
     
171. 
     
172. 
     
173. 
     
174. Sub Wait(t As Single)
     
175.     Dim time1!, time2!
     
176.     time1 = Timer
     
177.     Do
     
178.         DoEvents
     
179.         time2 = Timer - time1
     
180.         If time2 < 0 Then time2 = time2 + 86400        ' 86400=24*3600
     
181.     Loop While time2 < t
     
182. End Sub

复制代码

过客fppt

t2251618 发表于 2024-3-5 19:03
大佬，可以把代码分享一下吗

已分享，请耐心等待审核，此代码的核心部分主要是batmanbbs老师写的，我只是做了一下调试

文化属性666

谢谢老师分享

1478525

最终可行的办法和代码能发上来吗 多谢

过客fppt

1478525 发表于 2024-7-21 15:01
最终可行的办法和代码能发上来吗 多谢

最终代码就在94楼

1478525

过客fppt 发表于 2024-7-21 20:11
最终代码就在94楼

谢谢

过客fppt

1478525 发表于 2024-7-21 20:20
谢谢

有帮助请送花花