create block

[Anonymous]

'question  !!!!!!!!
' to create selection set there is SelectOnScreen  Line 50
'I want to write down in program select linia linia1 linia2
' without clicking mouse on screen
' How to add  linia linia1 linia2 to my block without using my muouse
' i want to write program that will add these lines

Public Sub TestCopyObjects1()
Dim objSS As AcadSelectionSet
Dim varBase As Variant
Dim objBlock As AcadBlock
Dim strName As String
Dim strErase As String
Dim varEnt As Variant
Dim objSourceEnts() As Object
Dim varDestEnts As Variant
Dim dblOrigin(2) As Double
Dim intI As Integer

With ThisDrawing.Utility

Dim k0Deg, k60Deg, k120Deg As Double

k0Deg = .AngleToReal("0d", acDegrees)
k60Deg = .AngleToReal("60d", acDegrees)
k120Deg = .AngleToReal("120d", acDegrees)

Const od100p As Integer = 100

Dim pktP0, pktP1, pktP2, pktP3 As Variant

pktP0 = .GetPoint(, vbCr & "Pick the start point: ")
pktP1 = .PolarPoint(pktP0, k0Deg, od100p)
pktP2 = .PolarPoint(pktP0, k60Deg, od100p)
pktP3 = .PolarPoint(pktP0, k120Deg, od100p)


Dim linia, linia1, linia2 As AcadLine
Set linia = ThisDrawing.ModelSpace.AddLine(pktP0, pktP1)
Set lini1 = ThisDrawing.ModelSpace.AddLine(pktP0, pktP2)
Set linia2 = ThisDrawing.ModelSpace.AddLine(pktP0, pktP3)


 End With
    'choose a selection set name that you only use as temporary storage and
    'ensure that it does not currently exist
On Error Resume Next
    ThisDrawing.SelectionSets.Item("TempSSet").Delete
    Set objSS = ThisDrawing.SelectionSets.Add("TempSSet")
    objSS.SelectOnScreen '!!!!!!!!!!!!!!!!!!!!!!!
    
    '' get the other user input
    With ThisDrawing.Utility
        .InitializeUserInput 1
        strName = .GetString(True, vbCr & "Enter a block name: ")
        .InitializeUserInput 1
        varBase = .GetPoint(, vbCr & "Pick a base point: ")
       
    End With
        
    '' set WCS origin
    dblOrigin(0) = 0: dblOrigin(1) = 0: dblOrigin(2) = 0
    
    '' create the block
    Set objBlock = ThisDrawing.Blocks.Add(dblOrigin, strName)
    
    '' put selected entities into an array for CopyObjects
    ReDim objSourceEnts(objSS.Count - 1)
    For intI = 0 To objSS.Count - 1
        Set objSourceEnts(intI) = objSS(intI)
    Next
    
    '' copy the entities into block
    varDestEnts = ThisDrawing.CopyObjects(objSourceEnts, objBlock)
    
    '' move copied entities so that base point becomes origin
    For Each varEnt In varDestEnts
        varEnt.Move varBase, dblOrigin
    Next
    
   '' clean up selection set
    objSS.Delete
End Sub

[norman.yuan]

You, of course, do not need to select entities on the screen, because the targeting entities are created in your code and you have the referneces to them. You can use AcadSelectionSet.AddItems() to add these entities into the selection set. That is (psuedo code):

'Create an AcadSelectionSet here

....

' Declare an array

Dim ents(0 to 2) As Entity

''Create the lines and place them into the array

Dim line As AcadLine

Set line = ThisDrawing.ModelSpace.AddLine(pktP0, pktP1)

ents(0)=line
Set line = ThisDrawing.ModelSpace.AddLine(pktP0, pktP2)

ents(1)=line
Set line = ThisDrawing.ModelSpace.AddLine(pktP0, pktP3)

ents(2)=line

''Add these lines into AcadSelectionSet

objSS.AddItems ents

However, since you use CopyObject() to build the block, you DO NOT NEED a SelectionSet, you simply use the entity array:

''Add lines into the block

varDestEnts = ThisDrawing.CopyObjects(ents, objBlock)

...

[Anonymous]

Debugger shows   ents(0) = linia  is incorrect  

I am novice about VBA and I don't know how to cope  

'question  !!!!!!!!
' to create selection set there is SelectOnScreen  Line 50
'I want to write down in program select linia linia1 linia2
' without clicking mouse on screen
' How to add  linia linia1 linia2 to my block without using my muouse
' i want to write program that will add these lines

Public Sub TestCopyObjects1()
Dim objSS As AcadSelectionSet
Dim varBase As Variant
Dim objBlock As AcadBlock
Dim strName As String
Dim strErase As String
Dim varEnt As Variant
Dim objSourceEnts() As Object
Dim varDestEnts As Variant
Dim dblOrigin(2) As Double
Dim intI As Integer
Dim ents(0 To 2) As AcadEntity  ' Declare an array


With ThisDrawing.Utility

Dim k0Deg, k60Deg, k120Deg As Double

k0Deg = .AngleToReal("0d", acDegrees)
k60Deg = .AngleToReal("60d", acDegrees)
k120Deg = .AngleToReal("120d", acDegrees)

Const od100p As Integer = 100

Dim pktP0, pktP1, pktP2, pktP3 As Variant

pktP0 = .GetPoint(, vbCr & "Pick the start point: ")
pktP1 = .PolarPoint(pktP0, k0Deg, od100p)
pktP2 = .PolarPoint(pktP0, k60Deg, od100p)
pktP3 = .PolarPoint(pktP0, k120Deg, od100p)


Dim linia, linia1, linia2 As AcadLine
Set linia = ThisDrawing.ModelSpace.AddLine(pktP0, pktP1)
Set linia1 = ThisDrawing.ModelSpace.AddLine(pktP0, pktP2)
Set linia2 = ThisDrawing.ModelSpace.AddLine(pktP0, pktP3)
ents(0) = linia
ents(1) = linia1
ents(2) = linia2

 End With
    'choose a selection set name that you only use as temporary storage and
    'ensure that it does not currently exist
On Error Resume Next
    ThisDrawing.SelectionSets.Item("TempSSet").Delete
    Set objSS = ThisDrawing.SelectionSets.Add("TempSSet")
    objSS.AddItems ents  '!!!!!!!!!!!!!!!!!!!!!!!
    
    '' get the other user input
    With ThisDrawing.Utility
        .InitializeUserInput 1
        strName = .GetString(True, vbCr & "Enter a block name: ")
        .InitializeUserInput 1
        varBase = .GetPoint(, vbCr & "Pick a base point: ")
       
    End With
        
    '' set WCS origin
    dblOrigin(0) = 0: dblOrigin(1) = 0: dblOrigin(2) = 0
    
    '' create the block
    Set objBlock = ThisDrawing.Blocks.Add(dblOrigin, strName)
    
   varDestEnts = ThisDrawing.CopyObjects(ents, objBlock)
    
    '' move copied entities so that base point becomes origin
    For Each varEnt In varDestEnts
        varEnt.Move varBase, dblOrigin
    Next
    
   '' clean up selection set
    objSS.Delete
End Sub

[norman.yuan]

There is because of this line:

Dim linia, linia1, linia2 As AcadLine

This Dim statement only declares linia2 as AcadLine, while linia and linia1 are Variant,

It should be

Dim linia As AcadLine

Dim linia1 As AcadLine

Dim linia2 As AcadLine

Or simply only use one Dim statement as my previous reply shows.

[Anonymous]

unfortunately it doesn't work

please try this code in your debugger 

[norman.yuan]

Well, it is just a simple error:

change

ents(0)=linia

To

Set ents(0)=linia

...

Here is the code works for me:

Option Explicit

Public Sub Test()

  Dim ents() As AcadEntity
  
  ents = CreateLines()
  
  ''Create block
  Dim blk As AcadBlock
  
  Dim pt(0 To 2) As Double
  pt(0) = 0#: pt(1) = 0#: pt(2) = 0#
  
  On Error Resume Next
  Set blk = ThisDrawing.Blocks("TestBlock")
  If Err.Number <> 0 Then
    Set blk = ThisDrawing.Blocks.Add(pt, "TestBlock")
  End If
  
  ThisDrawing.CopyObjects ents, blk
  
End Sub

Private Function CreateLines() As AcadEntity()

  Dim ents(0 To 2) As AcadEntity
  Dim line As AcadLine
  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) = 0#: pt2(1) = 5#: pt2(2) = 0#
  Set line = ThisDrawing.ModelSpace.AddLine(pt1, pt2)
  Set ents(0) = line
  
  pt1(0) = 0#: pt1(1) = 0#: pt1(2) = 0#
  pt2(0) = 5#: pt2(1) = 0#: pt2(2) = 0#
  Set line = ThisDrawing.ModelSpace.AddLine(pt1, pt2)
  Set ents(1) = line

  pt1(0) = 0#: pt1(1) = 0#: pt1(2) = 0#
  pt2(0) = 5#: pt2(1) = 5#: pt2(2) = 0#
  Set line = ThisDrawing.ModelSpace.AddLine(pt1, pt2)
  Set ents(2) = line
  
  CreateLines = ents
  
End Function

[Anonymous]

Thank You for help

It works