AutoCAD ActiveX：Excel VBA からの利用

toshiaki_isezaki

Issue

Excel VBA から Excel シート上のテーブル値に応じた作図が出来ますか？

Solution

AutoCAD の ActiveX オートメーションは、Windows の COM 機構を利用します。AutoCAD のカスタマイズを手助けする AutoCAD API のとおり、Microsoft Office 製品は、自身の機能を COM サーバーとして公開、内部の VBA を COM クライアントとして公開しているので、AutoCAD VBA から Excel を操作したり、Excel VBA から AutoCAD を操作することが出来ます。

Excel VBA から AutoCAD の ActiveX オートメーションインタフェースを利用するには、Excel VBA からAutoCAD オブジェクト情報を公開している AutoCAD タイプライブラリ（AutoCAD Type Library）を参照設定するだけです。

次のコードは、Excel の「精密テーブル」タブのテーブル上のカーソル列の値を読み取って、AutoCAD 図面のモデル空間に「精密滑車」ブロックを挿入するものです。

Option Explicit

Public Sub CommandButton1_Click()

    On Error Resume Next
    
    Dim oApp As AcadApplication
    Set oApp = GetObject(, "AutoCAD.Application.25")
    If Err Then
        Debug.Print "AutoCAD が起動されていません..."
        Set oApp = CreateObject("AutoCAD.Application.25")
    End If
    oApp.Visible = True
        
    If oApp.Documents.Count = 0 Then
        MsgBox "アクティブな図面がありません..."
        Exit Sub
    End If
    
    Dim oDoc As AcadDocument
    Set oDoc = oApp.ActiveDocument
    
    oDoc.SetVariable "DIMASZ", 0.1
    oDoc.SetVariable "DIMEXE", 0.2
    oDoc.SetVariable "DIMEXO", 0.1
    oDoc.SetVariable "DIMGAP", 0.02
    oDoc.SetVariable "DIMTXT", 0.1
    Call oDoc.ActiveDimStyle.CopyFrom(oDoc)
        
    Dim oModel As AcadModelSpace
    Set oModel = oDoc.ModelSpace
    Dim oEntity As AcadEntity
    For Each oEntity In oModel
        If oEntity.ObjectName = "AcDbBlockReference" Then
            Dim oBlockRef  As AcadBlockReference
            Set oBlockRef = oEntity
            If oBlockRef.Name = "精密滑車" Then
                oBlockRef.Delete
            End If
        End If
    Next
        
    Err.Clear

    oDoc.Regen (acActiveViewport)
        
    Dim ptBase As Variant
    ptBase(0) = 0#: ptBase(1) = 0#
    Dim oBlock As AcadBlock
    Set oBlock = Nothing
    Set oBlock = oDoc.Blocks.Item("精密滑車")
    If oBlock Is Nothing Then
        Set oBlock = oDoc.Blocks.Add(ptBase, "精密滑車")
    Else
        For Each oEntity In oBlock
            oEntity.Delete
        Next
    End If
       
    Dim SelectedRange As Range
    Set SelectedRange = Application.ActiveCell
    Dim SelectedRow As Long
    SelectedRow = SelectedRange.Row
    
    Dim OD As Double
    Dim Bore As Double
    Dim A As Double
    Dim B As Double
    OD = Sheets("滑車テーブル").Cells(SelectedRow, 2)
    Bore = Sheets("滑車テーブル").Cells(SelectedRow, 3)
    A = Sheets("滑車テーブル").Cells(SelectedRow, 4)
    B = Sheets("滑車テーブル").Cells(SelectedRow, 5)

    Dim ptVertexs(0 To 17) As Double
    ptVertexs(0) = 0#: ptVertexs(1) = Bore * -0.5
    ptVertexs(2) = ptVertexs(0): ptVertexs(3) = A * -0.5
    ptVertexs(4) = B: ptVertexs(5) = ptVertexs(3)
    ptVertexs(6) = ptVertexs(4): ptVertexs(7) = ptVertexs(3) - (OD - A) * 0.5
    ptVertexs(8) = ptVertexs(6) + 0.05: ptVertexs(9) = ptVertexs(7)
    ptVertexs(10) = ptVertexs(8) + 0.15: ptVertexs(11) = ptVertexs(9)
    ptVertexs(12) = ptVertexs(10) + 0.05: ptVertexs(13) = ptVertexs(9)
    ptVertexs(14) = ptVertexs(12): ptVertexs(15) = ptVertexs(1)
    ptVertexs(16) = ptVertexs(0): ptVertexs(17) = ptVertexs(1)
    
    Dim oPLine As AcadLWPolyline
    Set oPLine = oBlock.AddLightWeightPolyline(ptVertexs)
    oPLine.SetBulge 4, -0.5
    
    Dim oLoop1(0 To 0) As AcadEntity
    Set oLoop1(0) = oPLine
    
    Dim pt1(0 To 2) As Double
    Dim pt2(0 To 2) As Double
    pt1(0) = 0#: pt1(1) = 0#: pt1(2) = 0#
    pt2(0) = ptVertexs(14): pt2(1) = 0#: pt2(2) = 0#
   
    Dim oColor As AcadAcCmColor
    Set oColor = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.25")
    Call oColor.SetRGB(255, 0, 0)
    
    Dim oHatch1 As AcadHatch
    Set oHatch1 = oBlock.AddHatch(acHatchPatternTypePreDefined, "ANSI31", True, acHatchObject)
    oHatch1.AppendOuterLoop (oLoop1)
    oHatch1.PatternScale = 0.01
    oHatch1.TrueColor = oColor
    oHatch1.Evaluate
    
    Dim oLoop2(0 To 0) As AcadEntity
    Set oLoop2(0) = oLoop1(0).Mirror(pt1, pt2)
    
    Dim oHatch2 As AcadHatch
    Set oHatch2 = oBlock.AddHatch(acHatchPatternTypePreDefined, "ANSI31", True, acHatchObject)
    oHatch2.AppendOuterLoop (oLoop2)
    oHatch2.PatternScale = 0.01
    oHatch2.TrueColor = oColor
    oHatch2.Evaluate
    
    pt1(0) = 0#: pt1(1) = Bore * -0.5: pt1(2) = 0#
    pt2(0) = 0#: pt2(1) = pt1(1) + Bore: pt2(2) = 0#
    Call oBlock.AddLine(pt1, pt2)
    
    pt1(0) = ptVertexs(12)
    pt2(0) = ptVertexs(12)
    Call oBlock.AddLine(pt1, pt2)
    
    Dim oDimAligned As AcadDimAligned
    Dim ptLoc(0 To 2) As Double
    pt1(0) = ptVertexs(12): pt1(1) = ptVertexs(11)
    pt2(0) = ptVertexs(12): pt2(1) = pt1(1) + OD
    ptLoc(0) = pt1(0) + 1.2: ptLoc(1) = Abs(pt1(1) - pt2(1)) * 0.5: ptLoc(2) = 0#
    Set oDimAligned = oBlock.AddDimAligned(pt1, pt2, ptLoc)
    
    pt1(0) = ptVertexs(0): pt1(1) = ptVertexs(7) + A + (OD - A)
    pt2(0) = ptVertexs(0) + B: pt2(1) = ptVertexs(7) + A + (OD - A)
    ptLoc(0) = Abs(pt1(0) - pt2(0)) * 0.5: ptLoc(1) = pt1(1) + 1#
    Set oDimAligned = oBlock.AddDimAligned(pt1, pt2, ptLoc)
    
    pt1(0) = ptVertexs(0): pt1(1) = ptVertexs(3)
    pt2(0) = ptVertexs(0): pt2(1) = pt1(1) + A
    ptLoc(0) = pt1(0) - 1.2: ptLoc(1) = Abs(pt1(1) - pt2(1)) * 0.5
    Set oDimAligned = oBlock.AddDimAligned(pt1, pt2, ptLoc)
    
    pt1(0) = ptVertexs(0): pt1(1) = ptVertexs(3) + (A - Bore) * 0.5
    pt2(0) = ptVertexs(0): pt2(1) = pt1(1) + Bore
    ptLoc(0) = pt1(0) - 0.75: ptLoc(1) = Abs(pt1(1) - pt2(1)) * 0.5
    Set oDimAligned = oBlock.AddDimAligned(pt1, pt2, ptLoc)
    
    '挿入基点を指定する場合
    'Dim ptInsert As Variant
    'oDoc.Utility.InitializeUserInput 1
    'ptInsert = oDoc.Utility.GetPoint(, vbCrLf & "挿入点を指定:")
    '挿入基点を原点で固定する場合
    Dim ptInsert(0 To 2) As Double
    ptInsert(0) = 0#: ptInsert(1) = 0#
    
    Call oModel.InsertBlock(ptInsert, "精密滑車", 1#, 1#, 1#, 0#)
    oApp.ZoomExtents

End Sub

AutoCAD ActiveX：Excel VBA からの利用

寄稿者

フォーラムリンク

AutoCAD ActiveX：Excel VBA からの利用

寄稿者

フォーラム リンク

フォーラムリンク