概要 - 複数のオブジェクトを複写する(VBA/ActiveX)

複数のオブジェクトを複写するには、CopyObjects メソッドを使用するか、Copy メソッドを使用してオブジェクトの配列複写を作成します。

(選択セット内のオブジェクトを複写するには、選択セットを反復処理してオブジェクトを配列に保存します)。配列を反復処理し、各オブジェクトを複写し、新しく作成されたオブジェクトを第 2 の配列に集めます。

複数のオブジェクトを別の図面に複写するには、CopyObjects メソッドを使用し、図面のモデル空間への Owner パラメータを設定します。

2 つの円オブジェクトを複写する

次の例は、2 つの Circle オブジェクトを作成し、CopyObjects メソッドを使用して円を複写します。

Sub Ch4_CopyCircleObjects()
  Dim DOC1 As AcadDocument
  Dim circleObj1 As AcadCircle
  Dim circleObj2 As AcadCircle
  Dim circleObj1Copy As AcadCircle
  Dim circleObj2Copy As AcadCircle
  Dim centerPoint(0 To 2) As Double
  Dim radius1 As Double
  Dim radius2 As Double
  Dim radius1Copy As Double
  Dim radius2Copy As Double
  Dim objCollection(0 To 1) As Object
  Dim retObjects As Variant

  ' Define the Circle object
  centerPoint(0) = 0: centerPoint(1) = 0: centerPoint(2) = 0
  radius1 = 5#: radius2 = 7#
  radius1Copy = 1#: radius2Copy = 2#

  ' Create a new drawing
  Set DOC1 = ThisDrawing.Application.Documents.Add

  ' Add two circles to the drawing
  Set circleObj1 = DOC1.ModelSpace.AddCircle(centerPoint, radius1)
  Set circleObj2 = DOC1.ModelSpace.AddCircle(centerPoint, radius2)
  ZoomAll

  ' Put the objects to be copied into a form
  ' compatible with CopyObjects
  Set objCollection(0) = circleObj1
  Set objCollection(1) = circleObj2

  ' Copy object and get back a collection of
  ' the new objects (copies)
  retObjects = DOC1.CopyObjects(objCollection)

  ' Get newly created object and apply
  ' new properties to the copies
  Set circleObj1Copy = retObjects(0)
  Set circleObj2Copy = retObjects(1)

  circleObj1Copy.Radius = radius1Copy
  circleObj1Copy.Color = acRed
  circleObj2Copy.Radius = radius2Copy
  circleObj2Copy.Color = acRed

  ZoomAll
End Sub

オブジェクトを他の図面に複写する

次の例は、Circle オブジェクトを作成し、CopyObjects メソッドを使用して、円を新しい図面に複写します。

Sub Ch4_Copy_to_New_Drawing()
  Dim DOC0 As AcadDocument
  Dim circleObj1 As AcadCircle, circleObj2 As AcadCircle
  Dim centerPoint(0 To 2) As Double
  Dim radius1 As Double, radius2 As Double
  Dim radius1Copy As Double, radius2Copy As Double
  Dim objCollection(0 To 1) As Object
  Dim retObjects As Variant

  ' Define the Circle object
  centerPoint(0) = 0: centerPoint(1) = 0: centerPoint(2) = 0
  radius1 = 5#: radius2 = 7#
  radius1Copy = 1#: radius2Copy = 2#

  ' Add two circles to the current drawing
  Set circleObj1 = ThisDrawing.ModelSpace.AddCircle(centerPoint, radius1)
  Set circleObj2 = ThisDrawing.ModelSpace.AddCircle(centerPoint, radius2)
  ThisDrawing.Application.ZoomAll

  ' Save pointer to the current drawing
  Set DOC0 = ThisDrawing.Application.ActiveDocument

  ' Copy objects
  '
  ' First put the objects to be copied into a form compatible
  ' with CopyObjects
  Set objCollection(0) = circleObj1
  Set objCollection(1) = circleObj2

  ' Create a new drawing and point to its model space
  Dim Doc1MSpace As AcadModelSpace
  Dim DOC1 As AcadDocument

  Set DOC1 = Documents.Add
  Set Doc1MSpace = DOC1.ModelSpace

  ' Copy the objects into the model space of the new drawing. A
  ' collection of the new (copied) objects is returned.
  retObjects = DOC0.CopyObjects(objCollection, Doc1MSpace)

  Dim circleObj1Copy As AcadCircle, circleObj2Copy As AcadCircle

  ' Get the newly created object collection and apply new
  ' properties to the copies.
  Set circleObj1Copy = retObjects(0)
  Set circleObj2Copy = retObjects(1)

  circleObj1Copy.radius = radius1Copy
  circleObj1Copy.Color = acRed
  circleObj2Copy.radius = radius2Copy
  circleObj2Copy.Color = acRed

  ThisDrawing.Application.ZoomAll

  MsgBox "Circles copied."
End Sub