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

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

本帖最后由作者于 2004-11-25 18:43: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

<A name=71524>yulijin608</A>非常感谢

我看到上面得到的px，py明显是个二维点，所以下面就将插入点也当成是二维的处理了。

奇怪的是pcenter是三维的。二维的居然不通过，很是纳闷啊。

不过问题是解决了。

谢谢

页: [1]

明经CAD社区's Archiver

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