社区 › VB › [求助]下面的程序总是提示有错

chman 发表于 2004-11-25 18:16:00

[求助]下面的程序总是提示有错

如图所示，处理四边形没有问题，如果处理的是如图所示的六边形，总是提示出错了
Sub tt()
                       Dim pnt
                       Dim picked As Boolean
                       Dim px() As Double
                       Dim py() As Double
                       Dim i, k, j As Integer
                       Dim pcenter() As Double
                       Dim insertdistance() As Double
               Do While 1
                                                       pnt = ThisDrawing.Utility.GetPoint(, "在闭合圈内点击")
                                                       ThisDrawing.SendCommand "-boundary" & vbCr & "a" & vbCr & "b" & vbCr & "e" & vbCr & vbCr & pnt(0) & "," & pnt(1) & vbCr & vbCr
                                                       Set pr = ThisDrawing.ModelSpace(ThisDrawing.ModelSpace.Count - 1)
                                                       Dim retCoord As Variant
                                                       retCoord = pr.Coordinates
                                                       k = (UBound(retCoord) + 1) / 2
                                                       ReDim px(UBound(retCoord)) As Double
                                                       ReDim py(UBound(retCoord)) As Double
                                                       For i = 0 To UBound(retCoord) Step 2
                                                                                       px(i / 2) = retCoord(i)
                                                                                       py(i / 2) = retCoord(i + 1)
                                                       Next i
                                                       
                                                       ReDim pcenter(k - 2) As Double
                                                       ReDim insertdistance(k - 2) As Double
                                                       For i = 0 To k - 2
                                                                                       pcenter(0) = (px(i) + px(i + 1)) / 2
                                                                                       pcenter(1) = (py(i) + py(i + 1)) / 2
                                                                                       insertdistance(i) = Sqr((px(i) - px(i + 1)) * (px(i) - px(i + 1)) + (py(i) - py(i + 1)) * (py(i) - py(i + 1)))
                                                                                       insertdistance(i) = Format(insertdistance(i), "#,##0.00;;;Nil")
                                                                                       ThisDrawing.ModelSpace.AddText insertdistance(i), pcenter, 0.65
                                                       Next i
                                               
                       picked = True
                       
Loop
End Sub

yulijin608 发表于 2004-11-25 19:22:00

问题在于ReDim pcenter(k - 2) As Double
当是6边行时,ThisDrawing.ModelSpace.AddText insertdistance(i), pcenter, 0.65
中 pcenter含5个数,而坐标为3个double数元

chman 发表于 2004-11-25 19:46:00

我个人认为：如果定义为
ReDim pcenter(1) As Double
那就没有问题了
i 增加一个值，都对pcenter（0），pcenter（1）重新赋值。
但事实上程序仍然出错的。
能帮我想个办法，解决这个问题，，要能同时解决上述两种图形的情况。谢啦

yulijin608 发表于 2004-11-26 08:50:00

下面的程序在AutoCAD MAP 2000上通过
Sub tt()
                       On Error GoTo Err_Control
                       Dim pnt
                       Dim picked As Boolean
                       Dim px() As Double
                       Dim py() As Double
                       Dim i, k, j As Integer
                       Dim pcenter() As Double
                       Dim insertdistance() As Double
               Do While 1
                                                       pnt = ThisDrawing.Utility.GetPoint(, "在闭合圈内点击")
                                                       ThisDrawing.SendCommand "-boundary" & vbCr & "a" & vbCr & "b" & vbCr & "e" & vbCr & vbCr & pnt(0) & "," & pnt(1) & vbCr & vbCr
                                                       Set pr = ThisDrawing.ModelSpace(ThisDrawing.ModelSpace.Count - 1)
                                                       Dim retCoord As Variant
                                                       retCoord = pr.Coordinates
                                                       k = (UBound(retCoord) + 1) / 2
                                                       ReDim px(UBound(retCoord)) As Double
                                                       ReDim py(UBound(retCoord)) As Double
                                                       For i = 0 To UBound(retCoord) Step 2
                                                                                       px(i / 2) = retCoord(i)
                                                                                       py(i / 2) = retCoord(i + 1)
                                                       Next i
                                                       
                                                       ReDim pcenter(0 To 2) As Double
                                                       ReDim insertdistance(k - 2) As Double
                                                       For i = 0 To k - 2
                                                                                       pcenter(0) = (px(i) + px(i + 1)) / 2
                                                                                       pcenter(1) = (py(i) + py(i + 1)) / 2
                                                                                       pcenter(2) = 0
                                                                                       insertdistance(i) = Sqr((px(i) - px(i + 1)) * (px(i) - px(i + 1)) + (py(i) - py(i + 1)) * (py(i) - py(i + 1)))
                                                                                       insertdistance(i) = Format(insertdistance(i), "#,##0.00;;;Nil")
                                                                                       ThisDrawing.ModelSpace.AddText insertdistance(i), pcenter, 0.65
                                                       Next i
                                               
                       picked = True
                       
Loop
Exit_Here:
       Exit Sub
Err_Control:
       Select Case Err.Number
                                                       Case -2147467259
                                                               '右键单击或回车或空格
                                                       Err.Clear
                                                       Resume Exit_Here
       End Select
       
End Sub

tiger8888 发表于 2004-11-26 12:50:00

楼上的两位版主给我很大启发

chman 发表于 2004-11-26 21:06:00

yulijin608非常感谢
我看到上面得到的px，py明显是个二维点，所以下面就将插入点也当成是二维的处理了。
奇怪的是pcenter是三维的。二维的居然不通过，很是纳闷啊。
不过问题是解决了。
谢谢

查看完整版本: [求助]下面的程序总是提示有错