Word Vba生成除法竖式

word文档内容如下：

27031/9=

2563÷48=

25637/48=

25/5=

说明:把光标放在除法算式的那一行,运行宏ChuFaShuShi即可生成除法算式,目前只支持每行一个除法算式

具体代码如下：

Sub DrawLine(Qd_x As Single, Qd_y As Single, Cd As Single) '画直线
    Dim shpLine As Shape
    Set shpLine = ActiveDocument.Shapes.AddLine(Qd_x, Qd_y, Qd_x + Cd, Qd_y)
'BeginX 必选 Single 直线起点相对于绘图画布的水平位置（以磅为单位）。
'BeginY 必选 Single 直线起点相对于绘图画布的垂直位置（以磅为单位）。
'EndX 必选 Single 直线终点相对于绘图画布的水平位置（以磅为单位）。
'EndY 必选 Single 直线终点相对于绘图画布的垂直位置（以磅为单位）。
    With shpLine.Line
        .ForeColor = wdBlack
    End With
End Sub

Sub ChuHao(Qd_x As Single, Qd_y As Single, Cd As Single) '画竖式除号
    'Qd_x为起点坐标x,Qd_y为起点坐标y,Cd为除号上面的线的长度
    Dim pts(1 To 7, 1 To 2) As Single
    Dim Ch As Shape  '除号
    pts(1, 1) = Qd_x - 5         '第1个点的X坐标
    pts(1, 2) = Qd_y + 20       '第1个点的Y坐标
     
    pts(2, 1) = Qd_x       '第2个点的X坐标
    pts(2, 2) = Qd_y + 10
    pts(3, 1) = Qd_x     '第3个点的X坐标
    pts(3, 2) = Qd_y + 10  '2,3两点为控制点
     
    pts(4, 1) = Qd_x
    pts(4, 2) = Qd_y
    
    pts(5, 1) = Qd_x + Cd / 2
    pts(5, 2) = Qd_y
    
    pts(6, 1) = Qd_x + Cd / 2
    pts(6, 2) = Qd_y
    
    pts(7, 1) = Qd_x + Cd
    pts(7, 2) = Qd_y
 
    Set Ch = ActiveDocument.Shapes.AddCurve(SafeArrayOfPoints:=pts)
    With Ch.Line
        .ForeColor = wdBlack
    End With
End Sub

Function 取段数(Rng As Range) As Long
    取段数 = ActiveDocument.Range(Start:=ActiveDocument.Range.Start, End:=Rng.Paragraphs.First.Range.End).Paragraphs.Count
End Function

Sub ChuFaShuShi()
    Dim Rng As Range
    Dim DhHeng As Integer '横式所在的段号
    Dim HengTemp As Long  '横式位置
    Dim DhShuE As Integer '竖式最后一行的段号
    Dim FontSize As Single '字号
    Dim x As Single, y As Single '横式的水平与垂直位置
    Dim Arr
    Dim Shang As Integer '商
    Dim ShangStr As String
    Dim BcsLen As Integer, ShangLen As Integer '被除数长度,商长度
    Dim Ji As Integer, Yushu As Integer, ChuShu As Integer '商的某一位与除数的积,余数,除数
    Dim i As Integer, j As Integer
    Dim Hxcd As Single  '横线长度
    Dim p As Single 'Tab位置
    
    FontSize = Selection.Range.Font.Size
    DhHeng = 取段数(Selection.Range)
    With ActiveDocument.Paragraphs(DhHeng).Range
        HengTemp = .Start
        Call Selection.SetRange(HengTemp, HengTemp)
        
    End With
    With ActiveDocument.Paragraphs
        If .Count = DhHeng Then .Parent.Range.InsertAfter vbCr
    End With
    Dim Dqdh As Integer  '当前段号

    Do
        Dqdh = DhHeng
        With Selection.Find
            .ClearFormatting
            .Text = "[0-9]{1,}[/÷][0-9]{1,}"
            .MatchWildcards = True
            If .Execute = False Then Exit Do
            If Selection.Range.Start > ActiveDocument.Paragraphs(DhHeng).Range.End Then Exit Do
            If InStr(Selection.Range.Text, "÷") > 0 Then
                Arr = VBA.Split(Selection.Range.Text, "÷")
            Else
                Arr = VBA.Split(Selection.Range.Text, "/")
            End If
            If CInt(Arr(0)) < CInt(Arr(1)) Then Exit Do
            x = Selection.Information(wdHorizontalPositionRelativeToPage)  '返回所选内容的水平位置
            y = Selection.Information(wdVerticalPositionRelativeToPage)  '返回所选内容的垂直位置
        End With
            
        With ActiveDocument
            Shang = Int(Arr(0) / Arr(1))
            ShangStr = CStr(Shang)
            ShangLen = Len(ShangStr)
            BcsLen = Len(Arr(0))
            .Paragraphs(DhHeng).Range.InsertAfter InsertTab(Shang) & vbCr
            Dqdh = Dqdh + 1
            .Paragraphs(Dqdh).Range.InsertAfter InsertTab(Arr(1) & Arr(0)) & vbCr
            
            Set Rng = .Paragraphs(DhHeng + 1).Range
'            Rng.ParagraphFormat.TabStops.ClearAll
            YouDuiQi Rng, BcsLen + Len(Arr(1))
            
            Set Rng = .Paragraphs(DhHeng + 2).Range
'            Rng.ParagraphFormat.TabStops.ClearAll
            YouDuiQi Rng, BcsLen + Len(Arr(1))
            
            ChuShu = CInt(Arr(1))
            i = 1
            Do
                If i > ShangLen Then Exit Do
                Ji = CInt(Mid(ShangStr, i, 1)) * ChuShu
                .Paragraphs(Dqdh + 1).Range.InsertAfter InsertTab(Ji) & vbCr
                '插入某一位商与除数的积
                
                Set Rng = .Paragraphs(Dqdh + 2).Range
                YouDuiQi Rng, BcsLen + Len(Arr(1)) - ShangLen + i
                
                Do While i < ShangLen And Mid(ShangStr, i + 1, 1) = "0"
                     i = i + 1
                Loop
                Yushu = (CInt(Mid(Arr(0), 1, BcsLen - ShangLen + i)) Mod ChuShu) & Mid(Arr(0), BcsLen - ShangLen + i + 1, 1)
                .Paragraphs(Dqdh + 2).Range.InsertAfter InsertTab(Yushu) & vbCr
                
                Set Rng = .Paragraphs(Dqdh + 3).Range
                If i < ShangLen Then
                    YouDuiQi Rng, BcsLen + Len(Arr(1)) - ShangLen + i + 1
                Else
                    YouDuiQi Rng, BcsLen + Len(Arr(1)) - ShangLen + i
                End If
                Dqdh = Dqdh + 2
                i = i + 1
            Loop
            
            Dqdh = Dqdh + 1
            
            Set Rng = .Range(.Paragraphs(DhHeng + 1).Range.Start, .Paragraphs(Dqdh).Range.End)
            Rng.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
            Rng.ParagraphFormat.LineSpacing = 20
        
            
            Dim t As Integer
            t = .Paragraphs(DhHeng + 2).Range.End - BcsLen * 2
            Set Rng = .Range(t, t + 1)
            x = Rng.Information(wdHorizontalPositionRelativeToPage)  '返回所选内容的水平位置
            y = Rng.Information(wdVerticalPositionRelativeToPage)  '返回所选内容的垂直位置
            ChuHao x - FontSize / 2, y, FontSize * 1.5 * Len(Arr(0))
            
            For i = DhHeng + 4 To Dqdh Step 2
                Set Rng = .Paragraphs(i).Range
                y = Rng.Information(wdVerticalPositionRelativeToPage)  '返回所选内容的垂直位置
                DrawLine x - FontSize / 2, y, FontSize * 1.5 * Len(Arr(0))
            Next
        End With
        
        
        With Selection
            Call .SetRange(.Range.End, .Range.End)
        End With
    Loop

    
End Sub
Function InsertTab(ByVal str As String) As String '在每个字符前插入Tab字符
    Dim tempStr As String, i As Integer
    tempStr = ""
    For i = 1 To Len(str)
        tempStr = tempStr & vbTab & Mid(str, i, 1)
    Next
    InsertTab = tempStr
End Function
Sub YouDuiQi(Rng As Range, ByVal x As Integer) '与第几个右对齐
    Dim p As Single, FontSize As Single, RngLen As Integer
    
    RngLen = (Len(Rng.Text) - 1) / 2
    FontSize = Rng.Font.Size
    Rng.ParagraphFormat.TabStops.ClearAll
    For i = 1 To RngLen
        p = FontSize * 1.5 * (x - RngLen + i) - FontSize
        Rng.ParagraphFormat.TabStops.Add position:=p, Alignment:= _
            wdAlignTabCenter, Leader:=wdTabLeaderSpaces
    Next

End Sub