如何用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解方程。
附
真遗憾，自己回答自己，不完善的程序
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
需要编辑菜单，添加picturebox（pic），
