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