2016-09-05 09:25

# 问题！！定义了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条回答默认 最新

• qq_27976105 2016-09-08 01:13
已采纳

真遗憾，自己回答自己，不完善的程序

已采纳该答案
评论
解决 无用
打赏 举报
• qq_27976105 2016-09-08 01:11

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

评论
解决 无用
打赏 举报
• qq_27976105 2016-09-08 01:13

需要编辑菜单，添加picturebox（pic），

评论
解决 无用
打赏 举报