真遗憾,自己回答自己,不完善的程序
如何用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
- 点赞
- 写回答
- 关注问题
- 收藏
- 复制链接分享
- 邀请回答
3条回答
-
采纳
点赞 评论 复制链接分享
-
采纳
需要编辑菜单,添加picturebox(pic),
点赞 评论 复制链接分享 -
采纳
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 TypePrivate Type POINTAPI
M As Long
n As Long
End TypeDim pA(3) As POINTAPI
Dim dpStep As IntegerPrivate Type ArcPara
x0 As Double
y0 As Double
r As Double
strA As Double
endA As Double
End TypeConst 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 SingleDim 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 vbPointPrivate 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 iFor i = 0 To t
XA(i) = i * 30 + 20
YA(i) = i * 20 + 20
Next i
ReDim vbp(0)
Flag = False
DIndex = 1
MIndex = 0ScaleMode = 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 SubPrivate 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 = vbNotXorPenvbP2(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 = vbNotMergePenIf 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
DrawElseIf 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 SubPrivate 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 FunctionPrivate Function vbDis(P1 As vbPoint, P2 As vbPoint) As Double
vbDis = Sqr((P1.X - P2.X) ^ 2 + (P1.Y - P2.Y) ^ 2) '长度计算
End FunctionPrivate 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 FunctionPrivate Sub vbD_Click(Index As Integer)
For i = 0 To 1
vbD(i).Checked = False
Next i
vbD(Index).Checked = True
DIndex = Index
End SubPrivate Sub vbDel_Click()
If Pic.Tag <> "-1" Then
On Error Resume Next
Unload Line1(Val(Pic.Tag))
Pic.Tag = -1
End If
End SubPrivate 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 SubPrivate 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 FunctionPrivate 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 FunctionPrivate Sub vbQuit_Click()
End
End SubPrivate 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 FunctionPrivate 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 DoubleGradArc = 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点赞 评论 复制链接分享