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
記事全体を表示
