急﹗﹗﹗如何制作精美的曲線分析圖﹗

xysophie 2003-08-19 09:17:45

需要根据一組數据繪制曲線分析圖﹐
我以前沒做過
哪位高人能指點一下﹐最好有代碼﹐不胜感激﹗﹗﹗

...全文

152 10 打赏收藏转发到动态举报

写回复

用AI写文章

10 条回复

切换为时间正序

请发表友善的回复…

发表回复

xysophie 2003-08-25

打赏
举报

多謝樓上個位﹗﹗

lzqgj 2003-08-21

打赏
举报

我稍微修改了一下，可以连更多的点：
Private AX(100) As Single, AY(100) As Single, u1(4000) As Single, v1(4000) As Single
Dim num, nn As Integer
Function hypot(ByVal X As Single, ByVal Y As Single)
hypot = Sqr(X ^ 2 + Y ^ 2)
End Function

Private Sub Command1_Click()
DrawWidth = 3
For i = 0 To nn
Picture1.PSet (AX(i), AY(i))
Next i
DrawWidth = 1
tspLine nn - 1, 2, 0, 0, 0, 0
Picture1.PSet (u1(0), v1(0))
For i = 1 To num - 1
Picture1.Line -(u1(i), v1(i))
Next i
nn = 0
End Sub

Private Sub Command2_Click()
End
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(100) As Single, b(100) As Single, c(100) As Single, dx(100) As Single, dy(100) As Single
Dim qx(100) As Single, qy(100) 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(100) As Single, px(100) As Single, py(100) As Single
Dim u(3) As Single, v(3) As Single, i As Integer
num = 0
For i = 1 To n
t(i) = hypot(AX(i) - AX(i - 1), AY(i) - AY(i - 1))
Next i
Select Case ch
Case 0 '抛物条件
u(0) = (AX(1) - AX(0)) / t(1): u(1) = (AX(2) - AX(1)) / t(2)
u(2) = (u(1) - u(0)) / (t(2) + t(1))
tx1 = u(0) - u(2) * t(1)
u(0) = (AY(1) - AY(0)) / t(1): u(1) = (AY(2) - AY(1)) / t(2)
u(2) = (u(1) - u(0)) / (t(2) + t(1))
ty1 = u(0) - u(2) * t(1)
u(0) = (AX(n) - AX(n - 1)) / t(n): u(1) = (AX(n - 1) - AX(n - 2)) / t(n - 1)
u(2) = (u(0) - u(1)) / (t(n) + t(n - 1))
tx2 = u(0) + u(2) * t(n)
u(0) = (AY(n) - AY(n - 1)) / t(n): u(1) = (AY(n - 1) - AY(n - 2)) / t(n - 1)
u(2) = (u(0) - u(1)) / (t(n) + t(n - 1))
ty2 = u(0) + u(2) * t(n)
Case 1 '夹持条件
a(0) = 1: c(0) = 0: dx(0) = tx1: dy(0) = ty1
a(n) = 1: b(n) = 0: dx(n) = tx2: dy(n) = ty2
Case 2 '自由条件
a(0) = 2: c(0) = 1
dx(0) = 3 * (AX(1) - AX(0)) / t(1): dy(0) = 3 * (AY(1) - AY(0)) / t(1)
a(n) = 2: b(n) = 1
dx(n) = 3 * (AX(n) - AX(n - 1)) / t(n): dy(n) = 3 * (AY(n) - AY(n - 1)) / t(n)
Case 3 '循环条件
a(0) = 2: c(0) = 1
dx(0) = 3 * (AX(1) - AX(0)) / t(1) - (t(1) * (AX(2) - AX(1)) / t(2) - AX(1) + AX(0)) / (t(1) + t(2))
dy(0) = 3 * (AY(1) - AY(0)) / t(1) - (t(1) * (AY(2) - AY(1)) / t(2) - AY(1) + AY(0)) / (t(1) + t(2))
a(n) = 2: b(n) = 1
dx(n) = 3 * (AX(n) - AX(n - 1)) / t(n)
dx(n) = dx(n) + (AX(n) - AX(n - 1) - t(n) * (AX(n - 1) - AX(n - 2)) / t(n - 1)) / (t(n) + t(n - 1))
dy(n) = 3 * (AY(n) - AY(n - 1)) / t(n)
dy(n) = dy(n) + (AY(n) - AY(n - 1) - t(n) * (AY(n - 1) - AY(n - 2)) / t(n - 1)) / (t(n) + t(n - 1))
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) * (AX(i + 1) - AX(i)) / t(i + 1) + t(i + 1) * (AX(i) - AX(i - 1)) / t(i))
dy(i) = 3 * (t(i) * (AY(i + 1) - AY(i)) / t(i + 1) + t(i + 1) * (AY(i) - AY(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 * (AX(i + 1) - AX(i)) / t(i + 1) - 2 * px(i) - px(i + 1)) / t(i + 1)
bx4 = ((2 * (AX(i) - AX(i + 1)) / t(i + 1) + px(i) + px(i + 1)) / t(i + 1)) / t(i + 1)
by3 = (3 * (AY(i + 1) - AY(i)) / t(i + 1) - 2 * py(i) - py(i + 1)) / t(i + 1)
by4 = ((2 * (AY(i) - AY(i + 1)) / t(i + 1) + py(i) + py(i + 1)) / t(i + 1)) / t(i + 1)
tt = 0
While (tt <= t(i + 1))
cx = AX(i) + (px(i) + (bx3 + bx4 * tt) * tt) * tt
cy = AY(i) + (py(i) + (by3 + by4 * tt) * tt) * tt
u1(num) = cx: v1(num) = cy: num = num + 1: tt = tt + 0.5
Wend
u1(num) = AX(i + 1): v1(num) = AY(i + 1): num = num + 1
Next i
End Sub

Private Sub Form_Load()
Picture1.Scale (0, 0)-(640, 480)
nn = 0
End Sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
AX(nn) = X: AY(nn) = Y
Picture1.ForeColor = vbRed
Picture1.Circle (AX(nn), AY(nn)), 3
nn = nn + 1
If nn = 15 Then Call Command1_Click
End Sub

hxy2003 2003-08-20

打赏
举报

mschar

xysophie 2003-08-20

打赏
举报

to lzqgj﹕
我沒有做過﹐能詳細一點嗎?
分不夠可以另加﹐我挺著急的。
謝謝

lzqgj 2003-08-20

打赏
举报

用API函数——PolyBezier

lzqgj 2003-08-20

打赏
举报

http://www.vbnew.net/dn/index.asp?type=4有现成的只用VB画曲线的源码，很好。

lzqgj 2003-08-20

打赏
举报

Private Type POINTL
X As Long
Y As Long
End Type
Private Declare Function PolyBezier Lib "gdi32" (ByVal hdc As Long, lppt As POINTL, ByVal cPoints As Long) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private i
Private apt(0 To 6) As POINTL

Private Sub Form_Load()
Form1.ScaleMode = 3 '将单位设为象素
End Sub

Private Sub Form_Mousedown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If i <= 6 Then
apt(i).X = X '每个点的x坐标，可以换成自己的数据
apt(i).Y = Y
ForeColor = vbRed
Circle (X, Y), 2 '画出每个点
i = i + 1
End If
If i = 7 Then '点数必须为3n+1个才能画曲线，2n个控制点，n个终点，1个起点
PolyBezier Me.hdc, apt(0), 7 '包括7个点，可以添加，但apt(n)要对应
i = 0
End If
End Sub
以上方法可以根据在窗体上点击的坐标画出圆滑曲线，但不足之处是：
1、每4个点画一条曲线，仍然是不连续的，不过如果数据好，应该看不出明显变向
2、并不是所有点都在曲线上，因为中间两个点是控制点。要解决这问题，需要查看有关插入点的知识，我不会。http://210.76.98.83/lesson/0001/50137/Chapter3/31.htm有插值介绍。我的理解是每三点确定一条抛物线，然后根据它在每两点间再插入两点作为控制点，这样可保证曲线过每个点，并且基本圆滑。

xysophie 2003-08-20