一道VB＋CAD的图形难题

dreamci

求：
  如附件图中所示：由line和arc绘制（非多段线）的多个随机单元格构成的复杂图形中，以已知顶点坐标为第一个点，用VB编程，按照逆时针方向顺序求出每个单元个各个顶点坐标，并求出每个单元个面积，结果写入EXCEL或VB的MSFlexGrid控件中，整个过程不要出现鼠标拾取单元格，要自用运行出结果。
0 q3 }$ E- P, l" B
我的思路是：VB编程，用For……next将每个单元格用类似“BO”命令自动创建边界，形成多段线单元格，然后用以下代码获取多段线单元的顶点坐标和面积，输入到EXCEL或VB的MSFlexGrid控件中。
4 }% a  W- r" y" @! K4 l# ~( L* p
. I0 v; ^/ P6 A- k- {! u* s3 r9 ZFor  顶点号
8 k3 [: _+ e* J$ {( |       1、创建多段线单元
       2、提取多段线顶点坐标和面积信息
       3、将数据填写进EXCEL或VB的MSFlexGrid控件中
8 z0 U: L) R5 s0 X  N next 顶点号
) b$ M4 H7 g; H$ P2 o


For循环中第三部分代码大致如下：
4 J9 H* q' t3 C'MSFlexGrid1中能列出多段线的坐标（我从网上下载到的源代码）
) I& P6 G9 u' a7 V7 y' H) |4 g
8 H- H" V8 ~2 \- WPrivate Sub cd多段线坐标查询_Click()
# m' O8 d: {. T, G'==========================================================
  Dim acadApp As AcadApplication
+ M% O+ r7 i5 {% ^6 ?2 b  Dim ssetObj As AcadSelectionSet
  On Error Resume Next
  Set acadApp = GetObject(, "autoCAD.Application")
7 D, i% k7 X0 Y+ g- u, i  acadApp.ActiveDocument.SelectionSets("hights").Delete
: k3 P9 I, Z2 F9 f  Set ssetObj = acadApp.ActiveDocument.SelectionSets.Add("hights")
6 a. C9 e3 _. t) E& h$ y  AppActivate acadApp.Caption
* W/ ^/ |  D/ ?$ O  Dim FType(0) As Integer
, a! W5 _6 w; u  l5 H8 f1 K! j+ a2 E  Dim FData(0) As Variant
2 o9 w% ]3 z1 \/ S  FType(0) = 0
4 Q' R+ B; K; J& I  FData(0) = "line"

  
  Dim filterType As Variant
  Dim filterData As Variant
1 d% Z' N5 c9 ? ' filterType = FType
1 X- C  e( O. l5 q! o* H" B( Z ' filterData = FData
: A  L  Z2 g+ Y$ p& { ' ssetObj.Select acSelectionSetAll, , , filterType, filterData
5 V- o0 F8 l' h2 ?/ e% W9 M( @/ E$ ? '                                                                                'AppActivate userform1.Caption
'
' Dim pickedObjs As AcadEntity
$ v* R2 z7 @; U3 p% F0 x$ [- N' d8 l ' For Each pickedObjs In ssetObj
'   pickedObjs.Highlight (True)
' Next
' ssetObj.Delete
" n- t! k0 t* t! E/ U
/ k0 F9 B, }" ~9 {, Z5 |, ~
0 s" S& V% l; T) `* I- J2 t) r6 v
+ X( M5 o8 N1 ~0 @# X'==========================================================================================================
2 w# v$ X4 X* r
9 [: X- B+ n/ F; ?

* F! I3 G5 S0 z! M
    '安全创建选择集
    'Dim ssetObj As AcadSelectionSet
    If Not IsNull(acadApp.ActiveDocument.SelectionSets.Item("Test")) Then
        Set ssetObj = acadApp.ActiveDocument.SelectionSets.Item("Test")
6 z4 z0 C. D4 t1 t        ssetObj.Delete
2 q/ ~) l$ a$ D/ M8 A  r  k& b0 u$ \    End If
   
5 v. \. O* E7 ?+ w   
    '创建选择集
    Set ssetObj = acadApp.ActiveDocument.SelectionSets.Add("Test")
   
    '激活CAD窗口
    AppActivate acadApp.Caption
" j/ d- Z' L, L) d+ C6 E. y" l    acadApp.WindowState = acMax
    '提示用户从屏幕选择实体对象，并加入选择集
4 @1 q' i2 |! N    ssetObj.SelectOnScreen
    ssetObj.Select acSelectionSetAll  '选择所有曲线
' q7 O: y& s1 v/ o7 B. w* l   
" p( ?8 K' H5 \* i( K    '选择完毕后按回车键或单击右键
( z2 u0 A1 o) k: w* n: t/ J    'Dim pickedObjs As AcadEntity
    Dim retCoord As Variant
, s2 Q) F; a* J# Z; ^5 q& O2 v  V    For Each pickedObjs In ssetObj
) b8 g# R. z2 m: B        retCoord = pickedObjs.Coordinates
        AppActivate Me.Caption
        acadApp.WindowState = acMin
        If TypeOf pickedObjs Is AcadPolyline Or TypeOf pickedObjs Is Acad3DPolyline Then   '普通多义线或3维多段线
- t) O1 z( F' c' u# b            j = (UBound(pickedObjs.Coordinates) + 1) / 3   '多义线的顶点数
            For i = 0 To j * 3 - 1 Step 3
* S+ Z# V5 \; W1 Q# h                    If retCoord(0) = retCoord(j * 3 - 3) And retCoord(1) = retCoord(j * 3 - 2) Then  '闭合时
; s) _  q3 B* `% n                        MSFlexGrid1.Rows = j
1 O, e; N3 o  w1 C% E                    Else   '非闭合时
                        MSFlexGrid1.Rows = j + 1
                    End If
1 {" Y3 d3 _; `% ]                    MSFlexGrid1.TextMatrix(i / 3 + 1, 0) = i / 3 + 1
                    MSFlexGrid1.TextMatrix(i / 3 + 1, 2) = Format(retCoord(i) / 1000 * Val(Text比例.Text), "0.000")
                    MSFlexGrid1.TextMatrix(i / 3 + 1, 1) = Format(retCoord(i + 1) / 1000 * Val(Text比例.Text), "0.000")
8 z8 i, A8 @! E7 R& u
            Next i
. Y) e1 F& |2 I. q" Y6 N, }; ^        ElseIf TypeOf pickedObjs Is AcadLWPolyline Then   '轻便多义线
            j = (UBound(pickedObjs.Coordinates) + 1) / 2   '多义线的顶点数
            For i = 0 To j * 2 - 1 Step 2
) m$ X2 N5 ~( G/ Z; G                    If retCoord(0) = retCoord(j * 2 - 2) And retCoord(1) = retCoord(j * 2 - 1) Then '闭合时
. D9 r3 C8 v+ U                        MSFlexGrid1.Rows = j
3 F' `9 g/ p- P5 c% l8 b, q# W                    Else   '非闭合时
                        MSFlexGrid1.Rows = j + 1
3 R  E4 s$ Q# K& X; \/ w                    End If
                    '******MSFlexGrid1中只能列出多段线的坐标******
8 k) c# d1 q4 V+ R                    '不支持面域
                    MSFlexGrid1.TextMatrix(i / 2 + 1, 0) = i / 2 + 1
                    'X坐标
                    MSFlexGrid1.TextMatrix(i / 2 + 1, 1) = Format(retCoord(i) / 1000 * Val(Text比例.Text), "0.000")         'X
                    'Y坐标
! l' y* H' p, T8 |                    MSFlexGrid1.TextMatrix(i / 2 + 1, 2) = Format(retCoord(i + 1) / 1000 * Val(Text比例.Text), "0.000")     'Y
$ E; L7 \5 v: H% z7 `                    '面积
                    MSFlexGrid1.TextMatrix(i / 2 + 1, 3) = Format(pickedObjs.Area, "0.000") '面积
                    MSFlexGrid1.Refresh
            Next i
: z- F; V7 _& S        Else
% u$ y  y# Z9 {/ w             MsgBox "您选择的不是多段线！", 64 + vbOKOnly, "地质测量"
% }8 M4 d1 x' c6 o4 N1 q             ssetObj.Delete
7 n( V1 T! ?2 ?8 n1 O        End If
        Exit For
    Next
    '删除选择集
% A! U. y3 E* M* ~9 r2 e3 n6 o- h    ssetObj.Delete
End Sub

( t. ]" s3 U! o- e3 F'==========================================================
* b% A$ b( S% t3 V* I, B
) h3 H: P; _0 P  i[ 本帖最后由 dreamci 于 2009-5-21 21:58 编辑 ]

dreamci

没有人能解吗？

seafree101300

注释,需要

a2166692

一点都没明白

kjava

不是说不要那个选择吗？怎么程序里还是有选择的代码？另外我觉得有图例说明才行，不然不知道是什么情况