Change block layer with Excel input

[Anonymous]

I'm currently using AutoCAD 2014. I'm use to using AutoCAD but have never used VBA or AutoLISP before. Really just found out about them from doing some research on the internet and hoping for some help with my dilema. I have a floor plan already drawn and each individual room already has a seperate hatch created as a block. What I would like to be able to do is somehow make the layer of the block change to represent the percent completion of each room. I would ideally like to just be able to make an Excel spreadsheet that contains in column A the block title like Kitchen, Bath Room 1, Living Room, etc. and column B would contain the layer I want to move it to. So when I change column B from 20 to 30 the layer updates automatically. A couple different people will be imputting in to the spreadsheet which is why I want it to be able to the update automatically when needed.  My floor plan contains about 60 different spaces (blocks) and has about 10 different colors (layers) to represent the percent completes.  I'm not really sure how to go about this but I'm very much willing to learn. Eventually the drawing will grow to have over 300 individual blocks and around 12 layers. So you can see the amount of effort it would save versus selecting each block and changing it's layer individually.

Thanks,

JMB

[Anonymous]

I found this code online that has some of what I need. Just not sure how to edit it to change the part about inserting the structure attribute to the block to make it change the layer of the selected block to match column B of the spreadsheet.

Option Explicit
'' ----------------------------------------------'
'' Require Reference to:
'' Tools--> References --> AutoCAD 2XXX Type Library
'' Tools--> References --> AutoCAD Focus Control for VBA Type Library
'' and also set options here:
''Tools--> Opyions --> Genetral --> Error Trapping -> check 'Break on Unhahdled Errors'
 
Dim acApp As AcadApplication
Dim acDocs As AcadDocuments
Dim acDoc As AcadDocument
Dim acSpace As AcadBlock
'----------------------------------------------'
Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
'----------------------------------------------'
Public Sub UpdateBlocks()
Dim xlValues As Variant
Dim attValues() As String
ThisWorkbook.Worksheets("Sheet1").Activate
xlValues = Range("A1:A10").Value
Dim i
For i = LBound(xlValues, 1) To UBound(xlValues, 1)
ReDim Preserve attValues(i - 1)
attValues(i - 1) = CStr(xlValues(i, 1))
Next
Dim strDrawing As String
Dim strTag As String
Dim oBlkRef As AcadBlockReference
Dim attVar As Variant
Dim oAttrib As AcadAttributeReference
On Error Resume Next
Set acApp = GetObject(, "AutoCAD.Application")
If Err.Number <> 0 Then
Err.Clear
Set acApp = CreateObject("AutoCAD.Application")
End If
On Error GoTo Err_Control
acApp.Visible = True
SetFocus acApp.hwnd
Application.WindowState = xlMinimized
acApp.WindowState = acMax
strDrawing = "C:\Test\Blah.dwg" '<-- change drawing name
Set acDocs = acApp.Documents
Set acDoc = acDocs.Open(strDrawing, False)
acDoc.Activate
 
Set acDoc = acApp.ActiveDocument
Dim fType(1) As Integer
Dim fData(1) As Variant
Dim dxfCode, dxfValue
fType(0) = 0: fData(0) = "INSERT"
fType(1) = 66: fData(1) = 1
dxfCode = fType: dxfValue = fData
Dim oSset As AcadSelectionSet
With acDoc.SelectionSets
While .Count > 0
.Item(0).Delete
Wend
Set oSset = .Add("MyBlocks")
End With
 
acApp.Eval ("msgbox(" & Chr(34) & "Select blocks one-by-one" & Chr(34) & ")")
oSset.SelectOnScreen dxfCode, dxfValue
If oSset.Count = 0 Then
MsgBox "Nothing selected"
Exit Sub
End If
strTag = "STRUCTURE" 
Dim oEnt As AcadEntity
 
Dim n
 
n = LBound(attValues)
 
For Each oEnt In oSset
 
Set oBlkRef = oEnt
 
attVar = oBlkRef.GetAttributes
 
For i = LBound(attVar) To UBound(attVar)
 
Set oAttrib = attVar(i)
 
If StrComp(UCase(oAttrib.TagString), strTag, vbTextCompare) = 0 Then
 
oAttrib.TextString = attValues(n)
 
n = n + 1
 
Exit For
 
End If
 
Next i
 
Next oEnt
 
SetFocus Application.hwnd '' you go back to Excel
acDoc.Close True, strDrawing '' close drawing, saving changes
acApp.Quit
Set acDoc = Nothing
Set acApp = Nothing
Application.WindowState = xlMaximized
Err_Control:
If Err.Number <> 0 Then
MsgBox Err.Description
End If
End Sub
'----------------------------------------------'

[Anonymous]

this is macro Vba could match your request.a I post youtube link where you can how macro works and If you want you can dowload It from my blog.

https://www.youtube.com/watch?v=oGyCLcY7-HE

This macro allows to import in Excel  spreadsheet from .dwg file text, lines lenght, polylines area values. First you have to define from which layer you want to import values.

check the link and let me know which functions of my VBA macro can be useful for you and which need to be added.

I'm in a hurry and I didn't read completely your post but we can fix problems next time.

Vittorio

[Anonymous]

Hi there,

I am facing same situation with you. Glad that you have got script for the solution.

I have no VBA knowledge..   So I copy & paste the script and then a warning appears:

Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long

Is it related to my windows x64?

So far, have you been able to change CAD colour via text modification in excel?

Thank you...

Best

Bagus

[JuJitsoup]

I'm in the exact same situation. Did anyone ever find a solution? 

[Ed__Jobe]

Can you be more specific? What situation? If you are talking about the error on the declaration statement, you need to include the PtrSafe statement as follows.

Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long

[JuJitsoup]

Thanks for the reply. I posted a new thread as my requirements differ slightly from this.