Autocad to Excel 円の座標データをセルに表示 Excel VBA

エクセルからAUTOCADで選択中の円の座標を取得

選択している円のデータ情報を知りたいという質問がありましたので、下記のように変更しました。

SelectionSets.Add　選択セットを使用しています。VBAの最後に削除しています。

AUTOCADのコードでは、ThisDrawingですが、Excelから設定するには、AcadDocと書き直します。

ThisDrawing.SelectionSets.Add("Sample")

AcadDoc.SelectionSets.Add("Sample") 

AcadDocは下記のように定義

Set AcadDoc = AcadApp.ActiveDocument()

参照設定

AutoCAD 2021 Type Library にチェックしています。

• AUTOCADで、選択した円のデータを抽出

１．マクロ起動後、

２．AUTOCAD画面で円を選択。
３．円を青色に変更して、Excelに座標を書き出す。

• VBA CODE

Option Explicit

Private AcadDoc As AutoCAD.AcadDocument     'ﾓｼﾞｭｰﾙ定義

Private AcadApp As AutoCAD.AcadApplication  ' AutoCAD アプリケーション変数

Public Sub AutocadSelectionSET()

    Set AcadApp = GetObject(, "AutoCAD.Application")    ' xls追加

    Set AcadDoc = AcadApp.ActiveDocument()

         

    Dim objSelSet As AcadSelectionSet

    Dim objEntity As AcadEntity

    Dim objCircle As AcadCircle

    Dim Str As String

    Dim N

    Set objSelSet = AcadDoc.SelectionSets.Add("Sample")  'いったん選択セットを設定する。

    

    Call objSelSet.SelectOnScreen ' autocad 画面上で、円を選択する。マクロ起動後にAUTOCAD画面で選択する。

    N = ActiveCell.Row

         

         Cells(N, ActiveCell.Column + 0) = "objCircle.center(0)"

         Cells(N, ActiveCell.Column + 1) = "objCircle.center(1)"

         Cells(N, ActiveCell.Column + 2) = "objCircle.center(2)"

    N = ActiveCell.Row + 1

    For Each objEntity In objSelSet

      

      If objEntity.ObjectName = "AcDbCircle" Then

         Set objCircle = objEntity

           

         'Str = "OBJ name" & objEntity.ObjectName & "半径" & objCircle.Area & vbCrLf & "中心座標" & objCircle.center(0) & "," & objCircle.center(1) & "," & objCircle.center(2)

            ' MsgBox Str

           

            ' MsgBox "ECXEL 現在のセルの左に入力します。"

            

         Cells(N, ActiveCell.Column + 0) = objCircle.center(0)

         Cells(N, ActiveCell.Column + 1) = objCircle.center(1)

         Cells(N, ActiveCell.Column + 2) = objCircle.center(2)

         

      

         objEntity.Color = acBlue  '　選択した円を青くする。不要の場合は削除する。

      

         N = N + 1

      End If

    Next

    

    AcadDoc.SelectionSets("Sample").Delete      '使用後　選択セット削除する。

End Sub

モデル空間にある円の座標全てをエクセルに書き出す。

従来のコードでは、モデル空間の全ての円の情報を拾い出すようになっていました。

下記のコードでは、全ての円のデータを拾い出しています。

• 説明

Autocadで、円を選択しておく。
エクセルから下記マクロを実行すると選択中のセルから左へ座標を入力する。

• VBA code

Option Explicit

Private AcadDoc As AutoCAD.AcadDocument     'ﾓｼﾞｭｰﾙ定義
Private AcadApp As AutoCAD.AcadApplication  ' AutoCAD アプリケーション変数

' --- 現在選択中の図形(円)の情報を取得する
' --- AcadEntity
' --- Autocad 2006 Excel2003
Sub AutocadGetEntity()

    Set AcadApp = GetObject(, "AutoCAD.Application")    ' xls追加
    Set AcadDoc = AcadApp.ActiveDocument()              ' xls追加
     
    Dim objEntity As AcadEntity
    Dim objCircle As AcadCircle
    Dim Str As String
     
    ' モデル空間に含まれるすべての図形を列挙し、
    ' 一つずつAcadEntity型のオブジェクト変数objEntityに取り出す。
    'For Each objEntity In ThisDrawing.ModelSpace       ' Autocad Code
    For Each objEntity In AcadDoc.ModelSpace
         
        ' 取り出された図形のAutoCADクラス名がAcDbCircle(円)の場合は、
        ' AcadCircle型のオブジェクト変数objCircleにキャストして半径を表示。
        If objEntity.ObjectName = "AcDbCircle" Then
            Set objCircle = objEntity
            Str = "半径" & objCircle.Area & vbCrLf & "中心座標" & objCircle.center(0) & "," & objCircle.center(1) & "," & objCircle.center(2)
            MsgBox Str
           
            MsgBox "ECXEL 現在のセルの左に入力します。"
            Cells(ActiveCell.Row, ActiveCell.Column + 0) = objCircle.center(0)
            Cells(ActiveCell.Row, ActiveCell.Column + 1) = objCircle.center(1)
            Cells(ActiveCell.Row, ActiveCell.Column + 2) = objCircle.center(2)
       
        End If
    Next

End Sub