CAD 与VB 数据的结合，高手进！

lxy513

请教大侠，我想利用VB程序提取CAD图形（简单图形）的各顶点的坐标，苦于知识浅薄，请不吝赐教。谢谢。

pmq

Sub Start()
    On Error Resume Next
   
    Dim Sel As AcadSelectionSet    '选择集
    Dim Obj As AcadObject          '
    Dim Sxyh As Variant
    Dim Exyh As Variant
    Dim Coord As Variant
    Dim XYZ(2) As Double
    Dim Js As Long
   
    Open "C:\XYH.dat" For Output As #1
   
    '错误处理
    Set Sel = ThisDrawing.SelectionSets("ss")
    If Err Then Set Sel = ThisDrawing.SelectionSets.Add("ss")
   
    '初始状态下清空选择集
    Sel.Clear
    Sel.SelectOnScreen
   
    For Each Obj In Sel
        If Obj.ObjectName = "AcDbLine" Then
            Js = Js + 1
            Sxyh = Obj.StartPoint
            Exyh = Obj.EndPoint
            'XYZ_P_C Sxyh   '屏幕坐标转测量坐标
            Print #1, Str(Js); " , "; Str(Js); " , "; Sxyh(1); " , "; Sxyh(0); " , "; Sxyh(2)
            Js = Js + 1
            'XYZ_P_C Exyh
            Print #1, Str(Js); " , "; Str(Js); " , "; Exyh(1); " , "; Exyh(0); " , "; Exyh(2)
        ElseIf Obj.ObjectName = "AcDbPolyline" Or Obj.ObjectName = "AcDb2dPolyline" Then
            Coord = Obj.Coordinates
            XYZ(2) = Obj.Elevation
            For i = 0 To UBound(Coord) Step 3
                Js = Js + 1
                XYZ(1) = Coord(i + 1)
                XYZ(0) = Coord(i)
                'XYZ_P_C XYZ
                Print #1, Str(Js); " , "; Str(Js); " , "; XYZ(1); " , "; XYZ(0); " , "; XYZ(2)
            Next i
        ElseIf Obj.ObjectName = "AcDb3dPolyline" Or Obj.ObjectName = "AcDbSpline" Then
            Coord = Obj.Coordinates
            For i = 0 To UBound(Coord) Step 3
                Js = Js + 1
                XYZ(1) = Coord(i + 1)
                XYZ(0) = Coord(i)
                XYZ(2) = Coord(i + 2)
                'XYZ_P_C XYZ
                Print #1, Str(Js); " , "; Str(Js); " , "; XYZ(1); " , "; XYZ(0); " , "; XYZ(2)
            Next i
        End If
        Js = 0
    Next
    Close
End Sub

caiqs

楼上理解错误,他说的是VB程序打开cad,而非vba

打开VB，添加一个窗体，加上如下代码，然后运行，也可以编译成exe再运行

这段代码的作用是用VB程序打开dwg文件并写一行文字到模型空间，然后保存

Private Sub Form_Load()

On Error Resume Next
Dim acadapp As object
Set acadapp = CreateObject("AutoCAD.application")
acadapp.Visible = False '是否显示
Dim doc As object
Set doc = acadapp.Documents.Open("c:/test.dwg") '打开文档
doc.Activate
Dim insertpt(2) As Double
insertpt(0) = 0: insertpt(1) = 0: insertpt(2) = 0
doc.ModelSpace.AddText "用VB打开AutoCAD例子程序", insertpt, 5
acadapp.ZoomAll
doc.Close True '并闭并保存
acadapp.Quit '退出cad
End Sub