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
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 '----------------------------------------------'
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
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
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