Word VBA 程序将 Emoji 字符（4 个字节）读取为“12”
Word VBA program reads Emoji character (4 bytes) as "12"
我创建了一个文档，其中只有一个 "Thumb up" Emoji（Unicode 代码点 U+1F44D），我通过标准 Windows+;快捷键：
但我无法通过 VBA.
获取其 实际代码点
我得到这些值（调试）：
text = 12
length = 2
arrBytes = { 49, 0, 50, 0 }
使用以下子过程：
Sub test()
Dim text As String
Dim length As Integer
Dim arrBytes() As Byte
text = ActiveDocument.Range.Characters(1).text
length = Len(ActiveDocument.Range.Characters(1).text)
arrBytes = ActiveDocument.Range.Characters(1).text
End Sub
但是如果我通过菜单插入相同的表情符号 插入 > 符号 > 字体 "Segoe UI Emoji" > U+1F44D（大拇指），相同的 Sub 过程得到了我期望的值（在调试中；?? 不是 "real" 个字符，它们是 surrogate code points 单独没有任何意义):
text = ??
length = 2
arrBytes = { 61, 216, 77, 220 }
（参考，这个code将两个字符解码成👍）
如果使用Windows+;插入Emoji，如何判断实际字符？ （要求用户选择上述解决方法不是我的问题的一部分）
附录 5 月 26 日：@Florent B. 的解决方案适用于我所有的 3 台计算机 (ActiveDocument.Content.InsertXML ActiveDocument.Content.XML)。重新加载 XML 可能会对 VBA 程序产生影响，例如它会重新编号图像 "Shape IDs"，但那是另一回事了。
附录 5 月 22 日：对于符号添加 Windows+;, 我只能在文档 Range 对象的 XML 属性 中找到正确的值（4 字节 { 61, 216, 77, 220 }），但它要求我解析整个 XML 并确定哪些 XML 字符对应于 Range 对象的哪些位置，不幸的是我觉得这需要很多知识或假设。这是 XML 的一部分，我可以看到 4 个字节（<w:t>??</w:t> 其中 ?? 对应于 4 个字节）：
<?xml version="1.0" standalone="yes"?>
<?mso-application progid="Word.Document"?>
<w:wordDocument ...>
... (around 23.000 characters)
<w:body>
<wx:sect>
<w:p wsp:rsidR="002703DB" wsp:rsidRDefault="003926FB">
<w:r>
<w:rPr>
<w:rFonts w:ascii="Segoe UI Emoji" w:h-ansi="Segoe UI Emoji"/>
<wx:font wx:val="Segoe UI Emoji"/>
</w:rPr>
<w:t>??</w:t>
</w:r>
</w:p>
<w:sectPr wsp:rsidR="002703DB" wsp:rsidSect="002849CD"><w:pgSz w:w="11906"
w:h="16838"/><w:pgMar w:top="1417" w:right="1417" w:bottom="1417"
w:left="1417" w:header="708" w:footer="708" w:gutter="0"/><w:cols
w:space="708"/><w:docGrid w:line-pitch="360"/></w:sectPr>
</wx:sect>
</w:body>
</w:wordDocument>
XML几乎一样当我插入表情符号作为符号时，还有2个"rFonts":
<w:body>
<wx:sect>
<w:p wsp:rsidR="00CD420D" wsp:rsidRDefault="00CD420D">
<w:r>
<w:rPr>
<w:rFonts w:ascii="Segoe UI Emoji" w:fareast="Segoe UI Emoji"
w:h-ansi="Segoe UI Emoji" w:cs="Segoe UI Emoji"/>
<wx:font wx:val="Segoe UI Emoji"/>
</w:rPr>
<w:t>??</w:t>
</w:r>
</w:p>
<w:sectPr wsp:rsidR="00CD420D" wsp:rsidSect="002849CD"><w:pgSz w:w="11906"
w:h="16838"/><w:pgMar w:top="1417" w:right="1417" w:bottom="1417"
w:left="1417" w:header="708" w:footer="708" w:gutter="0"/><w:cols
w:space="708"/><w:docGrid w:line-pitch="360"/></w:sectPr>
</wx:sect>
</w:body>
</w:wordDocument>
PS：computers/softwares 我可以重现问题的地方：
- 电脑1（联想X230）：
- MS Word Office 365 1904 (16.0.11601.20174) 32 位，Windows 10 专业版 10.0.17763 x64
- 升级到 Office 365 1907 16.0.11901.20176 后，MSO (16.0.11901.20070) 32 位，Windows 10 Professional 1809 17763.652 x64
- 计算机 2：
- MS Word Office 365 1904 (16.0.11601.20184) 64 位，Windows10 专业版 1809 17763.503 x64
- 计算机 3（戴尔）：
- MS Word Office 365 ProPlus 1808 (16.0.10730.20334) 64 位，Windows10 企业版 10.0.17763 x64
我希望这会有所帮助：基于@SandraRossi 的上述评论，表情符号面板的输入似乎未正确转换为其代理代码点。如果您将包含这两种符号的文档（一个来自表情符号面板，另一个来自菜单，如您所述）保存为 XML 文档，您会注意到其中的区别：
表情符号输入：
<w:r w:rsidR="003814F5">
<w:rPr>
<mc:AlternateContent>
<mc:Choice Requires="w16se">
<w:rFonts w:ascii="Segoe UI Emoji" w:hAnsi="Segoe UI Emoji"/>
</mc:Choice>
<mc:Fallback>
<w:rFonts w:hint="eastAsia"/>
</mc:Fallback>
</mc:AlternateContent>
</w:rPr>
<mc:AlternateContent>
<mc:Choice Requires="w16se">
<w16se:symEx w16se:font="@SimHei" w16se:char="1F44D"/>
</mc:Choice>
<mc:Fallback>
<w:t></w:t>
</mc:Fallback>
</mc:AlternateContent>
</w:r>
菜单（符号）输入：
<w:r w:rsidR="003814F5">
<w:rPr>
<w:rFonts w:ascii="Segoe UI Emoji" w:hAnsi="Segoe UI Emoji"/>
</w:rPr>
<w:t xml:space="preserve"> is not </w:t>
</w:r>
<w16se:symEx w16se:font="@SimHei" w16se:char="1F44D"/> 行是这里的主要区别。正常的（菜单 -> 插入符号）表情符号用作后备。
好像只有Word有问题。我在 Excel（和 PowerPoint）上尝试了相同的表情符号面板输入，我在调试 ?? 中得到了正确的值，它在 Excel 中转换为 Unicode 代码点 U+1F44D当复制回 Word 时。
这是我最终的信念和发现。
根据 AAA 在 Excel、Powerpoint 和 Word 上进行的测试，这可能是 MS Word VBA 中的错误。有些人没有这个错误（参见评论）。
VBA 对象给出了无效的表情符号值，但 XML 属性 是正确的。 XML 过于复杂而不易解析，因此 Florent B. 在评论中找到了最简单的解决方法，其中包含 "recreating the document from itself":
ActiveDocument.Content.InsertXML ActiveDocument.Content.XML
不幸的是，就我个人而言，它可能会产生一些附带影响，例如形状 ID 被重新编号。
所以，我将上面的代码进行了扩展，只修正了原文档中的emoji字符，其余保持原样，作者：
- 正在将 XML 复制到 新 文档，
- 然后解析新文档中文本长度大于 1 的每个字符（即 Unicode 基本多语言平面之外的字符，也包含表情符号和许多其他字符），
- 同时解析原始文档（假设字符的顺序应与新文档中的字符顺序相同，并且它们的文本长度相同），
- 将这些字符从新文档复制回原始文档，
- 关闭新文档。
好的，宏运行时间更长，但我找不到更好的解决方案。
这是我的代码，经过简化（您可能会对 Range 对象的无用集合感到惊讶，其中每个 Range 是一个 Character 对象，实际上我没有提供函数的原始代码 Split_Into_Ranges ，它更大但更快，但它可以正常工作并很好地演示子 correct_emojis):
中的解决方案
Sub test()
Dim text As String
Dim length As Integer
Dim arrBytes() As Byte
Dim zranges As Collection
Set zranges = Split_Into_Ranges(ActiveDocument)
Call correct_emojis(zranges) ' <=== here the important algorithm
text = ActiveDocument.Range.Characters(1).text
length = Len(ActiveDocument.Range.Characters(1).text)
arrBytes = ActiveDocument.Range.Characters(1).text
End Sub
Function Split_Into_Ranges(ioDocument As Document) As Collection
Dim zranges As Collection
Set zranges = New Collection
For i = 1 To ioDocument.Characters.Count
zranges.Add ioDocument.Characters(i)
Next
Set Split_Into_Ranges = zranges
End Function
Sub correct_emojis(zranges As Collection)
Dim current_emoji_zranges As Collection
Dim temp_zranges As Collection
Dim temp_emoji_zranges As Collection
Dim doc_current As Document
Dim doc_temp As Document
Dim arrBytes() As Byte
Set doc_current_zranges = get_emoji_zranges(zranges)
If doc_current_zranges.Count = 0 Then
Exit Sub
End If
Set doc_current = ActiveDocument
Set doc_temp = Documents.Add()
Call doc_temp.Content.InsertXML(doc_current.Content.XML)
Set temp_zranges = Split_Into_Ranges(doc_temp)
Set current_emoji_zranges = get_emoji_zranges(zranges)
Set temp_emoji_zranges = get_emoji_zranges(temp_zranges)
For i = 1 To current_emoji_zranges.Count
If 0 = 1 Then
arrBytes = current_emoji_zranges(i).Characters(1).text
arrBytes = temp_emoji_zranges(i).Characters(1).text
End If
current_emoji_zranges(i).Characters(1).text = temp_emoji_zranges(i).Characters(1).text
Next
Call doc_temp.Close(False)
End Sub
Function get_emoji_zranges(zranges As Collection) As Collection
Dim emoji_zranges As Collection
Set emoji_zranges = New Collection
For i = 1 To zranges.Count
If Len(zranges(i).text) > zranges(i).Characters.Count Then
For j = 1 To zranges(i).Characters.Count
If Len(zranges(i).Characters(j).text) > 1 Then
emoji_zranges.Add (zranges(i))
End If
Next
End If
Next
Set get_emoji_zranges = emoji_zranges
End Function
我创建了一个文档，其中只有一个 "Thumb up" Emoji（Unicode 代码点 U+1F44D），我通过标准 Windows+;快捷键：
但我无法通过 VBA.
获取其 实际代码点我得到这些值（调试）：
text = 12
length = 2
arrBytes = { 49, 0, 50, 0 }
使用以下子过程：
Sub test()
Dim text As String
Dim length As Integer
Dim arrBytes() As Byte
text = ActiveDocument.Range.Characters(1).text
length = Len(ActiveDocument.Range.Characters(1).text)
arrBytes = ActiveDocument.Range.Characters(1).text
End Sub
但是如果我通过菜单插入相同的表情符号 插入 > 符号 > 字体 "Segoe UI Emoji" > U+1F44D（大拇指），相同的 Sub 过程得到了我期望的值（在调试中；?? 不是 "real" 个字符，它们是 surrogate code points 单独没有任何意义):
text = ??
length = 2
arrBytes = { 61, 216, 77, 220 }
（参考，这个code将两个字符解码成👍）
如果使用Windows+;插入Emoji，如何判断实际字符？ （要求用户选择上述解决方法不是我的问题的一部分）
附录 5 月 26 日：@Florent B. 的解决方案适用于我所有的 3 台计算机 (ActiveDocument.Content.InsertXML ActiveDocument.Content.XML)。重新加载 XML 可能会对 VBA 程序产生影响，例如它会重新编号图像 "Shape IDs"，但那是另一回事了。
附录 5 月 22 日：对于符号添加 Windows+;, 我只能在文档 Range 对象的 XML 属性 中找到正确的值（4 字节 { 61, 216, 77, 220 }），但它要求我解析整个 XML 并确定哪些 XML 字符对应于 Range 对象的哪些位置，不幸的是我觉得这需要很多知识或假设。这是 XML 的一部分，我可以看到 4 个字节（<w:t>??</w:t> 其中 ?? 对应于 4 个字节）：
<?xml version="1.0" standalone="yes"?>
<?mso-application progid="Word.Document"?>
<w:wordDocument ...>
... (around 23.000 characters)
<w:body>
<wx:sect>
<w:p wsp:rsidR="002703DB" wsp:rsidRDefault="003926FB">
<w:r>
<w:rPr>
<w:rFonts w:ascii="Segoe UI Emoji" w:h-ansi="Segoe UI Emoji"/>
<wx:font wx:val="Segoe UI Emoji"/>
</w:rPr>
<w:t>??</w:t>
</w:r>
</w:p>
<w:sectPr wsp:rsidR="002703DB" wsp:rsidSect="002849CD"><w:pgSz w:w="11906"
w:h="16838"/><w:pgMar w:top="1417" w:right="1417" w:bottom="1417"
w:left="1417" w:header="708" w:footer="708" w:gutter="0"/><w:cols
w:space="708"/><w:docGrid w:line-pitch="360"/></w:sectPr>
</wx:sect>
</w:body>
</w:wordDocument>
XML几乎一样当我插入表情符号作为符号时，还有2个"rFonts":
<w:body>
<wx:sect>
<w:p wsp:rsidR="00CD420D" wsp:rsidRDefault="00CD420D">
<w:r>
<w:rPr>
<w:rFonts w:ascii="Segoe UI Emoji" w:fareast="Segoe UI Emoji"
w:h-ansi="Segoe UI Emoji" w:cs="Segoe UI Emoji"/>
<wx:font wx:val="Segoe UI Emoji"/>
</w:rPr>
<w:t>??</w:t>
</w:r>
</w:p>
<w:sectPr wsp:rsidR="00CD420D" wsp:rsidSect="002849CD"><w:pgSz w:w="11906"
w:h="16838"/><w:pgMar w:top="1417" w:right="1417" w:bottom="1417"
w:left="1417" w:header="708" w:footer="708" w:gutter="0"/><w:cols
w:space="708"/><w:docGrid w:line-pitch="360"/></w:sectPr>
</wx:sect>
</w:body>
</w:wordDocument>
PS：computers/softwares 我可以重现问题的地方：
- 电脑1（联想X230）：
- MS Word Office 365 1904 (16.0.11601.20174) 32 位，Windows 10 专业版 10.0.17763 x64
- 升级到 Office 365 1907 16.0.11901.20176 后，MSO (16.0.11901.20070) 32 位，Windows 10 Professional 1809 17763.652 x64
- 计算机 2：
- MS Word Office 365 1904 (16.0.11601.20184) 64 位，Windows10 专业版 1809 17763.503 x64
- 计算机 3（戴尔）：
- MS Word Office 365 ProPlus 1808 (16.0.10730.20334) 64 位，Windows10 企业版 10.0.17763 x64
我希望这会有所帮助：基于@SandraRossi 的上述评论，表情符号面板的输入似乎未正确转换为其代理代码点。如果您将包含这两种符号的文档（一个来自表情符号面板，另一个来自菜单，如您所述）保存为 XML 文档，您会注意到其中的区别：
表情符号输入：
<w:r w:rsidR="003814F5">
<w:rPr>
<mc:AlternateContent>
<mc:Choice Requires="w16se">
<w:rFonts w:ascii="Segoe UI Emoji" w:hAnsi="Segoe UI Emoji"/>
</mc:Choice>
<mc:Fallback>
<w:rFonts w:hint="eastAsia"/>
</mc:Fallback>
</mc:AlternateContent>
</w:rPr>
<mc:AlternateContent>
<mc:Choice Requires="w16se">
<w16se:symEx w16se:font="@SimHei" w16se:char="1F44D"/>
</mc:Choice>
<mc:Fallback>
<w:t></w:t>
</mc:Fallback>
</mc:AlternateContent>
</w:r>
菜单（符号）输入：
<w:r w:rsidR="003814F5">
<w:rPr>
<w:rFonts w:ascii="Segoe UI Emoji" w:hAnsi="Segoe UI Emoji"/>
</w:rPr>
<w:t xml:space="preserve"> is not </w:t>
</w:r>
<w16se:symEx w16se:font="@SimHei" w16se:char="1F44D"/> 行是这里的主要区别。正常的（菜单 -> 插入符号）表情符号用作后备。
好像只有Word有问题。我在 Excel（和 PowerPoint）上尝试了相同的表情符号面板输入，我在调试 ?? 中得到了正确的值，它在 Excel 中转换为 Unicode 代码点 U+1F44D当复制回 Word 时。
这是我最终的信念和发现。
根据 AAA 在 Excel、Powerpoint 和 Word 上进行的测试，这可能是 MS Word VBA 中的错误。有些人没有这个错误（参见评论）。
VBA 对象给出了无效的表情符号值，但 XML 属性 是正确的。 XML 过于复杂而不易解析，因此 Florent B. 在评论中找到了最简单的解决方法，其中包含 "recreating the document from itself":
ActiveDocument.Content.InsertXML ActiveDocument.Content.XML
不幸的是，就我个人而言，它可能会产生一些附带影响，例如形状 ID 被重新编号。
所以，我将上面的代码进行了扩展，只修正了原文档中的emoji字符，其余保持原样，作者：
- 正在将 XML 复制到 新 文档，
- 然后解析新文档中文本长度大于 1 的每个字符（即 Unicode 基本多语言平面之外的字符，也包含表情符号和许多其他字符），
- 同时解析原始文档（假设字符的顺序应与新文档中的字符顺序相同，并且它们的文本长度相同），
- 将这些字符从新文档复制回原始文档，
- 关闭新文档。
好的，宏运行时间更长，但我找不到更好的解决方案。
这是我的代码，经过简化（您可能会对 Range 对象的无用集合感到惊讶，其中每个 Range 是一个 Character 对象，实际上我没有提供函数的原始代码 Split_Into_Ranges ，它更大但更快，但它可以正常工作并很好地演示子 correct_emojis):
Sub test()
Dim text As String
Dim length As Integer
Dim arrBytes() As Byte
Dim zranges As Collection
Set zranges = Split_Into_Ranges(ActiveDocument)
Call correct_emojis(zranges) ' <=== here the important algorithm
text = ActiveDocument.Range.Characters(1).text
length = Len(ActiveDocument.Range.Characters(1).text)
arrBytes = ActiveDocument.Range.Characters(1).text
End Sub
Function Split_Into_Ranges(ioDocument As Document) As Collection
Dim zranges As Collection
Set zranges = New Collection
For i = 1 To ioDocument.Characters.Count
zranges.Add ioDocument.Characters(i)
Next
Set Split_Into_Ranges = zranges
End Function
Sub correct_emojis(zranges As Collection)
Dim current_emoji_zranges As Collection
Dim temp_zranges As Collection
Dim temp_emoji_zranges As Collection
Dim doc_current As Document
Dim doc_temp As Document
Dim arrBytes() As Byte
Set doc_current_zranges = get_emoji_zranges(zranges)
If doc_current_zranges.Count = 0 Then
Exit Sub
End If
Set doc_current = ActiveDocument
Set doc_temp = Documents.Add()
Call doc_temp.Content.InsertXML(doc_current.Content.XML)
Set temp_zranges = Split_Into_Ranges(doc_temp)
Set current_emoji_zranges = get_emoji_zranges(zranges)
Set temp_emoji_zranges = get_emoji_zranges(temp_zranges)
For i = 1 To current_emoji_zranges.Count
If 0 = 1 Then
arrBytes = current_emoji_zranges(i).Characters(1).text
arrBytes = temp_emoji_zranges(i).Characters(1).text
End If
current_emoji_zranges(i).Characters(1).text = temp_emoji_zranges(i).Characters(1).text
Next
Call doc_temp.Close(False)
End Sub
Function get_emoji_zranges(zranges As Collection) As Collection
Dim emoji_zranges As Collection
Set emoji_zranges = New Collection
For i = 1 To zranges.Count
If Len(zranges(i).text) > zranges(i).Characters.Count Then
For j = 1 To zranges(i).Characters.Count
If Len(zranges(i).Characters(j).text) > 1 Then
emoji_zranges.Add (zranges(i))
End If
Next
End If
Next
Set get_emoji_zranges = emoji_zranges
End Function