Word VBA生成方格纸

在Word中用VBA生成方格纸的代码如下:

Sub DrawFangGeZhi() '画方格纸
    Dim i As Integer, HengX As Integer, ShuX As Integer
                      '横线数,竖线数
    Dim arr  '所有线名称的数组
    Dim Begin_x As Single, Begin_y As Single
    Dim XianTiaoJiShu As Integer    '线条计数
    Dim strTemp As String  '获取输入的值
    Dim Reg As Object, mh As Object
    Dim GeKuan As Single  '格子宽度
    
    Set Reg = CreateObject("vbscript.regexp")
    Reg.Pattern = "(\d+)\D+(\d+)"
    
    strTemp = InputBox("请输入需要的方格的宽与高(如8,6表示8×6):", , "20,20")
    If Len(strTemp) = 0 Then
        MsgBox "您没有输入数量,程序将退出."
        Exit Sub
    Else
        If Reg.test(strTemp) = False Then
            MsgBox "您输入的数量有误,程序将退出."
            Set Reg = Nothing
            Exit Sub
        End If
    End If
    
    Application.ScreenUpdating = False
    GeKuan = 0.5
    Set mh = Reg.Execute(strTemp)
    HengX = mh(0).submatches(1)
    ShuX = mh(0).submatches(0)
    Begin_x = Selection.Information(wdHorizontalPositionRelativeToPage)  '返回所选内容的水平位置
    Begin_y = Selection.Information(wdVerticalPositionRelativeToPage)  '返回所选内容的垂直位置
    
    ReDim arr(1 To HengX + ShuX + 2)
    
    XianTiaoJiShu = 1
    For i = 0 To ShuX  '画竖线
        With ActiveDocument.Shapes.AddLine(Begin_x + i * CentimetersToPoints(GeKuan), Begin_y, _
            Begin_x + i * CentimetersToPoints(GeKuan), Begin_y + HengX * CentimetersToPoints(GeKuan))
            arr(XianTiaoJiShu) = .Name
            XianTiaoJiShu = XianTiaoJiShu + 1
            .Line.ForeColor = wdBlack
            .Line.Weight = 0.5
            .Line.DashStyle = msoLineDash
        End With
    Next
    
    For i = 0 To HengX '画横线
        With ActiveDocument.Shapes.AddLine(Begin_x, Begin_y + i * CentimetersToPoints(GeKuan), _
            Begin_x + ShuX * CentimetersToPoints(GeKuan), Begin_y + i * CentimetersToPoints(GeKuan))
            arr(XianTiaoJiShu) = .Name
            XianTiaoJiShu = XianTiaoJiShu + 1
            .Line.ForeColor = wdBlack
            .Line.Weight = 0.5
            .Line.DashStyle = msoLineDash
        End With
    Next
    
    ActiveDocument.Shapes.Range(arr).Select
    Selection.ShapeRange.Group
    Set Reg = Nothing
    Application.ScreenUpdating = True
End Sub