如何用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解方程。

附

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

3条回答

采纳
码龄粉丝数

被点赞

被采纳

采纳率

私信
qq_27976105 5年前
真遗憾，自己回答自己，不完善的程序

点赞评论复制链接分享
采纳
码龄粉丝数

被点赞

被采纳

采纳率

私信
qq_27976105 5年前
需要编辑菜单，添加picturebox（pic），

点赞评论复制链接分享
采纳
码龄粉丝数

被点赞

被采纳

采纳率

私信
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
点赞评论复制链接分享

提交

为你推荐

如何用vb实现类似word插入形状-曲线的功能？
- 3个回答