1、我現在需要提取下面B樣條曲線的程式，去掉Bezier曲線曲線的程式命令。
2、或者能直接寫一個小程式，提取400個資料點，然后光滑連接即可，資料點都是在光滑的曲線上的。
拜謝！
'在本例中，黑色的線條是對坐標系上各點的直接連線
'黃色的線僅對點間連線進行近似擬合，并不通過每一個點，使用的是B樣條曲線，貝茲曲線的一種一般化
'藍色的線通過除第一個點和最后一個點之外的每一個點，使用的是Bezier曲線，貝塞爾曲線
Option Explicit
Private Type Vi '定義點的資料結構
x As Double
y As Double
End Type
Dim Pts(64) As Vi, Ypts(64) As Double '用于Bezier繪制的臨時點坐標
Dim Points(3) As Vi, PointsB(3) As Vi
Dim Po(-1 To 100) As Vi
Dim CosNN(158) As Double '用于通過Cos值查表獲取角度
'Bezier計算
Private Sub calc_spline(Npts As Integer)
Dim x As Double, dx As Double, ddx As Double, dddx As Double
Dim y As Double, dy As Double, ddy As Double, dddy As Double
Dim i As Integer
Dim dt As Double, dt2 As Double, dt3 As Double
Dim xdt2_term As Double, xdt3_term As Double
Dim ydt2_term As Double, ydt3_term As Double
dt = 1# / (Npts - 1)
dt2 = (dt * dt)
dt3 = (dt2 * dt)
' x 坐標增量計算
xdt2_term = 3 * (Points(2).x - 2 * Points(1).x + Points(0).x)
xdt3_term = Points(3).x + 3 * (-Points(2).x + Points(1).x) - Points(0).x
xdt2_term = dt2 * xdt2_term
xdt3_term = dt3 * xdt3_term
dddx = 6 * xdt3_term
ddx = -6 * xdt3_term + 2 * xdt2_term
dx = xdt3_term - xdt2_term + 3 * dt * (Points(1).x - Points(0).x)
x = Points(0).x
Pts(0).x = Points(0).x
x = x + 0.5
For i = 1 To Npts
ddx = ddx + dddx
dx = dx + ddx
x = x + dx
Pts(i).x = x
Next i
' y 坐標增量計算
ydt2_term = 3 * (Points(2).y - 2 * Points(1).y + Points(0).y)
ydt3_term = Points(3).y + 3 * (-Points(2).y + Points(1).y) - Points(0).y
ydt2_term = dt2 * ydt2_term
ydt3_term = dt3 * ydt3_term
dddy = 6 * ydt3_term
ddy = -6 * ydt3_term + 2 * ydt2_term
dy = ydt3_term - ydt2_term + dt * 3 * (Points(1).y - Points(0).y)
y = Points(0).y
Pts(0).y = Points(0).y
y = y + 0.5
For i = 1 To Npts
ddy = ddy + dddy
dy = dy + ddy
y = y + dy
Pts(i).y = y
Next i
End Sub
'Bezier控制點計算
Private Sub DRC()
Dim Tem(3) As Vi, TemB As Double, JD(1) As Double, JDT(1) As Double, t As Double, t2(1) As Double
'Bezier端點賦值
Points(0).x = PointsB(1).x
Points(0).y = PointsB(1).y
Points(3).x = PointsB(2).x
Points(3).y = PointsB(2).y
'計算Bezier控制點位置
Tem(0).x = PointsB(1).x - PointsB(0).x
Tem(0).y = PointsB(1).y - PointsB(0).y
Tem(1).x = Tem(0).x / Sqr(Tem(0).x * Tem(0).x + Tem(0).y * Tem(0).y)
Tem(0).x = PointsB(2).x - PointsB(1).x
Tem(0).y = PointsB(2).y - PointsB(1).y
Tem(1).y = Tem(0).x / Sqr(Tem(0).x * Tem(0).x + Tem(0).y * Tem(0).y)
t2(0) = 1: t2(1) = 1
For t = 0 To 158
If t2(0) > Abs(Tem(1).x - CosNN(t)) Then
JDT(0) = t / 100
t2(0) = Abs(Tem(1).x - CosNN(t))
End If
If t2(1) > Abs(Tem(1).y - CosNN(t)) Then
JDT(1) = t / 100
t2(1) = Abs(Tem(1).y - CosNN(t))
End If
Next t
JD(0) = (Sgn(PointsB(0).y - PointsB(1).y) * JDT(0) + Sgn(PointsB(1).y - PointsB(2).y) * JDT(1)) / 2
'''''
Tem(0).x = PointsB(3).x - PointsB(2).x
Tem(0).y = PointsB(3).y - PointsB(2).y
Tem(1).x = Tem(0).x / Sqr(Tem(0).x * Tem(0).x + Tem(0).y * Tem(0).y)
Tem(0).x = PointsB(2).x - PointsB(1).x
Tem(0).y = PointsB(2).y - PointsB(1).y
Tem(1).y = Tem(0).x / Sqr(Tem(0).x * Tem(0).x + Tem(0).y * Tem(0).y)
t2(0) = 1: t2(1) = 1
For t = 0 To 158
If t2(0) > Abs(Tem(1).x - CosNN(t)) Then
JDT(0) = t / 100
t2(0) = Abs(Tem(1).x - CosNN(t))
End If
If t2(1) > Abs(Tem(1).y - CosNN(t)) Then
JDT(1) = t / 100
t2(1) = Abs(Tem(1).y - CosNN(t))
End If
Next t
JD(1) = (Sgn(PointsB(2).y - PointsB(3).y) * JDT(0) + Sgn(PointsB(1).y - PointsB(2).y) * JDT(1)) / 2 + 3.14
TemB = (PointsB(2).x - PointsB(1).x) / 2.82
'Bezier控制點賦值
Points(1).x = Cos(JD(0)) * TemB + PointsB(1).x
Points(1).y = -Sin(JD(0)) * TemB + PointsB(1).y
Points(2).x = Cos(JD(1)) * TemB + PointsB(2).x
Points(2).y = -Sin(JD(1)) * TemB + PointsB(2).y
spline (vbBlue)
End Sub
'Bezier繪制
Private Sub spline(color As Long)
Dim i As Integer
Dim C As Long
calc_spline (64)
picdraw.Scale (0, 300)-(200, 0)
For i = 1 To 63
picdraw.Line (Pts(i - 1).x, Pts(i - 1).y)-(Pts(i).x, Pts(i).y), color
Next i
picdraw.Line (Pts(i - 1).x, Pts(i - 1).y)-(Pts(i).x, Pts(i).y), color
End Sub
'Bezier呼叫
Private Sub B1(n As Integer, st As Double)
Dim t As Integer
For t = 0 To n - 4
PointsB(0).x = Po(t).x
PointsB(0).y = Po(t).y
PointsB(1).x = Po(t + 1).x
PointsB(1).y = Po(t + 1).y
PointsB(2).x = Po(t + 2).x
PointsB(2).y = Po(t + 2).y
PointsB(3).x = Po(t + 3).x
PointsB(3).y = Po(t + 3).y
DRC
Next t
End Sub
'B樣條曲線生成
Private Sub B2(n As Integer, st As Double)
Dim l As Double, x As Double, y As Double, x0 As Double, x1 As Double, x2 As Double, y0 As Double, y1 As Double, y2 As Double
Dim a As Integer
picdraw.Scale (0, 300)-(200, 0)
For a = 0 To n - 3
x0 = (Po(a).x + Po(a + 1).x) / 2#
x1 = Po(a + 1).x - Po(a).x
x2 = (Po(a).x - 2 * Po(a + 1).x + Po(a + 2).x) / 2#
y0 = (Po(a).y + Po(a + 1).y) / 2#
y1 = Po(a + 1).y - Po(a).y
y2 = (Po(a).y - 2 * Po(a + 1).y + Po(a + 2).y) / 2#
picdraw.PSet (x0, y0), vbYellow
For l = 0 To 1 Step st
x = x0 + x1 * l + x2 * l * l
y = y0 + y1 * l + y2 * l * l
picdraw.Line -(x, y), vbYellow
Next l
Next a
End Sub
Private Sub Command1_Click()
Dim dx As Integer, dy As Integer, t As Integer
picdraw.Cls
picdraw.Scale (0, 300)-(200, 0)
Po(-1).x = Rnd * 40
Po(-1).y = Rnd * 300
picdraw.PSet (Po(-1).x, Po(-1).y)
For t = 0 To 31
dx = Rnd * 40
dy = Rnd * 300
Po(t).x = Po(t - 1).x + dx
Po(t).y = dy
picdraw.Line -(Po(t).x, Po(t).y)
Next
Call B2(30, 0.1)
Call B1(30, 0)
End Sub
Private Sub Command2_Click()
Unload Me
End Sub
Private Sub Command3_Click()
picdraw.Cls
End Sub
Private Sub Form_Load()
Dim t As Double, t2 As Double
For t = 0 To 1.58 Step 0.01
CosNN(t2) = Cos(t)
t2 = t2 + 1
Next t
End Sub
?
'For I=0 to 999 Step -1: Money = Money + 1: Next I
Private Sub picdraw_Click()
End Sub
uj5u.com熱心網友回復：
參考MSDN98\SAMPLES\MSDN\TECHART\2103\BEZIER.H
MSDN98\SAMPLES\MSDN\TECHART\2103\BEZIER.C
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/121757.html
標籤：VBA
上一篇：畢業設計。單片機通過串口在上位機VB溫度曲執行緒式不會寫，各位好人給個程式我吧··
下一篇：VB的開發