完美拆分汉字.docVIP

在运行VBA之前请安装字体“楷体_GB2312”，运行“第一步”折分汉字成“freeform”图形零件。由于拆分成的零件的顺序与汉字的笔顺不一致， 所以要运行“第二步”，记下零件的顺序与汉字笔顺的对应关系。比如：“正”字，拆分成的零件的顺序是横、竖、竖、横、横，而汉字的笔顺是： 横、竖、横、竖、横。也就是你在第三步出来的输入框里依次输入1,2,4,3,5.就纠正了这个错误. 你可以直接运行”拆分汉字”，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 S