汉字笔画计算小程序

zopey

'纯vba代码

Private Sub CommandButton1_Click()

m = ActiveSheet.Shapes.Count
For i = m To 1 Step -1
   If ActiveSheet.Shapes(i).Type <> 12 Then ActiveSheet.Shapes(i).Delete
Next

Dim s As String
s = [g3].Value

Dim wordapp As Object
Set wordapp = CreateObject("word.application")

With wordapp
    .documents.Add
    '.Visible = 1

    .ActiveDocument.Shapes.AddTextEffect(msoTextEffect1, s, "楷体_GB2312", 100#, msoFalse, msoFalse, 66#, 80).Select
    'DoEvents
    With .Selection
         .Cut
         .PasteSpecial DataType:=3
    End With

    .ActiveDocument.Shapes(1).Select
    .Selection.ShapeRange.Ungroup.Select
    .Selection.Copy

    .ActiveDocument.Close False
End With

ActiveSheet.[e7].Select
ActiveSheet.Paste

m = ActiveSheet.Shapes.Count
ActiveSheet.[g4].Select
ActiveSheet.[g4].Value = m - 3

wordapp.Quit SaveChanges:=wdDoNotSaveChanges
Set wordapp = Nothing
End Sub




附件说明：
在G3 单元格输入汉字，点击“计算”  在G4 单元格得出该汉字笔画数。

汉字笔画计算程序.rar (18.03 KB, 下载次数: 438)

2018-9-27 22:55 上传

点击文件名下载附件

02761752696

谢谢   分享

xiangyun@

挺有意思的

zopey

word2007 中测试：
  
.Selection.ShapeRange.Ungroup.Select  
执行到这一句"取消组合" 报错；

改“分解图片”功能可以拆分出笔画，但是录制的宏与上面相同。
求 word2007 分解图片的 有效vba 代码。

zopey

1、取消组合
Selection.ShapeRange.Ungroup.Select

2、分解图片
WordBasic.DrawDisassemblePicture

经个人调试，1替换为2 ，则office 2007 也可以正常执行代码了。
详见附件 ，欢迎测试。

汉字笔画v1.3.zip (30.51 KB, 下载次数: 214)

2018-9-28 14:32 上传

点击文件名下载附件

zopey

给笔画填充颜色，自然序号i 是乱的， 并不是书写该汉字的笔画顺序 。

Sub test()
m = ActiveSheet.Shapes.Count
For i = 3 To m - 1
   ActiveSheet.Shapes(i).Select
   Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 0, 0)
Next
End Sub

YZC51

谢谢老师！学习下
Sub 按钮110_Click()
    m = ActiveSheet.Shapes.Count
    For i = m To 1 Step -1
       If ActiveSheet.Shapes(i).Type <> 8 Then ActiveSheet.Shapes(i).Delete
    Next
    Dim s As String
    s = [g3].Value
    Dim wordapp As Object
    Set wordapp = CreateObject("word.application")
    With wordapp
        .documents.Add
        '.Visible = 1
        .ActiveDocument.Shapes.AddTextEffect(msoTextEffect1, s, "楷体_GB2312", 150#, msoFalse, msoFalse, 66#, 80).Select
        'DoEvents
        With .Selection
             .Cut
             .PasteSpecial DataType:=3
        End With
        .ActiveDocument.Shapes(1).Select
        .WordBasic.DrawDisassemblePicture
        .Selection.Copy
        .ActiveDocument.Close False
    End With
    ActiveSheet.[f7].Select
    ActiveSheet.Paste
    m = ActiveSheet.Shapes.Count
    ActiveSheet.[g4].Select
    ActiveSheet.[g4].Value = m - 3
    wordapp.Quit SaveChanges:=wdDoNotSaveChanges
    Set wordapp = Nothing
    m = ActiveSheet.Shapes.Count
    For i = 3 To m - 1
       ActiveSheet.Shapes(i).Select
       Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 0, 0)        ActiveSheet.[f1].Select
       Application.Wait (Now + TimeValue("0:00:01"))
    Next
    ActiveSheet.[f1].Select

End Sub

zopey

YZC51 发表于 2018-9-28 19:18
谢谢老师！学习下
Sub 按钮110_Click()
    m = ActiveSheet.Shapes.Count

其实后面还有 2大难题，笔画的 先后顺序、书写方向。
我是一点 思路没有。

YZC51

谢谢老师分享，俺坚信老师一定会有办法的！

aman1516

zopey 发表于 2018-9-28 19:28
其实后面还有 2大难题，笔画的 先后顺序、书写方向。
我是一点 思路没有。

或是最让人放心的汉字笔画序库
http://club.excelhome.net/thread-649531-1-1.html