Birden Çok Nesneyi Kopyalama Hakkında (VBA/ActiveX)

Birden fazla nesneyi kopyalamak için şunu kullanın:Kopya Nesneleriveya bu yöntemle kullanılacak nesnelerden oluşan bir dizi oluşturun.Kopyalayöntem.

Seçim kümesindeki nesneleri kopyalamak için, seçim kümesi üzerinde yineleme yapın ve nesneleri bir diziye kaydedin. Dizi üzerinde yineleme yaparak her nesneyi ayrı ayrı kopyalayın ve yeni oluşturulan nesneleri ikinci bir dizide toplayın.

Birden fazla nesneyi farklı bir çizime kopyalamak için şunu kullanın:Kopya NesneleriBu yöntemi kullanarak Sahip parametresini çizimin model alanına ayarlayın .

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 
   
   
   
   
   
      
   
   
   
   
      
   

  'Daire nesnesini tanımlayın
  merkez noktası(0) = 0: merkez noktası(1) = 0: merkez noktası(2) = 0
  yarıçap1 = 5#: yarıçap2 = 7#
  yarıçap1Kopyası = 1#: yarıçap2Kopyası = 2#

  ' Yeni bir çizim
   oluşturun . DOC1 = ThisDrawing.Application.Documents.Add değişkenini ayarlayın .​​​  

  Çizime iki daire ekleyin.
  Set circleObj1 = DOC1.ModelSpace.AddCircle(centerPoint, radius1)
  Set circleObj2 = DOC1.ModelSpace.AddCircle(centerPoint, radius2)
  ZoomAll

  ' Kopyalanacak nesneleri CopyObjects ile uyumlu bir forma
   yerleştirin ' 
  Set objCollection(0) = circleObj1
  Set objCollection(1) = circleObj2

  ' Nesneyi kopyala ve yeni nesnelerin (kopyaların) bir koleksiyonunu geri
   al'    
  retObjects = DOC1.CopyObjects(objCollection)

  ' Yeni oluşturulan nesneyi alın ve yeni özellikleri kopyalara uygulayın
   '  
  set circleObj1Copy = retObjects(0)
  set circleObj2Copy = retObjects(1)

  circleObj1Copy.Radius = radius1Copy
  daireObj1Kopyası.Renk = acRed
  daireObj2Kopyası.Yarıçap = yarıçap2Kopyası
  daireObj2Kopyası.Renk = acRed

  ZoomAll
Son Alt Yordam

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 
   
    
      
    
    
      
   

  'Daire nesnesini tanımlayın
  merkez noktası(0) = 0: merkez noktası(1) = 0: merkez noktası(2) = 0
  yarıçap1 = 5#: yarıçap2 = 7#
  yarıçap1Kopyası = 1#: yarıçap2Kopyası = 2#

  ' Mevcut çizime iki daire
   ekleyin Set circleObj1 = ThisDrawing . ModelSpace . AddCircle ( centerPoint , radius1 ) Set circleObj2 = ThisDrawing . ModelSpace . AddCircle ( centerPoint , radius2 ) ThisDrawing . Application . ZoomAll  
   
  

  'Mevcut çizime işaretçiyi kaydet'
  DOC0 = ThisDrawing.Application.ActiveDocument olarak ayarla

  ' Nesneleri
   kopyala ' 
  ' Öncelikle kopyalanacak nesneleri CopyObjects ile uyumlu bir forma
   yerleştirin ' 
  Set objCollection(0) = circleObj1
  Set objCollection(1) = circleObj2

  ' Yeni bir çizim oluşturun ve model alanına işaret edin
   Dim Doc1MSpace As AcadModelSpace Dim DOC1 As AcadDocument    
   

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

  'Nesneleri yeni çizimin model alanına kopyalayın.'
  ' Yeni ( kopyalanan ) nesnelerin koleksiyonu döndürülür . 
  retObjects = DOC0.CopyObjects ( objCollection , Doc1MSpace )​​​  

  Dim circleObj1Copy As AcadCircle , circleObj2Copy As AcadCircle  

  'Yeni oluşturulan nesne koleksiyonunu alın ve yeni özellikleri uygulayın.'
  ' özelliklerini kopyalara atayın . Set circleObj1Copy = retObjects ( 0 ) Set circleObj2Copy = retObjects ( 1 )
  
  

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

  BuÇizim . Uygulama . Tümünü Yakınlaştır

  MsgBox "Daireler kopyalandı." End Sub