Macro - Acad 2 Excel

Can someone help? I need to make a macro to send Title block data from
Autocad to Excel. I have no ideas as to how to do this....

many thanks!

 

do a search at vbdesign.net it has already been done.

 

I am afraid a search has left me even more confused! I just want to send
the data from the Title Block to Excel. It would be nice if the macro
checked if Excel was open first, and opened the program if it wasnt
already opened! Is this possible?
I am a total newbie to this!
If anyone can explain in a code snippet?

tia

 

My software will do what you want, but it is overkill.

--
David Wishengrad
President & CTO
MillLister, Inc.
Software for measuring and stretching multiple 3D solids.
Http://Construction3D.com

 

This worked in A2K. Add project reference to "MS Excel 9.0 Object Library".

Private Sub ACAD2Excel()
Dim oExcel As Excel.Application, oWrkBk As Excel.Workbook, oWrkSh As
Excel.Worksheet
Dim sTextOut As String, sTextIn As String

Set oExcel = New Excel.Application
Set oWrkBk = oExcel.Workbooks.Open(<"DRIVE:\PATH\WORKBOOK.XLS">)
Set oWrkSh = oWrkBk.Worksheets(<"WORKSHEET NAME">)
sTextOut = <"Some title block text">

' Send Acad text to Excel cell
oWrkSh.[A1] = sTextOut ' set Excel cell value = text

oWrkSh.Calculate ' Optionally recalc worksheet

' Send Excel cell to Acad text
sTextIn = oWrkSh.[A1] ' set text = Excel cell value
End Sub

 

Hmmn, thx John.
I must be doing something wrong? Just cant get this to work?
Think i need a dummies guide!
I am an ACAD and VB newbie (which does not help!)

 

does it matter if project reference is MS Excel 11.0 Object Library? I
have no MS Excel 9.0 Object Library in the list!

 

That should work OK. Are you getting any error messages?

 

Thanks again for the reply John.
I am getting a compile error (syntax error) on line 1 of your code?

Has the syntax changed between Autocad releases?

I was told that the original code i posted worked on earlier releases
of Autocad/M$ Office, and yet i just can not get it to work?

<b>Original Code:</b>


Code:
--------------------

' Declare necessary API routines:
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As Long) As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Sub Extract()

Dim MyXL As Object
Dim ExcelWasNotRunning As Boolean
Dim RowNum As Integer
Dim Array1 As Variant
Dim Count As Integer
Dim SSNew As Object

'------------------------------------------------
' Start Excel if not running

On Error Resume Next

Set MyXL = GetObject(, "Excel.Application")
If Err <> 0 Then ExcelWasNotRunning = True
Err.Clear

'Check For Excel. If Excel is Running Enter into Running Object Table
DetectExcel ' ==== This is a future Sub Routine Name

'Set the object variable to the reference you want to see.
Set MyXL = GetObject("C:\ACADTBL.XLS")

MyXL.Application.Visible = True
MyXL.Parent.Windows(2).Visible = True
MyXL.Application.Windows("ACADTBL.xls").Activate
MyXL.Application.Windows("PERSONAL.xls").Visible = False
MyXL.Application.Windows("MAT.xls").Visible = False

Dim header As Boolean
header = False
Set SSNew = ThisDrawing.SelectionSets.Add("TEMP")
Dim PT1(0 To 2) As Double
Dim PT2(0 To 2) As Double
Dim GC(0 To 1) As Integer
Dim GV(0 To 1) As Variant
Dim Attribs
PT1(0) = 0#
PT1(1) = 0#
PT1(2) = 0#
PT2(0) = 0#
PT2(1) = 0#
PT2(2) = 0#
GC(0) = 0
GV(0) = "INSERT"
GC(1) = 2
GV(1) = "PCKEY"
SSNew.Select acSelectionSetAll, PT1, PT2, GC, GV

'------------------------------------------------
' Extract the Attributes!

MyXL.Application.Worksheets("Acad").Select
MyString = MyXL.Application.Cells(1, 6).Value
I = 1
While (MyString <> "")
MyString = MyXL.Application.Cells(I, 6).Value
I = I + 1
Wend

If I = 1 Then
I = 1
End If
If I > 2 Then
I = I - 1
End If

For Each Entity In SSNew
Array1 = Entity.GetAttributes
For Count = LBound(Array1) To UBound(Array1)
MyXL.Application.Cells(I, Count + 6).Value = Array1(Count).TextString
Next Count
header = True

MyStr = UCase(MyXL.Application.Cells(I, 7).Value)
MyXL.Application.Cells(I, 1).Value = Mid(MyStr, 1, 2)
MyXL.Application.Cells(I, 2).Value = Mid(MyStr, 3, 2)
MyXL.Application.Cells(I, 3).Value = Mid(MyStr, 5, 2)
MyXL.Application.Cells(I, 4).Value = Mid(MyStr, 7, 2)
For J = 9 To 15
If Mid(MyStr, J, 1) = "-" Then
LStr = Left(MyStr, J)
CC = Right(MyStr, 15 - Len(LStr))
MyXL.Application.Cells(I, 5).Value = CC
End If
Next J
Next '==== End Entity Loop

X = I 'Place Holder (Last Record Number)
MyName = MyXL.Application.Cells(X, 7).Value

For J = 1 To X
If MyName = MyXL.Application.Cells(J, 7).Value Then
MyXL.Application.Worksheets("Acad").Rows(X).Cut
MyXL.Application.Worksheets("Acad").Rows(J).Select
MyXL.Application.Worksheets("Acad").Paste
End If
Next J

MyXL.Application.Range("A1").Select

Set MyXL = Nothing

End Sub

Sub DetectExcel()
' Procedure checks for a running Excel and registers it!
Const WM_USER = 1024
Dim hWnd As Long
'If Excel is Running this API call returns its Handle.

hWnd = FindWindow("XLMAIN", 0)
If hWnd = 0 Then
Exit Sub
Else
SendMessage hWnd, WM_USER + 18, 0, 0
End If

'Set NewSheet = Sheets.Add(Type:=xlWorksheet)
'For I = 1 To Sheets.Count
' NewSheet.Cells(I, 1).Value = Sheets(I).Name
'Next I

End Sub


--------------------



Maybe i am doing somthing wrong?

Here is what i tried with your code:

1. Open my test file in Autocad
2. Alt-F11 to open VB Editor
3. Tools --> References --> Add M$ Excel 11.0 Object lib
4. Insert --> Module, and paste in your code.

Code:
--------------------

Private Sub ACAD2Excel()
Dim oExcel As Excel.Application, oWrkBk As Excel.Workbook, oWrkSh As
Excel.Worksheet
Dim sTextOut As String, sTextIn As String

Set oExcel = New Excel.Application
Set oWrkBk = oExcel.Workbooks.Open(<"DRIVE:\PATH\WORKBOOK.XLS">)
Set oWrkSh = oWrkBk.Worksheets(<"WORKSHEET NAME">)
sTextOut = <"Some title block text">

' Send Acad text to Excel cell
oWrkSh.[A1] = sTextOut ' set Excel cell value = text

oWrkSh.Calculate ' Optionally recalc worksheet

' Send Excel cell to Acad text
sTextIn = oWrkSh.[A1] ' set text = Excel cell value
End Sub

 

My newsreader introduced a line break into the first line of my sample. The
last DIM (oWrkSh As Excel.Worksheet) was split onto two lines. This would
cause a compile error. Try removing the line break.
--
John Goodfellow
irtfnm
use john at goodfellowassoc dot com

lpClassName As String, ByVal lpWindowName As Long) As Long

hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As
Long) As Long

 

Hello John, I have tried removing the line break so your code looks
like:

Code:
--------------------

Private Sub ACAD2Excel()
Dim oExcel As Excel.Application, oWrkBk As Excel.Workbook, oWrkSh As Excel.Worksheet
Dim sTextOut As String, sTextIn As String

Set oExcel = New Excel.Application
Set oWrkBk = oExcel.Workbooks.Open(<"DRIVE:\PATH\WORKBOOK.XLS">)
Set oWrkSh = oWrkBk.Worksheets(<"WORKSHEET NAME">)
sTextOut = <"Some title block text">

' Send Acad text to Excel cell
oWrkSh.[A1] = sTextOut ' set Excel cell value = text

oWrkSh.Calculate ' Optionally recalc worksheet

' Send Excel cell to Acad text
sTextIn = oWrkSh.[A1] ' set text = Excel cell value
End Sub

 

Before we fix this code, why don't you just use the Block Attribute
Manager? It already does what you are trying to do. If there are other
things you are looking to do, don't use this code use ExcelLink - it is
in your AutoCAD Sample\VBA directory -- assuming you installed the
samples. Now just to explain why the posted code probably doesn't work
for you...

Ok, let's start by remove any possible problems with line breaks [see
below]. Second, in the lines where there is (<"...whatever...">), you
*are* changing that to something valid, right???? Such as changing:

Set oWrkBk = oExcel.Workbooks.Open(<"DRIVE:\PATH\WORKBOOK.XLS">)
Set oWrkSh = oWrkBk.Worksheets(<"WORKSHEET NAME">)

to:

Set oWrkBk = oExcel.Workbooks.Open("C:\My Documents\Test.xls")
Set oWrkSh = oWrkBk.Worksheets("Sheet1")

For whatever reason, probably to 'highlight' it for you, John included
"<" & ">" which are invalid where they are located. Using Option
Explicit will cause these lines to turn red to warn you of this within
the vba editor.

Third, the code has to have a valid file to use that already exists. SO
in the example above, you must place the exact name and location of an
existing file.

Fourth, the program never closes the file. If you try to open it, it'll
warn you. Hopefully, you wouldn't shutdown your computer or all the data
you wrote out would be lost!


CODE:
=====================================================
Option Explicit

Private Sub ACAD2Excel()
Dim oExcel As Excel.Application
Dim oWrkBk As Excel.Workbook
Dim oWrkSh As Excel.Worksheet
Dim sTextOut As String, sTextIn As String

Set oExcel = New Excel.Application
Set oWrkBk = oExcel.Workbooks.Open(<"DRIVE:\PATH\WORKBOOK.XLS">)
Set oWrkSh = oWrkBk.Worksheets(<"WORKSHEET NAME">)
sTextOut = <"Some title block text">

' Send Acad text to Excel cell
oWrkSh.[A1] = sTextOut ' set Excel cell value = text

oWrkSh.Calculate ' Optionally recalc worksheet

' Send Excel cell to Acad text
sTextIn = oWrkSh.[A1] ' set text = Excel cell value

' Close the file and save changes
oWrkBk.Close True

'clear out variables
Set oWrkSh = Nothing
Set oWrkBk = Nothing
Set oExcel = Nothing

End Sub
___________________________
Mike Tuersley
CADalyst's AutoCAD Clinic
Rand IMAGINiT Technologies