qq_27976105
qq_27976105
采纳率100%
2016-09-05 09:25

如何用vb实现类似word插入形状-曲线的功能?

已采纳

描述:外观
在PictureBox绘图,mousedown记录下点坐标(x0,y0),(x1,y1),(x2,y2)。。。(xn+1,yn+1)。
三次样条插值对散点进行拟合。
查得求解样条插值函数的三弯矩方法如下:图片说明

问题!!定义了single,但是数组输出1

 Dim a(10) As Single, b(10) As Single, h(10) As Single, lan(10) As Single, v(10) As Single, d(10) As Single
Dim i As Integer

Private Sub Form_Load()
a(0) = 4: a(1) = 4.35: a(2) = 4.57: a(3) = 4.76: a(4) = 5.26: a(5) = 5.88
b(0) = 4.18: b(1) = 5.77: b(2) = 6.58: b(3) = 6.24: b(4) = 4.9: b(5) = 4.76

For i = 1 To 5
h(i - 1) = a(i) - a(i - 1)
v(i) = h(i - 1) * (h(i - 1) + h(i)) ^ (-1)
lan(i) = 1 - v(i)
  On Error Resume Next
d(i) = 6 * ((b(i + 1) - b(i)) / h(i) - (b(i) - b(i - 1)) / h(i - 1)) / (h(i - 1) + h(i))
   On Error Resume Next
Next i

End Sub

Private Sub Form_Click()
For i = 1 To 4

Print a(i); b(i); h(i); h(i - 1) / ((h(i - 1) + h(i))); v(i); lan(i); d(i)
Print
Next i


End Sub

图片说明
放了5个定点想要试一下,但不会用excel解方程。

转自马语者博客-三次样条插值-excel,word,cad形状

  • 点赞
  • 写回答
  • 关注问题
  • 收藏
  • 复制链接分享
  • 邀请回答

3条回答

  • qq_27976105 qq_27976105 5年前

    真遗憾,自己回答自己,不完善的程序

    点赞 评论 复制链接分享
  • qq_27976105 qq_27976105 5年前

    需要编辑菜单,添加picturebox(pic),图片说明图片说明

    点赞 评论 复制链接分享
  • qq_27976105 qq_27976105 5年前

    Private Declare Function PolyBezier Lib "gdi32" (ByVal hdc As Long, lppt As POINTAPI, ByVal cPoints As Long) As Long

    Private Type vbPoint
    X As Single
    Y As Single
    End Type

    Private Type POINTAPI
    M As Long
    n As Long
    End Type

    Dim pA(3) As POINTAPI
    Dim dpStep As Integer

    Private Type ArcPara
    x0 As Double
    y0 As Double
    r As Double
    strA As Double
    endA As Double
    End Type

    Const Pi = 3.1415926

    Dim u1(0 To 80000) As Single, v1(0 To 80000) As Single
    Dim num As Long, t As Integer, de As Integer, ToInit As Boolean
    Dim DownX As Single, DownY As Single
    Dim XA(1000) As Single, YA(1000) As Single

    Dim DIndex As Integer, MIndex As Integer, vbP2() As vbPoint, mArcP As ArcPara
    Dim vbp() As vbPoint, Flag As Boolean, Prec(1) As vbPoint, Psou(1) As vbPoint

    Private Sub Form_Load()
    Dim i As Integer
    t = 30
    Randomize Timer
    For i = 0 To t
    XA(i) = Rnd(1) * 500 + Rnd(1) * 50 + 12
    YA(i) = Rnd(1) * 400 + Rnd(1) * 100 + 12
    Next i

    For i = 0 To t
    XA(i) = i * 30 + 20
    YA(i) = i * 20 + 20
    Next i
    ReDim vbp(0)
    Flag = False
    DIndex = 1
    MIndex = 0

    ScaleMode = vbPixels

    End Sub
    Sub tspLine(ByVal n As Integer, ByVal ch As Integer, ByVal tx1 As Single, ByVal tx2 As Single, ByVal ty1 As Single, ByVal ty2 As Single)
    Dim a(1000) As Single, b(1000) As Single, c(1000) As Single, dX(1000) As Single, dY(1000) As Single
    Dim qx(1000) As Single, qy(1000) As Single
    Dim tt As Single, bx3 As Single, bx4 As Single, by3 As Single, by4 As Single
    Dim cx As Single, cy As Single, t(1000) As Single, px(1000) As Single, py(1000) As Single
    Dim u(3000) As Single, v(3000) As Single, i As Integer
    num = 0
    For i = 1 To n
    t(i) = hypot(XA(i) - XA(i - 1), YA(i) - YA(i - 1))
    Next i
    Select Case ch
    Case 2 '自由条件
    a(0) = 2: c(0) = 1
    dX(0) = 3 * (XA(1) - XA(0)) / t(1): dY(0) = 3 * (YA(1) - YA(0)) / t(1)
    a(n) = 2: b(n) = 1
    dX(n) = 3 * (XA(n) - XA(n - 1)) / t(n): dY(n) = 3 * (YA(n) - YA(n - 1)) / t(n)
    End Select

    '计算方程组系数阵和常数阵
    For i = 1 To n - 1
    a(i) = 2 * (t(i) + t(i + 1)): b(i) = t(i + 1): c(i) = t(i)
    dX(i) = 3 * (t(i) * (XA(i + 1) - XA(i)) / t(i + 1) + t(i + 1) * (XA(i) - XA(i - 1)) / t(i))
    dY(i) = 3 * (t(i) * (YA(i + 1) - YA(i)) / t(i + 1) + t(i + 1) * (YA(i) - YA(i - 1)) / t(i))
    Next i

    '采用追赶法解方程组
    c(0) = c(0) / a(0)
    For i = 1 To n - 1
    a(i) = a(i) - b(i) * c(i - 1): c(i) = c(i) / a(i)
    Next i
    a(n) = a(n) - b(n) * c(i - 1)
    qx(0) = dX(0) / a(0): qy(0) = dY(0) / a(0)
    For i = 1 To n
    qx(i) = (dX(i) - b(i) * qx(i - 1)) / a(i)
    qy(i) = (dY(i) - b(i) * qy(i - 1)) / a(i)
    Next i
    px(n) = qx(n): py(n) = qy(n)
    For i = n - 1 To 0 Step -1
    px(i) = qx(i) - c(i) * px(i + 1)
    py(i) = qy(i) - c(i) * py(i + 1)
    Next i
    '计算曲线上点的坐标
    For i = 0 To n - 1
    bx3 = (3 * (XA(i + 1) - XA(i)) / t(i + 1) - 2 * px(i) - px(i + 1)) / t(i + 1)
    bx4 = ((2 * (XA(i) - XA(i + 1)) / t(i + 1) + px(i) + px(i + 1)) / t(i + 1)) / t(i + 1)
    by3 = (3 * (YA(i + 1) - YA(i)) / t(i + 1) - 2 * py(i) - py(i + 1)) / t(i + 1)
    by4 = ((2 * (YA(i) - YA(i + 1)) / t(i + 1) + py(i) + py(i + 1)) / t(i + 1)) / t(i + 1)
    tt = 0
    While (tt <= t(i + 1))
    cx = XA(i) + (px(i) + (bx3 + bx4 * tt) * tt) * tt
    cy = YA(i) + (py(i) + (by3 + by4 * tt) * tt) * tt
    u1(num) = cx: v1(num) = cy: num = num + 1: tt = tt + 0.5
    Wend
    u1(num) = XA(i + 1): v1(num) = YA(i + 1): num = num + 1
    Next i
    End Sub

    Private Sub Pic_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 Then
    If DIndex = 0 Then
    Prec(0).X = X: Prec(0).Y = Y
    Else
    If MIndex < 4 Then
    ReDim vbP2(1)
    Pic.DrawMode = vbNotXorPen

                vbP2(0).X = X: vbP2(0).Y = Y
                Draw
            ElseIf MIndex = 4 Then
    
                Static i As Integer
                vbP2(i).X = X: vbP2(i).Y = Y
                i = i + 1
               If i = 3 Then
                    i = 0
                    Draw
                End If
                ElseIf MIndex = 5 Then
                  Dim p As POINTAPI
                    Pic.DrawMode = vbNotMergePen
                  dpStep = dpStep + 1
    
                If dpStep = 1 Then
                    pA(0).M = X / 15
                    pA(0).n = Y / 15
                    pA(1).M = X / 15
                    pA(1).n = Y / 15
                    pA(2).M = X / 15
                    pA(2).n = Y / 15
                    pA(3).M = X / 15
                    pA(3).n = Y / 15
                End If
            ElseIf MIndex = 6 Then
    
               Static c As Integer, z As Integer
                XA(c) = X: YA(c) = Y
                c = c + 1
    
    
               If (c = 1000) Or (Shift = 2) Then
    
               c = 0
    

    'XA,YA清除

               End If
    
            End If
        End If
    End If
    

    End Sub

    Private Sub Pic_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim Temp As Single, p As vbPoint, i As Long
    If Button = vbLeftButton Then
    If DIndex = 1 Then
    If MIndex < 4 Then
    Draw
    vbP2(1).X = X: vbP2(1).Y = Y
    Pic.DrawMode = vbCopyPen '将Pic的绘画模式改为复制笔画
    Draw
    ElseIf MIndex = 5 Then
    Pic.DrawMode = vbNotMergePen

                    If dpStep > 0 Then
                    dpStep = dpStep Mod 4
                    End If
                ElseIf MIndex = 6 Then
                 On Error Resume Next
                    Pic.Cls
               DownX = X: DownY = Y   'fuzhi
               Dim J As Long
                            For J = 0 To t - 1
                              Pic.Line (XA(J) - 1, YA(J) - 1)-(XA(J) + 1, YA(J) + 1), QBColor(10), B
                              Pic.Print J
                            Next J
                            tspLine t - 1, 2, 0, 0, 0, 0
                            Pic.PSet (u1(0), v1(0))
                              For J = 1 To num - 1
                               Pic.Line -(u1(J), v1(J))
                              Next J
                    End If
         End If
       End If
    

    End Sub

    Private Sub Pic_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 Then
    If DIndex = 1 Then
    If MIndex < 4 Then
    Draw
    vbP2(1).X = X: vbP2(1).Y = Y
    Draw

              ElseIf MIndex = 5 Then
    
            Dim fColor As OLE_COLOR
            Select Case dpStep
            Case 1
    
    
         fColor = vbBlue
        PolyBezier Pic.hdc, pA(0), 4
        pA(1).M = X / 15
        pA(1).n = Y / 15
        pA(2).M = X / 15
        pA(2).n = Y / 15
        pA(3).M = X / 15
        pA(3).n = Y / 15
    
           fColor = vbBlue
        PolyBezier Pic.hdc, pA(0), 4
    
    Case 2
    
        fColor = vbBlue
    
        PolyBezier Pic.hdc, pA(0), 4
         pA(1).M = X / 15
        pA(1).n = Y / 15
        pA(2).M = X / 15
        pA(2).n = Y / 15
           ForeColor = vbBlue
        PolyBezier Pic.hdc, pA(0), 4
    
    Case 3
    fColor = vbBlue
    
        PolyBezier Pic.hdc, pA(0), 4
        pA(1).M = X / 15
        pA(1).n = Y / 15
        ForeColor = vbBlue
        PolyBezier Pic.hdc, pA(0), 4
    
    
    End Select
    
    
    
    
    
            End If
        End If
    

    End If
    Pic.ToolTipText = "(" & X & ", " & Y & ")"
    End Sub

    Private Function vbSelect(p As vbPoint) As Integer
    For i = 0 To UBound(vbp) - 1
    If (vbp(i).X <> 0 And vbp(i).Y <> 0) And (vbp(i + 1).X <> 0 And vbp(i + 1).Y <> 0) Then
    If vbCheck(vbDis(vbp(i), p), vbDis(p, vbp(i + 1)), vbDis(vbp(i), vbp(i + 1)), 0.01) Then
    vbSelect = i + 1 '返回选择的线条的索引号
    Exit For
    Else
    vbSelect = -1 '返回初始值
    End If
    Else
    vbSelect = -1 '返回初始值
    End If
    Next i
    End Function

    Private Function vbDis(P1 As vbPoint, P2 As vbPoint) As Double
    vbDis = Sqr((P1.X - P2.X) ^ 2 + (P1.Y - P2.Y) ^ 2) '长度计算
    End Function

    Private Function vbCheck(a As Double, b As Double, c As Double, JD As Double) As Boolean
    '长度A B C ,精度JD
    If a + b > c * (1 - Abs(JD)) And a + b < c * (1 + Abs(JD)) Then
    vbCheck = True
    Else
    vbCheck = False
    End If
    End Function

    Private Sub vbD_Click(Index As Integer)
    For i = 0 To 1
    vbD(i).Checked = False
    Next i
    vbD(Index).Checked = True
    DIndex = Index
    End Sub

    Private Sub vbDel_Click()
    If Pic.Tag <> "-1" Then
    On Error Resume Next
    Unload Line1(Val(Pic.Tag))
    Pic.Tag = -1
    End If
    End Sub

    Private Sub vbM_Click(Index As Integer)
    For i = 0 To vbM.UBound
    vbM(i).Checked = False
    Next i
    vbM(Index).Checked = True
    MIndex = Index
    Select Case Index
    Case Is < 4
    ReDim vbP2(1)
    Case 4 '圆弧
    ReDim vbP2(2)
    End Select
    End Sub

    Private Function vbTrim(vbStr As String, ByRef p As vbPoint) As Boolean
    Dim Arr() As String '定义数组,以分割坐标
    vbTrim = False
    vbStr = Replace(Replace(vbStr, "PU", ""), "PD", "") '去掉PU或PD
    Arr = Split(vbStr, " ") '提取坐标数据
    p.X = Val(Arr(0)) '将坐标赋给参数
    p.Y = Val(Arr(1))
    vbTrim = True '返回真
    End Function

    Private Function vbCheck2(vbp() As vbPoint, i As Long) As Boolean
    vbCheck2 = False
    If i < UBound(vbp) Then
    If Not (vbp(i).X = 0 And vbp(i).Y = 0 And vbp(i + 1).X = 0 And vbp(i + 1).Y = 0) Then '如果本身和后面一个不全为空坐标
    vbCheck2 = True '返回真
    Else
    vbCheck2 = False '返回假
    End If
    Else
    vbCheck2 = True '返回真
    End If
    End Function
    Function hypot(ByVal X As Single, ByVal Y As Single)
    hypot = Sqr(X ^ 2 + Y ^ 2)
    End Function

    Private Sub vbQuit_Click()
    End
    End Sub

    Private Sub Draw()
    Dim i As Integer, J As Integer, r As Integer
    Select Case MIndex
    Case 0 '直线
    Pic.Line (vbP2(0).X, vbP2(0).Y)-(vbP2(1).X, vbP2(1).Y), vbColor
    Case 1 '矩形
    Pic.Line (vbP2(0).X, vbP2(0).Y)-(vbP2(1).X, vbP2(1).Y), vbColor, B
    Case 2 '圆
    i = vbP2(1).X - vbP2(0).X: J = vbP2(1).Y - vbP2(0).Y
    r = Abs(IIf(Abs(i) < Abs(J), i, J)) / 2
    Pic.Circle (vbP2(0).X + r * Sgn(i), vbP2(0).Y + r * Sgn(J)), r, vbColor
    Case 3 '椭圆
    i = vbP2(1).X - vbP2(0).X: J = vbP2(1).Y - vbP2(0).Y
    If i <> 0 And J <> 0 Then
    Pic.Circle (vbP2(0).X + i / 2, vbP2(0).Y + J / 2), Abs(IIf(Abs(i) > Abs(J), i, J)) / 2, vbColor, , , Abs(J) / Abs(i)
    Else
    Pic.Line (vbP2(0).X, vbP2(0).Y)-(vbP2(1).X, vbP2(1).Y), vbColor
    End If
    Case 4 '圆弧
    On Error Resume Next
    Call DrawArc(CalArc(vbP2))

    End Select
    

    End Sub

    '画圆弧中计算角度的函数
    Private Function CaleAngle(ByVal ax As Double, ByVal ay As Double, ByVal ox As Double, ByVal oy As Double) As Double
    Dim afa As Double
    ax = ax - ox
    ay = ay - oy
    If ax < 0.000001 And ax > -0.000001 Then
    If ay > 0 Then
    CaleAngle = Pi / 2#
    Else
    CaleAngle = Pi * 1.5
    End If
    Else
    afa = Atn(ay / ax)
    If ax < 0 Then
    afa = afa + Pi
    End If
    If afa < 0 Then
    afa = afa + Pi * 2#
    End If
    CaleAngle = afa
    End If
    End Function

    Private Function CalArc(vbPointA() As vbPoint) As ArcPara
    Dim x1 As Single
    Dim y1 As Single
    Dim dx1 As Single
    Dim dy1 As Single
    Dim x2 As Single
    Dim y2 As Single
    Dim dx2 As Single
    Dim dy2 As Single
    Dim dX As Single
    Dim dY As Single
    Dim af As Double, bt As Double, gama As Double '三个角度
    '得到第一点和第二点的中点和斜率
    x1 = (vbPointA(1).X + vbPointA(0).X) / 2
    y1 = (vbPointA(1).Y + vbPointA(0).Y) / 2
    dy1 = vbPointA(1).X - vbPointA(0).X
    dx1 = -(vbPointA(1).Y - vbPointA(0).Y)
    ' 得到第一点和第三点的中点和斜率
    x2 = (vbPointA(2).X + vbPointA(1).X) / 2
    y2 = (vbPointA(2).Y + vbPointA(1).Y) / 2
    dy2 = vbPointA(2).X - vbPointA(1).X
    dx2 = -(vbPointA(2).Y - vbPointA(1).Y)
    ' 求圆心
    CalArc.x0 = (y1 * dx1 * dx2 + x2 * dx1 * dy2 - x1 * dy1 * dx2 - y2 * dx1 * dx2) _
    / (dx1 * dy2 - dy1 * dx2)
    CalArc.y0 = (CalArc.x0 - x1) * dy1 / dx1 + y1
    '求半径
    dX = CalArc.x0 - vbPointA(0).X
    dY = CalArc.y0 - vbPointA(0).Y
    CalArc.r = Sqr(dX * dX + dY * dY)

    '求每个点与x轴正向的夹角
    af = CaleAngle(vbPointA(0).X, -vbPointA(0).Y, CalArc.x0, -CalArc.y0)
    bt = CaleAngle(vbPointA(1).X, -vbPointA(1).Y, CalArc.x0, -CalArc.y0)
    gama = CaleAngle(vbPointA(2).X, -vbPointA(2).Y, CalArc.x0, -CalArc.y0)
    
    If gama - af > 0 Then
        If (bt - af) * (bt - gama) > 0 Then
            CalArc.strA = gama: CalArc.endA = af
        Else
            CalArc.strA = af: CalArc.endA = gama
        End If
    Else
        If (bt - af) * (bt - gama) > 0 Then
            CalArc.strA = af: CalArc.endA = gama
        Else
            CalArc.strA = gama: CalArc.endA = af
        End If
    End If
    

    End Function

    Private Sub DrawArc(ArcP As ArcPara)
    Dim ArcStrX As Double
    Dim ArcStrY As Double
    Dim ArcNewX As Double
    Dim ArcNewY As Double
    Dim i As Double
    Dim GradArc As Double

    GradArc = Pi / 180
    ArcStrX = ArcP.r * Cos(ArcP.strA)
    ArcStrY = ArcP.r * Sin(ArcP.strA)
    ArcStrX = ArcStrX + ArcP.x0                                                 '坐标系的转换
    ArcStrY = ArcP.y0 - ArcStrY
    If ArcP.strA < ArcP.endA Then
        For i = ArcP.strA To ArcP.endA Step GradArc
            If (ArcP.endA - i) < 0.000001 Then i = ArcP.endA
            ArcNewX = ArcP.r * Cos(i)
            ArcNewY = ArcP.r * Sin(i)
            ArcNewX = ArcNewX + ArcP.x0
            ArcNewY = ArcP.y0 - ArcNewY                                         '坐标系的转换
            Pic.DrawWidth = 1
            Pic.Line (ArcStrX, ArcStrY)-(ArcNewX, ArcNewY), vbColor
            ArcStrX = ArcNewX
            ArcStrY = ArcNewY
        Next i
    Else
        For i = ArcP.strA To 2 * Pi Step GradArc
            If (2 * Pi - i) < 0.000001 Then i = 2 * Pi
            ArcNewX = ArcP.r * Cos(i)
            ArcNewY = ArcP.r * Sin(i)
            ArcNewX = ArcNewX + ArcP.x0
            ArcNewY = ArcP.y0 - ArcNewY                                         '坐标系的转换
            Pic.DrawWidth = 1
            Pic.Line (ArcStrX, ArcStrY)-(ArcNewX, ArcNewY), vbColor
            ArcStrX = ArcNewX
            ArcStrY = ArcNewY
        Next i
        For i = 0 To ArcP.endA Step GradArc
            If (ArcP.endA - i) < 0.000001 Then i = ArcP.endA
            ArcNewX = ArcP.r * Cos(i)
            ArcNewY = ArcP.r * Sin(i)
            ArcNewX = ArcNewX + ArcP.x0
            ArcNewY = ArcP.y0 - ArcNewY                                         '坐标系的转换
            Pic.DrawWidth = 1
            Pic.Line (ArcStrX, ArcStrY)-(ArcNewX, ArcNewY), vbColor
            ArcStrX = ArcNewX
            ArcStrY = ArcNewY
        Next i
    End If
    

    End Sub

    Private Sub vbCls_Click(Index As Integer)
    Pic.Cls
    End Sub

    点赞 评论 复制链接分享