VBA Manipulation of blocks

[Riddlez]

I have been working with VBA for about 2 weeks now and have hit a road block in writing a program. I do have some programming background, but not much and I am probably using funcitons and code snip-its that go well beyond my total understanding of VBA and AutoCAD.

 

Essentially, my code needs to store information from a specified block on all layouts. Then, delete the blocks via their handles. Then purge the old block so that a replacement can be entered from a directory. Then, update the inserted blocks with the old data.

 

Problem 1: I can't seem to get the variable "Entity" to initialize/be assigned an entity/oject/block via the 2nd 'For Each loop' so that I can extract the data.

 

Problem 2: Is there a way to insert my block without using the purgeall command? I've tried to understand a "copy and replace" method, but couldn't wrap my head around it.

 

Problem 3: Is there a way to insert a block and have it simultaneously be assigned to a variable (that would make it so I could modfy the marked areas "Problem 3" so that they can upload attributes via taking the handle off of the inserted block).

 

Any other comments about the code that can save computing time, would help too. And there are some redundant/empty/useless variables, I just haven't been able to weed them out as of yet.

 

Thank you in advance for your help,

Riddlez.

 

Option Explicit
Sub open_AutoCAD_and_other_files()
Dim a, array1, As Variant
Dim insrtionpoint(0 To 2) As Double
Dim count As Variant
Dim vesselname, udblk, blockname, hndle, repblkdir As String
Dim vesrow,vesnum, repnum, attnum, atttot, blknum, counter, strt As integer Dim blocknameloc, tagflag, i, j, blknew As Integer
Dim x As Variant
Dim y As Variant
Dim z As Variant
Dim excelvsheet, acadapp, excel, acaddoc, currentspace As Object
Dim actvecell, actvecells, blk2bdltd As Object
Dim Entity As AcadEntity
Dim aLAYOUT As AcadLayout
Dim cLAYOUT As AcadLayout
Dim rttion As Double

On Error Resume Next
'Checks if autocad is open and then opens if otherwise
Set acadapp = Nothing
Set acadapp = GetObject(, "AutoCAD.Application")
If Err Then
   Err.Clear
   MsgBox ("Autocad is not running, now attempting to hack your e-mail.")
   Set acadapp = CreateObject("AutoCADLT.Application")
   Set acadapp = GetObject(, "AutoCAD.Application")
   acadapp.Visible = 1
End If
acadapp.ActiveDocument.Close
'makes autocad visible so that the user can see the files opening
acadapp.Visible = 1

'designates the object excel as the application that is open
Set excel = GetObject(, "Excel.Application")

'Turns screen updating off so the fuction can run more quickly.
Application.ScreenUpdating = False

'Deletes all other worksheets if ok is pressed
If MsgBox("Delete uneeded sheets?", vbOKCancel) = vbOK Then
   Dim ws As Worksheet
   Application.DisplayAlerts = False
   For Each ws In ThisWorkbook.Worksheets
       If ws.Name <> "Sheet1" Then ws.Delete
   Next ws
   Application.DisplayAlerts = True
   Else
   Exit Sub
End If

'moves to sheet1 and counts from A2 to the end of a continuous block of rows to know total number of repetitions
Worksheets("Sheet1").Activate
vesnum = Range("A2").CurrentRegion.Rows.count

'determines the number of replacement blocks
repnum = Range("D2").CurrentRegion.Rows.count

'allows the user to input a value for block that is to be replaced
udblk = InputBox("What block do you wish to replace?", "User Input", "NULL")

'Begins the "big" loop - Contains the functions that will be repeated for each file
For vesrow = 2 To (vesnum + 1) 'the ending value is not inclusive (i.e. 1 To 4 does 3 iterations, 1,2 and 3)

'looks in Sheet1 for the vessel name, checks if there is a sheet by that name and creates it if there isn't one
   Worksheets("Sheet1").Activate
   vesselname = Cells(vesrow, 1)

   Worksheets(vesselname).Activate
   If Err Then
       Error.Clear
       Sheets.Add.Name = "" & vesselname
   End If

   'open autocad doc from cell
   Worksheets("Sheet1").Activate
   Set acaddoc = acadapp.Documents.Open(Cells(vesrow, 2))

   'initializes blknum to 0, since this is the beginning of a new dwg
   blknum = 0
   tagflag = 1

'PROBLEM 1
For Each aLAYOUT In acaddoc.Layouts
   ActiveWorkbook.Sheets(vesselname).Cells(blknum + 1, 1).EntireRow.Borders.Item(xlEdgeBottom).Weight = xlThick
   aLAYOUT.Activate
       If aLAYOUT.Name <> "Model" Then
       'starts a loop that checks ALL objects/elements in a space
       For Each Entity In aLAYOUT.Block

           With Entity
'If the block is the one that is going to be replaced, then place a 1 in the 200th row of the block's column, otherwise put a 0
               If Entity.Name = udblk Then
                   'Increment the block count by one since it has found a new block
                   blknum = blknum + 1

'not sure if 'a' is necessary, but this part gets the attributes and insertion points of the current block
    a = .GetDynamicBlockProperties
    Application.StatusBar = "Processing: " & CStr(Entity.Handle)
    array1 = .GetAttributes
    array2 = .insertionpoint

'check total number of attributes in array1 and add one because Ubound returns the last array number which is one less than the total amount of points
    attnum = UBound(array1) + 1
                     
'store the total number of attributes for use in placing the information into columns
     atttot = attnum
                     
If tagflag = 1 Then
         counter = attnum
     While counter > 0
        ActiveWorkbook.Sheets(vesselname).Cells(1, atttot - counter + 1).Value = array1(atttot - counter).TagString
         counter = counter - 1
     Wend
   ActiveWorkbook.Sheets(vesselname).Cells(1, 252).Value = "x"
   ActiveWorkbook.Sheets(vesselname).Cells(1, 253).Value = "y"
   ActiveWorkbook.Sheets(vesselname).Cells(1, 254).Value = "z"
   ActiveWorkbook.Sheets(vesselname).Cells(1, 255).Value = "Element Rotation"
   ActiveWorkbook.Sheets(vesselname).Cells(1, 256).Value = "Element Handle"
                           
   tagflag = tagflag - 1
End If

'for every attribute, place the stored information in a column
   While attnum > 0
        ActiveWorkbook.Sheets(vesselname).Cells(blknum + 1, atttot - attnum + 1).Value = array1(atttot - attnum).TextString
       attnum = attnum - 1
   Wend
                           
'after the attributes listed in the column, place the handle, insertion point and name of the attribute
    x = array2(0)
    y = array2(1)
    z = array2(2)
                       
    ActiveWorkbook.Sheets(vesselname).Cells(blknum + 1, 252).Value = x
    ActiveWorkbook.Sheets(vesselname).Cells(blknum + 1, 253).Value = y
    ActiveWorkbook.Sheets(vesselname).Cells(blknum + 1, 254).Value = z
    ActiveWorkbook.Sheets(vesselname).Cells(blknum + 1, 255).Value = .Rotation
   ActiveWorkbook.Sheets(vesselname).Cells(blknum + 1, 256).Value = "'" & CStr(Entity.Handle)

          'end If
      End If
   End With
Next Entity
End If
Next aLAYOUT

'limit the next loop to the number of blocks in existance
     counter = blknum
     strt = 2

'conditionally searches row 200 for a 1.  if it finds it, it
'replaces the block with a block from another file and uploads the data
     While counter > 0
       ActiveWorkbook.Sheets(vesselname).Activate
       hndle = Cells(strt, 256).Value
       Set blk2bdltd = acadapp.ActiveDocument.HandleToObject(hndle)
       blk2bdltd.Delete
       counter = counter - 1
       strt = strt + 1
     Wend

'PROBLEM 2 -is there a way to do this without deleting unused Layers?
   acaddoc.PurgeAll

   counter = blknum
   strt = 2
   While counter > 0
       ActiveWorkbook.Sheets(vesselname).Activate

       insrtionpoint(0) = Cells(strt, 252).Value
       insrtionpoint(1) = Cells(strt, 253).Value
       insrtionpoint(2) = Cells(strt, 254).Value
       rttion = Cells(strt, 255).Value

'could be paper space depending on function. for testing it is the model space
     repblkdir = excel.ActiveWorkbook.Sheets("Sheet1").Cells(2, 5).Value

'PROBLEM 3
     elem2 = acaddoc.ModelSpace.InsertBlock(insrtionpoint, repblkdir, 1#, 1#, 1#, rttion)

     counter = counter - 1
     strt = strt + 1
     Wend

     Set currentspace = acaddoc.ModelSpace

'PROBLEM 3
   blknew = 0
   count = acaddoc.ModelSpace.count

       While blknum > 0
       Set elem2 = acaddoc.ModelSpace.Item(count - blknum)
 
'Checks to see if the element is a block
           If StrComp(elem2.EntityName, "AcDbBlockReference", 1) = 0 Then

'If the block is the one that is going to be replaced, then place a 1 in the 200th row of the block's column, otherwise put a 0
        If elem2.Name = udblk Then
        blknew = blknew + 1
'not sure if 'a' is necessary, but this part gets the attributes and insertion points of the current block
               a = elem2.GetDynamicBlockProperties
               Application.StatusBar = "Processing: " & CStr(elem2.Handle)
               array1 = elem2.GetAttributes
               array2 = elem2.insertionpoint
                       For i = 0 To atttot - 1
                               array1(i).TextString = ActiveWorkbook.Sheets(vesselname).Cells(blknew + 1, i + 1)
                       Next i
                   ActiveWorkbook.Sheets(vesselname).Cells(blknew + 1, 256).Value = "'" & CStr(elem2.Handle)
                  strt = strt + 1
              End If
         End If
    blknum = blknum - 1
Wend
acaddoc.Save
acaddoc.Close
Next vesrow
'Incase of error, still shows AutoCAD
acaddoc.Visible = 1
End Sub

[Riddlez]

I forgot to mention that it is using excel as the interface, in that all the directories and sheet names would have to be inserted into "Sheet1" in Row 2 and down. Column 1 for the reference/file/vessel name and Column 2 for the directory of the file with the aforementioned name.

 

Columns 4 and 5 are for the block that is going to be replaced throughout all the files.

 

This is so that you can dump names and directories into the spreadsheet and have the code do it's thing for all the files.

 

I'm sorry ahead of time, if I am doing anything that is considered: inconsiderate, of bad manners when posting in a forum or anything of such a nature.

 

I look forward to you responses,

Riddlez.

[Riddlez]

Solved my problem. Sorry to anyone that has been trying to work it out before they responded.

 

If anyone wants to know what I did, feel free to drop a reply asking.

 

Cheers,

Riddlez.