Link Excel VBA to acad

[pksen]

Hi guys ,

I got struck with my project.How to change the Auto cad block attributes through Microsoft excel using VBA.Please guide using VBA code.

Example:Excel has some value in cells 1 to 10, which has to be fetched in the Auto cad block attributes through VBA code.Please reply any one ASAP

Thanks in advance.

[fixo]

Did you mean that all these attributes will be applied for a single block wich is you will be select on screen,

Or you want to apply these values to many blocks globally, would be good to know

the block name in this case

And also will be this Excel file open before or you need to open it in the session from

File dialog?

What is your Acad release and platform?

[fixo]

Here is very basic example

 
Option Explicit
'' Require Reference to:
'' Tools--> References --> Microsoft Excel 1X.0 Type Library
'' and also you have to set options here:
'' Tools--> Options --> Genetral --> Error Trapping -> check 'Break on Unhahdled Errors'
'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ''
Const xlFileName As String = "C:\Test\TitleBlock.xls" '<-- change data file name
Const sheetName As String = "MyAttributes" '<-- change sheet name
Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
''------------Late binding example:------------------''
Sub LateBindingExcel()
Dim xlApp As Object
Dim xlBooks As Object
Dim xlBook As Object
Dim xlSheets As Object
Dim xlSheet As Object
Dim xlCells As Object
Dim xlRange As Object
On Error GoTo Err_Control
On Error Resume Next
Set xlApp = Nothing
Set xlApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set xlApp = CreateObject("Excel.Application")
End If
Err.Clear
Set xlBooks = xlApp.Workbooks
If xlBooks.Count > 0 Then
Set xlBook = xlBooks.Item(1)
End If
If xlBooks.Count = 0 Then
Set xlBook = xlBooks.Open(xlFileName, False)
End If
Set xlSheets = xlBook.worksheets
Set xlSheet = xlSheets.Item(sheetName)  '<--- change a sheet name (might be a sheet number instead)
xlSheet.Application.Visible = True
Set xlCells = xlSheet.Cells
Set xlRange = xlCells.Range("$A1:$A10")
Dim i As Long
i = 1
Dim strAddr As String
Dim attrData(0 To 9) As String
For i = 1 To 10
strAddr = "A" & CStr(i)
Set xlRange = xlCells.Range(strAddr)
Dim cellVal
cellVal = xlRange.Value
attrData(i - 1) = CStr(cellVal) '<-- store data you took from Excel for the future use
Next
ThisDrawing.Activate
' keep this order
Set xlRange = Nothing
Set xlCells = Nothing
Set xlSheet = Nothing
Set xlSheets = Nothing
xlBook.Close False
Set xlBook = Nothing
Set xlBooks = Nothing
xlApp.Quit
Set xlApp = Nothing
MsgBox "Select blocks"
''------------- End of Excel work-----------------''
Dim oEnt As AcadEntity
Dim oBlkRef As AcadBlockReference
Dim oAttrib As AcadAttributeReference
Dim attVal  As Variant
Dim ftype(0 To 1) As Integer
Dim fdata(0 To 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 ThisDrawing.SelectionSets
              While .Count > 0
                   .Item(0).Delete
              Wend
         Set oSset = .Add("$MyBlocks$")
         End With

oSset.SelectOnScreen dxfCode, dxfValue
If oSset.Count = 0 Then
MsgBox "nothing selected, exit..."
Exit Sub
End If
For Each oEnt In oSset
Set oBlkRef = oEnt
attVal = oBlkRef.GetAttributes
For i = LBound(attrData) To (UBound(attrData)) '<-- assuming a contents size of the stored data
Set oAttrib = attVal(i)
If attrData(i) <> vbNullString Then
oAttrib.TextString = attrData(i)
End If
Next i
Next oEnt
Err_Control:
If Err.Number <> 0 Then
MsgBox Err.Description
End If
End Sub

 

~'J'~

[pksen]

Dear Friend,

I mean 1 particular cell value for one block attribute in acad.

I will open the acad file through excel vba,I'm have the code also its working basically.

My basic need is i need to fetch excel cell to autocad block attribute without using coordinate through vba codes.

(currently i'm using through co-ordination it functioning, but when you change the co-ordinates position the values are all gets changed)

Only i want to link excel cell value to autocad.

 

Let me explain you the basic,

i'm having 10 nos of constant block attributes in autocad.(that will not get change)My basic need is while running a vba it has to take a value from excel cells. because every time i'm running a vba means the value gets change.its a variables.

 

I want code like a,cad block attribute name called A.For that A block i have to take a value from excel cell.(Say cell(5,5))Like that.

I want to link both this.

Please help, i'm very new to this.

Edited January 21, 2012 by pksen

[fixo]

In this case you have to store your data in Excel in two colums:

First colum will store Handle values for every block,

the second one for attribute value

In AutoCAD you could be able select every block by its Handle

using HandleToObject method of ThisDrawing object,

Then you go usual way, nothing difficult is there

You can grab the file from here:

http://dl.dropbox.com/u/18024145/VBAExcelAutoCAD.xls

This one is for text and mtext but you can easily rewrite them to

your suit

[pksen]

Is there is any method to link excel text to autocad text.without using co-ordinates.While running a VBA the excel text has to update in autocad text.

[fixo]

Just in case if you know Handle property of this text object

and this handle was stored in the excel celll as string

then you can reach at this object in the drawing using HandleToObject

method and change its textstring

I answered you on this question in the thread below btw

First you need to store handles of the text (s) in the first column , say "A"

then in the next column "B" you can store (or set new text string instead)

then just open drawing from Excel, find objects by its handles:

pseudo-code in the Excel module:

 
dim obj as AcadEntity
Dim oText as AcadText
dim handlerange as range
dim textrange as range
set handlerange=mySheet.Range("A1000")
set textrange=mySheet.Range("B1000")
Set obj= thisdrawing.HandleToObject(range.Value)
set txtobj= obj
txtobj.TextString= textrange.value''--> or value2

[pksen]

Hi,

I want to link excel cell value to autocad attribute block.while running a VBA excel value has to update in block attributes value.Block attribute name is constant,Only variable is the excel value.I have a code for opening a acad in excel.

But i need a code for this option only.Please any one help me through any codes.

[pksen]

Dear Fixo,

I'm very new to this.what is the HANDLETOOBJECT.

my problem is i'm having 10 variable values in excel cells(ie:10cells). & i'm having constant 10 block attributes in acad.

while running a VBA these excel text has to paste in acad text that 10 block attriubutes value.

Please help me through code sir.

[fixo]

What is the block name and attribute tag?

[pksen]

Block Name is A , Attribute tag is Structure , only the block vale has to update

[SLW210]

I merged all of your threads.

[fixo]

I can't to do your homework completely,

better yet to see the Help file, docs, search for desired info

on this forum and on other forums

Add block name you need to selection filter by yourself,

it's the very last post of mine in this thread

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

 

~'J'~

Edited January 23, 2012 by fixo
spell check

[Alt]

Dear fixo,

 

 

Can you post your VBAExcelAutoCAD.xls once again please? Link is dead now.

 

 

Regards!

[jmb789]

I can't to do your homework completely,

better yet to see the Help file, docs, search for desired info

on this forum and on other forums

Add block name you need to selection filter by yourself,

it's the very last post of mine in this thread

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

~'J'~

 

How could I modify this code to work for my application. I want to make a named block which represents column A in a spreadsheet change to a layer represented by column B? I kind of see each function is doing but don't know enough to see where to make the changes.

[blintz]

hello Fixo

I have an excel spreadsheet with which I put in certain coordinates of the blocks

The Excel table is structured so as to have axis X , Y, Z , name of the block , scale X , Y, Z , rotation angle.

At the table there is no reference to " TAG1 " to assign the technical code block .

I tried to download the file to Dropbox but there's more

you can download it ?