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

batmanbbs

过客fppt 发表于 2023-8-25 06:54
超过的话，选中区域会自动分行，生成图片也是两行的了

方法不错，重要的是兼容WORD和WPS，缺点是好像对表格和Omath公式支持的不好

过客fppt

loquat 发表于 2023-8-27 21:38
直接cropRight好像上下也需要处理。

谢谢 loquat 老师，原来还可以这样获取宽度

loquat

我的代码，如果选中区域换行了，就会有问题，仅适用单行的选中区域。

loquat

你们怎么修图片上下的多余空白的？

batmanbbs

loquat 发表于 2023-8-27 21:38
直接cropRight好像上下也需要处理。

老师，目前针对转图片（包括选区、EQ域代码、OMth公式、表格），经过个人测试，除了表格之外，都不需要对转换后的图片进行上下裁剪，只需将段落中的文本对齐方式设置为居中即可。

设置后的效果

过客fppt

弄了那么多代码，但是批量上传到系统中之后，发现公司的系统实在是太垃圾了，好绝望！

WPS中转化为图片后非常正常：

题目批量上传到系统中之后，在系统中的效果：

手动一道道题复制到系统中才能达到理想的效果：

sylun

可试试如下代码，是用GetPoint方法获得区域位置参数并借用网上截屏代码编写，只作简单测试，效率不高。Win11系统运行时库文件出错

1.     Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, _
   
2.         ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
   
3.     Enum JpMode
   
4.           theScreen = 0 '全屏截图
   
5.           theForm = 1 '当前焦点窗口截图
   
6.     End Enum
   
7.     Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
   
8.     Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
   
9.     Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
   
10.     Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, _
    
11.         RefIID As Guid, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    
12.     Private Const CF_BITMAP = 2
    
13.     Private Type PicBmp
    
14.         Size As Long
    
15.         Type As Long
    
16.         hBmp As Long
    
17.         hPal As Long
    
18.         Reserved As Long
    
19.     End Type
    
20.     Private Type Guid
    
21.         Data1 As Long
    
22.         Data2 As Integer
    
23.         Data3 As Integer
    
24.         Data4(0 To 7) As Byte
    
25.     End Type
    
26.    
    
27.     Function ApiGetClipBmp() As IPicture
    
28.         On Error Resume Next
    
29.         Dim Pic As PicBmp, IID_IDispatch As Guid
    
30.         OpenClipboard 0
    
31.         With IID_IDispatch
    
32.             .Data1 = &H20400
    
33.             .Data4(0) = &HC0
    
34.             .Data4(7) = &H46
    
35.         End With
    
36.         With Pic
    
37.             .Size = Len(Pic)
    
38.             .Type = 1
    
39.             .hBmp = GetClipboardData(CF_BITMAP)
    
40.         End With
    
41.         OleCreatePictureIndirect Pic, IID_IDispatch, 1, ApiGetClipBmp
    
42.         CloseClipboard
    
43.     End Function
    
44.    
    
45.     Function KeyJp(Optional ByVal TheMode As JpMode = theScreen) As IPictureDisp
    
46.        '版权所有，请保留作者信息.QQ：1085992075 '原声明
    
47.           Call keybd_event(vbKeySnapshot, TheMode, 0, 0) '
    
48.           DoEvents
    
49.     End Function
    
50. 
    
51. Function RangeToPic(rngTarget As Range) As Variant
    
52.     Dim i%, l&, t&, w&, h&, isWps As Boolean
    
53.     If InStr(LCase(Application.Path), "wps") > 0 Then isWps = True
    
54.     'rngTarget.Select
    
55.     With ActiveDocument
    
56.         .ActiveWindow.View.Zoom = 100
    
57.         .ActiveWindow.GetPoint l, t, w, h, Selection.Range
    
58.         Selection.Collapse wdCollapseEnd
    
59.         Call KeyJp(theScreen)
    
60.         Call ApiGetClipBmp
    
61.         rngTarget.Select
    
62.         Selection.PasteSpecial DataType:=wdPasteBitmap
    
63.         If isWps Then Selection.MoveStart 1, -1 Else Selection.MoveEnd 1, 1
    
64.         With Selection.InlineShapes(1)
    
65.             .LockAspectRatio = msoFalse
    
66.             .ScaleWidth = 100
    
67.             .ScaleHeight = 100
    
68.             .PictureFormat.CropLeft = PixelsToPoints(l)
    
69.             .PictureFormat.CropTop = PixelsToPoints(t)
    
70.             .PictureFormat.CropRight = .Width - PixelsToPoints(w)
    
71.             .PictureFormat.CropBottom = .Height - PixelsToPoints(h)
    
72.             .Range.ParagraphFormat.BaseLineAlignment = wdBaselineAlignCenter
    
73.             .Select
    
74.         End With
    
75.         SendKeys "{ENTER}"
    
76.         Application.CommandBars.Item("Picture").Controls.Item(10).Execute '压缩图片
    
77.     End With
    
78. End Function
    
79. 
    
80. Sub FieldFormulaToPic()
    
81.     '将域公式内容转换为图片，仅页内矩形区域；测试环境：win10 x64, WPS 11.1
    
82.     Dim aField As Field
    
83.     For Each aField In ActiveDocument.Fields
    
84.         If aField.Type = wdFieldFormula Then
    
85.             aField.Select
    
86.             Call RangeToPic(Selection.Range)
    
87.         End If
    
88.     Next
    
89. End Sub

复制代码

batmanbbs

sylun 发表于 2023-8-30 20:37
可试试如下代码，是用GetPoint方法获得区域位置参数并借用网上截屏代码编写，只作简单测试，效率不高。Win1 ...

老师，通过这段代码又学习到不少新知识，谢谢！

经测试采用结合GETPOINT和截图两种方式处理转图的效果并不太理想：

（1）像素转磅本身就受很多因素影响，虽然解决了WORD界面的缩放问题（其实就位图来说，我觉得更好的办法不是恢复到100%后截图，而是放大后截图再缩小，这样图片效果更好一些），但是仍受屏幕PPI等因素影响（在本本上的情况尤为突出）。

（2）窗口本身也受很多因素影响，比如有其他的置顶窗口（例如：我会使用QUICKER的悬浮按钮）会遮挡屏幕和窗口，这时截图的内容可能就不是真正需要的内容。

（3）代码中有两处使用了快捷键，一个是全屏截图，一个是确认压缩图片。全屏截图的快捷键有可能会被其他软件占用失效（虽然这个概率比较小）；压缩图片会弹出窗口WORD压缩图片的确认窗口（有二次确认窗口），影响了代码的运行，另外该功能使用WORD本身的控件，有可能面临WORD和WPS不兼容的问题。

（4）由于采用的截屏方式，必须移动到对应的域代码，让其显示在屏幕上，才能截屏。这导致无法禁止屏幕刷新，大大地降低了运行效率。

（5）剪切图片需要一个过程，每做一次剪切（上下左右一共是4次）都会影响到段落排版，在没有禁止屏幕刷新的情况，极有可能影响截图内容的准确性。（可能还需要一个延时来处理才行）

PS：代码中有两处是不是有点问题：
（1）识别WORD/WPS后，选择插入转换的嵌入式图片，是不是WORD和WPS不同的选择方式写反了?
（2）发送回车键是不是应该在调用压缩图片对话窗口之后？

过客fppt

sylun 发表于 2023-8-30 20:37
可试试如下代码，是用GetPoint方法获得区域位置参数并借用网上截屏代码编写，只作简单测试，效率不高。Win1 ...

非常感谢 sylun 老师的帮助，以前我们一直用手动截图一个个公式进行的，但是因为打印出来质量不好，后来要求输入转化为Word自带公式；昨天我也找了公司系统的开发人员，他们今天回复：经过技术评估，后端暂时做不了优化，这个问题以前就存在的，技术之前测试过其他方案都没有办法解决。
总体来说，就是公司的系统太垃圾了，唉

zhanglei1371

过客fppt 发表于 2023-8-31 10:31
非常感谢 sylun 老师的帮助，以前我们一直用手动截图一个个公式进行的，但是因为打印出来质量不好，后来 ...

test.rar (109.46 KB, 下载次数: 45)

2023-8-31 18:20 上传

点击文件名下载附件

这个应该没问题吧

还没做好...