|
楼主 |
发表于 2013-10-15 07:53
|
显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
本帖最后由 灰袍法师 于 2013-10-15 08:16 编辑
er......我发现 海底眼 原先的自定义函数带有错误。
如果两个数据点非常接近,而其它数据点远离这两个接近的数据点,那么这两个 接近数据点之间 的插值就会出错。
比如原附件的第一个表,如果用以下数据画平滑曲线就会出现插值点不在曲线上:
2.00 | 2.80 | 3.60 | 5.00 | 5.00 | 6.00 | 0.00 | 4.00 | 4.00 | 0.00 | 5.00 | 4.00 |
出错图示如下:
查了半天,发现是这段代码有误,原帖海底眼的代码是:
在 FindFourBezierPoints 子过程里面的这段代码:
If ((d13 / 6 < d23 / 2) And (d24 / 6 < d23 / 2)) Then
If (Dot1.x <> Dot2.x Or Dot1.y <> Dot2.y) Then OffsetTo2 = AmultiF(OffsetTo2, 1 / 6)
If (Dot1.x = Dot2.x And Dot1.y = Dot2.y) Then OffsetTo2 = AmultiF(OffsetTo2, 1 / 3)
If (Dot3.x <> Dot4.x Or Dot3.y <> Dot4.y) Then OffsetTo3 = AmultiF(OffsetTo3, 1 / 6)
If (Dot3.x = Dot4.x And Dot3.y = Dot4.y) Then OffsetTo3 = AmultiF(OffsetTo3, 1 / 3)
ElseIf ((d13 / 6 >= d23 / 2) And (d24 / 6 >= d23 / 2)) Then
OffsetTo2 = AmultiF(OffsetTo2, d23 / 12)
OffsetTo3 = AmultiF(OffsetTo3, d23 / 12)
ElseIf (d13 / 6 >= d23 / 2) Then
OffsetTo2 = AmultiF(OffsetTo2, d23 / 2 / d13)
OffsetTo3 = AmultiF(OffsetTo3, d23 / 2 / d13)
ElseIf (d24 / 6 >= d23 / 2) Then
OffsetTo2 = AmultiF(OffsetTo2, d23 / 2 / d24)
OffsetTo3 = AmultiF(OffsetTo3, d23 / 2 / d24)
End If
要全部替换为以下正确代码:
If ((d13 / 6 < d23 / 2) And (d24 / 6 < d23 / 2)) Then
If (Dot1.x <> Dot2.x Or Dot1.y <> Dot2.y) Then OffsetTo2 = AmultiF(OffsetTo2, 1 / 6)
If (Dot1.x = Dot2.x And Dot1.y = Dot2.y) Then OffsetTo2 = AmultiF(OffsetTo2, 1 / 3)
If (Dot3.x <> Dot4.x Or Dot3.y <> Dot4.y) Then OffsetTo3 = AmultiF(OffsetTo3, 1 / 6)
If (Dot3.x = Dot4.x And Dot3.y = Dot4.y) Then OffsetTo3 = AmultiF(OffsetTo3, 1 / 3)
ElseIf ((d13 / 6 >= d23 / 2) And (d24 / 6 >= d23 / 2)) Then
OffsetTo2 = AmultiF(AsubB(Dot3, Dot1), d23 / 2 / d13) '原有代码的这一句和下一句都错了。
OffsetTo3 = AmultiF(AsubB(Dot2, Dot4), d23 / 2 / d24)
ElseIf (d13 / 6 >= d23 / 2) Then
OffsetTo2 = AmultiF(AsubB(Dot3, Dot1), d23 / 2 / d13)
OffsetTo3 = AmultiF(AsubB(Dot2, Dot4), d23 / 2 / d13)
ElseIf (d24 / 6 >= d23 / 2) Then
OffsetTo2 = AmultiF(AsubB(Dot3, Dot1), d23 / 2 / d24)
OffsetTo3 = AmultiF(AsubB(Dot2, Dot4), d23 / 2 / d24)
End If
这里是修改后的顶楼附件,用最新版本的 WinRAR 打开
数值牛顿法求解两条贝塞尔曲线的交点_改正原有代码插值错误的新版本.rar
(37.93 KB, 下载次数: 411)
|
|