Jump to content

Get Attributes, Selection Sets

streng

By streng
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

streng Contributor

streng

Posted
Posted

Hi

 

Am wondering if someone can give me some advice in creating a selection set to automatically select title blocks (Only One per layout)

 

Namely

 

A1Title

A2Title

A3Title, etc.

 

My code iretates between layouts but at the moment has got a user input to select the block and I would like the code to automatically select the block and then scroll through layouts.

 

Have attached file for a better understanding.

 

Hope someone can help.

Project6.zip

Lee Mac Grand Master

Lee Mac

Posted
Posted

Judging by your attachment, I'm guessing you're after VBA?

 

but in LISP:

 

(setq ss (ssget "X"
               (list (cons 0 "INSERT")
                     (cons 2 "A1Partners")
                     (if (getvar "CTAB")
                       (cons 410 (getvar "CTAB"))
                       (cons 67 (- 1 (getvar "TILEMODE")))))))

streng Contributor

streng

Posted
  • Author
Posted

Thanks for reply

 

I am after VBA, have no knowledge of lisp unfortunately.

 

Regards

 

Streng

Lee Mac Grand Master

Lee Mac

Posted
Posted
Thanks for reply

 

I am after VBA, have no knowledge of lisp unfortunately.

 

Regards

 

Streng

 

 

I thought that may be the case :)

SEANT Veteran

SEANT

Posted
Posted

I'll take a peek at this later today.

SEANT Veteran

SEANT

Posted
Posted

Here are some modifications that allow Layout processing without the need to manually iterate through them.

 

I may have inadvertently changed the output format – you’d be the best person to access that – but this should give you some additional options to play with.

 

Option Explicit

Dim objXL As Excel.Application

Private Sub CreateNewIssue()
Dim intCode(1) As Integer
Dim varData(1) As Variant
Dim layBlock As AcadBlock
Dim elem As AcadEntity
Dim cLay As AcadLayout
Dim Array1 As Variant
Dim RowNum As Long
Dim aCount As Long
Dim Workbook As Excel.Workbook
Dim getAcObj As AcadObject
Dim anExcelActiveWorkBook As Excel.Workbook
Dim anExcelActiveSheet As Excel.Worksheet
Dim Cust() As String
Dim col As Long
Dim row As Long
Dim DrgNo As Long

  ' To Create Drawing Register / Doc Issue Sheet
  'SummaryInfo
  RowNum = 1
  DrgNo = 1
  'Checks Excel Is Running (Using Function IsExcel Running)
  If Not IsExcelRunning() Then
     MsgBox "Problem starting Excel!"
     Exit Sub
  End If
  
  
  'Turns Screen Updating Off While Doc Issue Populates
  objXL.Application.ScreenUpdating = True   'To Be Changed To False Upon Completion
  intCode(0) = 0: varData(0) = "Insert"
  intCode(1) = 2: varData(1) = "*Partners"
  If AllSS(intCode, varData) > 0 Then
     For Each elem In ThisDrawing.SelectionSets.Item("TempSSet")
     Set layBlock = ThisDrawing.ObjectIdToObject(elem.OwnerID)
     Set cLay = layBlock.Layout
        If elem.HasAttributes Then
           Array1 = elem.GetAttributes
           objXL.Visible = True
           objXL.WindowState = 3
           Set anExcelActiveWorkBook = objXL.Workbooks.Add
           anExcelActiveWorkBook.Activate
           Set anExcelActiveSheet = anExcelActiveWorkBook.ActiveSheet
           'Puts Titles On Sheet 1 (i.e Project1, Project 2, etc)
           For aCount = LBound(Array1) To UBound(Array1)
              anExcelActiveSheet.Cells(RowNum, aCount + 1) = Array1(aCount).TagString
           Next aCount
           RowNum = 2
        End If
        'Puts Information Under Titles (i.e 100 Street, Town)
        For aCount = LBound(Array1) To UBound(Array1)
           anExcelActiveSheet.Cells(RowNum, aCount + 1) = Array1(aCount).TextString
           anExcelActiveSheet.Columns(aCount + 1).EntireColumn.AutoFit
           objXL.Cells(RowNum, 16) = CStr(cLay.Name)
           objXL.Cells(RowNum, 17) = DrgNo
        Next aCount
        RowNum = RowNum + 1
        DrgNo = DrgNo + 1
     Next elem
     ' Taking custom properties
      
      Cust = GetCurrentCustoms()
      For row = 0 To UBound(Cust, 1)
          objXL.Cells(row + 2, 21) = Cust(row, 0)
          objXL.Cells(row + 2, 22) = Cust(row, 1)
      Next
  'Job Number
          objXL.Range("P2:P21").NumberFormat = "00"
          objXL.Sheets("Sheet1").Name = "Job Data"
  'Drawing Titles (Max 60 i.e Max 3 Sheets)
          objXL.Columns("R:R").ColumnWidth = 100
          objXL.Range("R2").Formula = "=IF(ISBLANK(D2),"" "",IF(ISBLANK(H2),D2,CONCATENATE(D2,"" "",E2,"" "",F2)))"
          objXL.Range("R3").Formula = "=IF(ISBLANK(D3),"" "",IF(ISBLANK(H3),D3,CONCATENATE(D3,"" "",E3,"" "",F3)))"
          objXL.Range("R4").Formula = "=IF(ISBLANK(D4),"" "",IF(ISBLANK(H4),D4,CONCATENATE(D4,"" "",E4,"" "",F4)))"
          objXL.Range("R5").Formula = "=IF(ISBLANK(D5),"" "",IF(ISBLANK(H5),D5,CONCATENATE(D5,"" "",E5,"" "",F5)))"
          objXL.Range("R6").Formula = "=IF(ISBLANK(D6),"" "",IF(ISBLANK(H6),D6,CONCATENATE(D6,"" "",E6,"" "",F6)))"
          objXL.Range("R7").Formula = "=IF(ISBLANK(D7),"" "",IF(ISBLANK(H7),D7,CONCATENATE(D7,"" "",E7,"" "",F7)))"
          objXL.Range("R8").Formula = "=IF(ISBLANK(D8),"" "",IF(ISBLANK(H8),D8,CONCATENATE(D8,"" "",E8,"" "",F8)))"
          objXL.Range("R9").Formula = "=IF(ISBLANK(D9),"" "",IF(ISBLANK(H9),D9,CONCATENATE(D9,"" "",E9,"" "",F9)))"
          objXL.Range("R10").Formula = "=IF(ISBLANK(D10),"" "",IF(ISBLANK(H10),D10,CONCATENATE(D10,"" "",E10,"" "",F10)))"
          objXL.Range("R11").Formula = "=IF(ISBLANK(D11),"" "",IF(ISBLANK(H11),D11,CONCATENATE(D11,"" "",E11,"" "",F11)))"
          objXL.Range("R12").Formula = "=IF(ISBLANK(D12),"" "",IF(ISBLANK(H12),D12,CONCATENATE(D12,"" "",E12,"" "",F12)))"
          objXL.Range("R13").Formula = "=IF(ISBLANK(D13),"" "",IF(ISBLANK(H13),D13,CONCATENATE(D13,"" "",E13,"" "",F13)))"
          objXL.Range("R14").Formula = "=IF(ISBLANK(D14),"" "",IF(ISBLANK(H14),D14,CONCATENATE(D14,"" "",E14,"" "",F14)))"
          objXL.Range("R15").Formula = "=IF(ISBLANK(D15),"" "",IF(ISBLANK(H15),D15,CONCATENATE(D15,"" "",E15,"" "",F15)))"
          objXL.Range("R16").Formula = "=IF(ISBLANK(D16),"" "",IF(ISBLANK(H16),D16,CONCATENATE(D16,"" "",E16,"" "",F16)))"
          objXL.Range("R17").Formula = "=IF(ISBLANK(D17),"" "",IF(ISBLANK(H17),D17,CONCATENATE(D17,"" "",E17,"" "",F17)))"
          objXL.Range("R18").Formula = "=IF(ISBLANK(D18),"" "",IF(ISBLANK(H18),D18,CONCATENATE(D18,"" "",E18,"" "",F18)))"
          objXL.Range("R19").Formula = "=IF(ISBLANK(D19),"" "",IF(ISBLANK(H19),D19,CONCATENATE(D19,"" "",E19,"" "",F19)))"
          objXL.Range("R20").Formula = "=IF(ISBLANK(D20),"" "",IF(ISBLANK(H20),D20,CONCATENATE(D20,"" "",E20,"" "",F20)))"
          objXL.Range("R21").Formula = "=IF(ISBLANK(D21),"" "",IF(ISBLANK(H21),D21,CONCATENATE(D21,"" "",E21,"" "",F21)))"
          objXL.Range("R22").Formula = "=IF(ISBLANK(D22),"" "",IF(ISBLANK(H22),D22,CONCATENATE(D22,"" "",E22,"" "",F22)))"
          objXL.Range("R23").Formula = "=IF(ISBLANK(D23),"" "",IF(ISBLANK(H23),D23,CONCATENATE(D23,"" "",E23,"" "",F23)))"
          objXL.Range("R24").Formula = "=IF(ISBLANK(D24),"" "",IF(ISBLANK(H24),D24,CONCATENATE(D24,"" "",E24,"" "",F24)))"
          objXL.Range("R25").Formula = "=IF(ISBLANK(D25),"" "",IF(ISBLANK(H25),D25,CONCATENATE(D25,"" "",E25,"" "",F25)))"
          objXL.Range("R26").Formula = "=IF(ISBLANK(D26),"" "",IF(ISBLANK(H26),D26,CONCATENATE(D26,"" "",E26,"" "",F26)))"
          objXL.Range("R27").Formula = "=IF(ISBLANK(D27),"" "",IF(ISBLANK(H27),D27,CONCATENATE(D27,"" "",E27,"" "",F27)))"
          objXL.Range("R28").Formula = "=IF(ISBLANK(D28),"" "",IF(ISBLANK(H28),D28,CONCATENATE(D28,"" "",E28,"" "",F28)))"
          objXL.Range("R29").Formula = "=IF(ISBLANK(D29),"" "",IF(ISBLANK(H29),D29,CONCATENATE(D29,"" "",E29,"" "",F29)))"
          objXL.Range("R30").Formula = "=IF(ISBLANK(D30),"" "",IF(ISBLANK(H30),D30,CONCATENATE(D30,"" "",E30,"" "",F30)))"
          objXL.Range("R31").Formula = "=IF(ISBLANK(D31),"" "",IF(ISBLANK(H31),D31,CONCATENATE(D31,"" "",E31,"" "",F31)))"
          objXL.Range("R32").Formula = "=IF(ISBLANK(D32),"" "",IF(ISBLANK(H32),D32,CONCATENATE(D32,"" "",E32,"" "",F32)))"
          objXL.Range("R33").Formula = "=IF(ISBLANK(D33),"" "",IF(ISBLANK(H33),D33,CONCATENATE(D33,"" "",E33,"" "",F33)))"
          objXL.Range("R34").Formula = "=IF(ISBLANK(D34),"" "",IF(ISBLANK(H34),D34,CONCATENATE(D34,"" "",E34,"" "",F34)))"
          objXL.Range("R35").Formula = "=IF(ISBLANK(D35),"" "",IF(ISBLANK(H35),D35,CONCATENATE(D35,"" "",E35,"" "",F35)))"
          objXL.Range("R36").Formula = "=IF(ISBLANK(D36),"" "",IF(ISBLANK(H36),D36,CONCATENATE(D36,"" "",E36,"" "",F36)))"
          objXL.Range("R37").Formula = "=IF(ISBLANK(D37),"" "",IF(ISBLANK(H37),D37,CONCATENATE(D37,"" "",E37,"" "",F37)))"
          objXL.Range("R38").Formula = "=IF(ISBLANK(D38),"" "",IF(ISBLANK(H38),D38,CONCATENATE(D38,"" "",E38,"" "",F38)))"
          objXL.Range("R39").Formula = "=IF(ISBLANK(D39),"" "",IF(ISBLANK(H39),D39,CONCATENATE(D39,"" "",E39,"" "",F39)))"
          objXL.Range("R40").Formula = "=IF(ISBLANK(D40),"" "",IF(ISBLANK(H40),D40,CONCATENATE(D40,"" "",E40,"" "",F40)))"
          objXL.Range("R41").Formula = "=IF(ISBLANK(D41),"" "",IF(ISBLANK(H41),D41,CONCATENATE(D41,"" "",E41,"" "",F41)))"
          objXL.Range("R42").Formula = "=IF(ISBLANK(D42),"" "",IF(ISBLANK(H42),D42,CONCATENATE(D42,"" "",E42,"" "",F42)))"
          objXL.Range("R43").Formula = "=IF(ISBLANK(D43),"" "",IF(ISBLANK(H43),D43,CONCATENATE(D43,"" "",E43,"" "",F43)))"
          objXL.Range("R44").Formula = "=IF(ISBLANK(D44),"" "",IF(ISBLANK(H44),D44,CONCATENATE(D44,"" "",E44,"" "",F44)))"
          objXL.Range("R45").Formula = "=IF(ISBLANK(D45),"" "",IF(ISBLANK(H45),D45,CONCATENATE(D45,"" "",E45,"" "",F45)))"
          objXL.Range("R46").Formula = "=IF(ISBLANK(D46),"" "",IF(ISBLANK(H46),D46,CONCATENATE(D46,"" "",E46,"" "",F46)))"
          objXL.Range("R47").Formula = "=IF(ISBLANK(D47),"" "",IF(ISBLANK(H47),D47,CONCATENATE(D47,"" "",E47,"" "",F47)))"
          objXL.Range("R48").Formula = "=IF(ISBLANK(D48),"" "",IF(ISBLANK(H48),D48,CONCATENATE(D48,"" "",E48,"" "",F48)))"
          objXL.Range("R49").Formula = "=IF(ISBLANK(D49),"" "",IF(ISBLANK(H49),D49,CONCATENATE(D49,"" "",E49,"" "",F49)))"
          objXL.Range("R50").Formula = "=IF(ISBLANK(D50),"" "",IF(ISBLANK(H50),D50,CONCATENATE(D50,"" "",E50,"" "",F50)))"
          objXL.Range("R51").Formula = "=IF(ISBLANK(D51),"" "",IF(ISBLANK(H51),D51,CONCATENATE(D51,"" "",E51,"" "",F51)))"
          objXL.Range("R52").Formula = "=IF(ISBLANK(D52),"" "",IF(ISBLANK(H52),D52,CONCATENATE(D52,"" "",E52,"" "",F52)))"
          objXL.Range("R53").Formula = "=IF(ISBLANK(D53),"" "",IF(ISBLANK(H53),D53,CONCATENATE(D53,"" "",E53,"" "",F53)))"
          objXL.Range("R54").Formula = "=IF(ISBLANK(D54),"" "",IF(ISBLANK(H54),D54,CONCATENATE(D54,"" "",E54,"" "",F54)))"
          objXL.Range("R55").Formula = "=IF(ISBLANK(D55),"" "",IF(ISBLANK(H55),D55,CONCATENATE(D55,"" "",E55,"" "",F55)))"
          objXL.Range("R56").Formula = "=IF(ISBLANK(D56),"" "",IF(ISBLANK(H56),D56,CONCATENATE(D56,"" "",E56,"" "",F56)))"
          objXL.Range("R57").Formula = "=IF(ISBLANK(D57),"" "",IF(ISBLANK(H57),D57,CONCATENATE(D57,"" "",E57,"" "",F57)))"
          objXL.Range("R58").Formula = "=IF(ISBLANK(D58),"" "",IF(ISBLANK(H58),D58,CONCATENATE(D58,"" "",E58,"" "",F58)))"
          objXL.Range("R59").Formula = "=IF(ISBLANK(D59),"" "",IF(ISBLANK(H59),D59,CONCATENATE(D59,"" "",E59,"" "",F59)))"
          objXL.Range("R60").Formula = "=IF(ISBLANK(D60),"" "",IF(ISBLANK(H60),D60,CONCATENATE(D60,"" "",E60,"" "",F60)))"
          objXL.Range("R61").Formula = "=IF(ISBLANK(D61),"" "",IF(ISBLANK(H61),D61,CONCATENATE(D61,"" "",E61,"" "",F61)))"
           objXL.UserControl = True
              
      objXL.Application.ScreenUpdating = True 'Needs to Be Last Entry
  End If
End Sub


Function IsExcelRunning() As Boolean

On Error Resume Next
  Set objXL = GetObject(, "Excel.Application")
  If Err <> 0 Then
     Err.Clear
     Set objXL = CreateObject("Excel.Application")
     If Err <> 0 Then
        Err.Clear
        IsExcelRunning = False
        Exit Function
     End If
  End If
  IsExcelRunning = True
End Function
Function GetCurrentCustoms() As Variant
   Dim Num As Long
   Dim Index As Long
   Dim CustomKey As String
   Dim CustomValue As String
   Dim Sum As AcadSummaryInfo
   Set Sum = ThisDrawing.SummaryInfo
   Dim Cnt As Long

   Num = Sum.NumCustomInfo
   ReDim Cust(0 To Num - 1, 0 To 1) As String
   For Index = 0 To Num - 1
       Sum.GetCustomByIndex Index, CustomKey, CustomValue
       Cust(Cnt, 0) = CustomKey
       Cust(Cnt, 1) = CustomValue
       Cnt = Cnt + 1
   Next Index

   Set Sum = Nothing
   GetCurrentCustoms = Cust
   End Function
   
   Sub SSClear()
Dim SSS As AcadSelectionSets
  On Error Resume Next
  Set SSS = ThisDrawing.SelectionSets
     If SSS.Count > 0 Then
        SSS.Item("TempSSet").Delete
     End If
End Sub


Function AllSS(Optional grpCode As Variant, Optional dataVal As Variant) As Integer
  Dim TempObjSS As AcadSelectionSet
  SSClear
  Set TempObjSS = ThisDrawing.SelectionSets.Add("TempSSet")
        'pick selection set
  If IsMissing(grpCode) Then
     TempObjSS.Select acSelectionSetAll
  Else
     TempObjSS.Select acSelectionSetAll, , , grpCode, dataVal
  End If
  AllSS = TempObjSS.Count
End Function

streng Contributor

streng

Posted
  • Author
Posted

You're a star.

 

Have altered the output to list as before.

 

Unfortunately I have one more problem.

 

Although most blocks are called "*Partners"

How do I add another to include "A4Sketch"

 

Regards

 

Streng

SEANT Veteran

SEANT

Posted
Posted

I'm not in a position to test it but believe:

 

intCode(1) = 2: varData(1) = "*Partners,A4Sketch"

 

should do.

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...