完美拆分汉字

在运行VBA之前请安装字体“楷体_GB2312”，运行“第一步”折分汉字成“freeform”图形零件。由于拆分成的零件的顺序与汉字的笔顺不一致，

所以要运行“第二步”，记下零件的顺序与汉字笔顺的对应关系。比如：“正”字，拆分成的零件的顺序是横、竖、竖、横、横，而汉字的笔顺是：

横、竖、横、竖、横。也就是你在第三步出来的输入框里依次输入1,2,4,3,5.就纠正了这个错误.

你可以直接运行”拆分汉字”，就得到按默认顺序组成的部件。就能更好理解为什么要分成麻烦的3个步骤。

将VBA代码稍作修改，就可以获得偏旁部首。当然，你也可以手工拖动笔画，组成自己想要的效果。

动手吧！下载不等于技能！！

Sub 第一步()

Dim s$

s = InputBox("请输入要拆分的汉字：", "拆分汉字", "正")

With Selection

.WholeStory

.Delete

ActiveDocument.Shapes.AddTextEffect(msoTextEffect1, s, "楷体_GB2312", 60#, msoFalse, msoFalse, 0, 0).Select

.Cut

.PasteSpecial DataType:=wdPasteMetafilePicture '选择性粘帖“图形（Windows图元文件）”

ActiveDocument.Shapes(1).Select

.ShapeRange.Ungroup.Select

.Cut

.MoveRight wdCharacter, 1

.Paste

MsgBox "请拿笔把汉字拆分成单个零件，记下一会儿是第几次看到的" & Chr(10) & "记在对应的零件旁边，每次间隔5秒", vbOKOnly, "黄义成温馨提示"

End With

End Sub

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub 第二步()

Dim x As Byte, m As Byte

m = ActiveDocument.Shapes.Count - 3

For x = 1 To m

ActiveDocument.Shapes(3 + x).Select

Sleep 5000

DoEvents

Next x

End Sub

Sub 第三步()

Dim m As Byte, num(), x As Byte, y As Byte

m = ActiveDocument.Shapes.Count - 3

ReDim num(1 To m)

For x = 1 To m

num(x) = InputBox("第" & x & "次看到的是第几画？", "为了更完美，需要您的参与！", "2")

Next x

With Selection

For x = 1 To m

For y = num(x) To m

ActiveDocument.Shapes(3 + x).Select

.Copy: .Paste: .ShapeRange.IncrementLeft 80 * y

Next y

Next x

End With

End Sub

Sub 拆分汉字()

Dim s$, x As Byte, y As Byte, m As Byte

s = InputBox("请输入要拆分的汉字：", "拆分汉字", "正")

With Selection

.WholeStory

.Delete '清空

ActiveDocument.Shapes.AddTextEffect(msoTextEffect1, s, "楷体_GB2312", 60#, msoFalse, msoFalse, 0, 0).Select

.Cut

.PasteSpecial DataType:=wdPasteMetafilePicture '选择性粘帖“图形（Windows图元文件）”ActiveDocument.Shapes(1).Select

.ShapeRange.Ungroup.Select

.Cut

.MoveRight wdCharacter, 1

.Paste

m = ActiveDocument.Shapes.Count – 3’汉字的总笔画数

For x = 1 To m

For y = x To m

ActiveDocument.Shapes(x + 3).Select

.Copy: .Paste: .ShapeRange.IncrementLeft 65 * y

Next y

Next x End With End Sub