topic Re: vba & excel in VBA Forum

vba & excel

Anonymous — Wed, 18 Nov 2009 22:51:48 GMT

CAn anyone help?
I would like some vba code which can extract select attributes from a title sheet block in a drawing such as
Project name,
Drawing Title,
Drawing Number & Revision
and place them on seperate rows into an existing excel spreadsheet say 2 rows below the last row of existing data.

John b

Re: vba & excel

Anonymous — Thu, 19 Nov 2009 16:08:07 GMT

Check in Help->Developer Resources->Autocad Developer Help (search "excel").
There is more available from autodesk website
(http://usa.autodesk.com/adsk/servlet/item?siteID=123112&id=2767701) for
example.

Post back if you don't find what you need.

Re: vba & excel

Hallex — Thu, 19 Nov 2009 19:14:29 GMT

Post your sample drawing with this block only here
Perhaps I can help
Attached is an example that I have a found somewhere
(don't remember it)
This will get you started
Change the file name and sheet name at
the start of code

~'J'~ Edited by: hallex on Nov 19, 2009 9:19 PM

Re: vba & excel

Anonymous — Tue, 24 Nov 2009 06:11:56 GMT

Here is the drawing file with the block attached. the attributes i wish to extract are in the boxes
Actually i already have code which extracts attributes from a block called cable in the drawings. This extracts to excel and places the data six or seven rows (this can be changed) from the top of the worksheet ok but at this stage the excel sheet is still open with no name. i wish to be able to extract the attribute information at this time from the title block and place this in the first six or seven rows on seperate rows.
I would greatly appreciate any help

below is my existing code

Option Explicit

Sub Pmark()
Dim Excel As Object
Dim ExcelSheet As Object
Dim RowNum As Integer
Dim Array1 As Variant
Dim cnt As Integer
Dim NumberOfAttributes As Integer
Dim Ssnew As AcadSelectionSet
Dim Sheet As Object
Dim Max As Integer
Dim Min As Integer
Dim NoOfIndices As Integer
Dim blkRef As AcadBlockReference
Dim objAtt As AcadAttributeReference
Dim objEnt As AcadEntity
' Start Excel if not running
On Error Resume Next
Set Excel = GetObject(, "Excel.Application")
If Err <> 0 Then
Err.Clear
Set Excel = CreateObject("Excel.Application")
If Err <> 0 Then
MsgBox "Could Not Load Excel!", vbExclamation
End
End If
End If
On Error GoTo 0
Excel.Visible = True
Excel.Workbooks.Add '............................
Excel.workSheets(1).Select
'Excel.workSheets("Sheet1").Activate '.......................
'Set ExcelSheet = Excel.ActiveWorkbook.Sheets("Sheet1")
Set ExcelSheet = Excel.ActiveSheet
ExcelSheet.Name = "BOM" '<-- change sheet name by suit
''Clear the cells
ExcelSheet.Range("A1", "DZ100").Clear
ExcelSheet.Range("A1:N1").Font.Bold = True

'Get Selection Set of Specific Block with Attributes
RowNum = 7 'this governs the row the block data from "cable" is placed on
Dim Header As Boolean
Header = False
' The following sets up a selection set from the user for all objects
On Error Resume Next
' create set
Set Ssnew = ThisDrawing.SelectionSets.Add("BOM")
'if statement handles possible selection set error
If Err.Number <> 0 Then
Set Ssnew = ThisDrawing.SelectionSets.Item("BOM")
Ssnew.Clear
End If

Dim GC(0 To 1) As Integer
Dim GV(0 To 1) As Variant
Dim atribs
GC(0) = 0
GV(0) = "INSERT"
GC(1) = 2
'---------------------------------------------------
'Revise the block name "tendnum1" for your application
GV(1) = "cable"
'---------------------------------------------------
Ssnew.Select acSelectionSetAll, , , GC, GV
For Each objEnt In Ssnew
Set blkRef = objEnt
Array1 = blkRef.GetAttributes
For cnt = LBound(Array1) To UBound(Array1)
Set objAtt = Array1(cnt)
If Header = False Then
'If StrComp(Array1(cnt).EntityName, "AcDbAttribute", 1) = 0 Then '<--extrafluous, you already know this is attribute only
ExcelSheet.Cells(RowNum, cnt + 1).Value = objAtt.TagString
'End If
End If
Next cnt
RowNum = RowNum + 1
For cnt = LBound(Array1) To UBound(Array1)
Set objAtt = Array1(cnt)
ExcelSheet.Cells(RowNum, cnt + 1).Value = objAtt.TextString
Next cnt
Header = True
Next
'some formatting goes here:
With ExcelSheet.UsedRange
.Columns.AutoFit
Dim headRng As Excel.Range
Set headRng = .Range(Cells(1, 1), Cells(1, UBound(Array1) + 1))
With headRng
.Borders.LineStyle = xlContinuous
.Interior.ColorIndex = 35
.Font.ColorIndex = 5
End With
Dim dataRng As Excel.Range
Set dataRng = .Range(Cells(2, 1), Cells(.Rows.Count, UBound(Array1) + 1))
dataRng.Select
With Excel.Selection
.Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("A2") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
:=xlSortNormal
.Borders.LineStyle = xlContinuous
.Font.ColorIndex = 9
.Interior.ColorIndex = 34
End With
End With
Set dataRng = Nothing
Set headRng = Nothing
Set ExcelSheet = Nothing
Ssnew.Delete
End Sub

Re: vba & excel

Hallex — Tue, 24 Nov 2009 08:32:37 GMT

Oh, my
I'm so sorry - I'm very sick now
Will be back later say within 2-3 days only

~'J'~

Re: vba & excel

Hallex — Thu, 26 Nov 2009 13:04:03 GMT

Sorry but your block is buggy
It has three duplicate tags
I will be follow this rule: all similar tags
i declare with increment e.g. TITLE1, TITLE2 etc

This will get you started

Sub Test()
'send attribute data to excel
Dim i As Integer
Dim j As Integer
Dim intType(0 To 1) As Integer
Dim varData(0 To 1) As Variant

On Error Resume Next

If Not IsNull(oSset) Then

ThisDrawing.SelectionSets.Item("BOM").Delete
Else
End If
For i = 0 To UserForm1.ListBox1.ListCount
If UserForm1.ListBox1.Selected(i) = True Then

intType(0) = 0
varData(0) = "INSERT"
intType(1) = 2
varData(1) = UserForm1.ListBox1.List(i)
Set oSset = ThisDrawing.SelectionSets.Add("BOM")
oSset.Select acSelectionSetAll, FilterType:=intType, FilterData:=varData
End If

Next i

Dim varPick As Variant
Dim objEnt As AcadEntity
Dim varAttribs As Variant
Dim strAttribs As String
Dim blkCount As Integer
Dim jCounter As Integer
Dim iCounter As Integer

On Error Resume Next

For Each objEnt In oSset
Set oBref = objEnt
If oBref.HasAttributes Then
iCounter = 1
'get attributes
varAttribs = oBref.GetAttributes

ReDim blkData(0 To 7, 0 To 1) As String
blkData(0, 0) = "Block Name"
blkData(0, 1) = oBref.Name

For jCounter = LBound(varAttribs) + 1 To UBound(varAttribs) + 1
If varAttribs(jCounter - 1).TagString = "PROJECT" Or _
varAttribs(jCounter - 1).TagString = "ADDRESS" Or _
varAttribs(jCounter - 1).TagString = "SUBURB" Or _
varAttribs(jCounter - 1).TagString = "?" Or _
varAttribs(jCounter - 1).TagString = "TITLE" Then

blkData(jCounter, 0) = varAttribs(jCounter - 1).TagString 'oBRef.Name
blkData(jCounter, 1) = varAttribs(jCounter - 1).TextString
End If
Next jCounter
' iCounter = iCounter + 1
End If
Next objEnt

'export data to Excel
Dim xlApp As Object 'the Excel application
Dim xlSheet As Object 'the Excel sheet
Dim actBook As Object 'the Excel book
Dim xlBook As Object 'the Excel file

On Error GoTo Err_Control
On Error Resume Next 'prevent stopping if Excel is not open
Set xlApp = GetObject(, "Excel.application")
'activate Excel if open
If Err = 0 Then
Err.Clear
End If
On Error GoTo 0
'activate Excel if open
Set xlApp = CreateObject("Excel.application")
'Open Excel if not open
If Err <> 0 Then
MsgBox "Impossible to access Excel"
Exit Sub
End If
xlApp.Visible = True

Set xlBook = xlApp.Workbooks.Add()

Set actBook = xlApp.ActiveWorkbook
Set xlSheet = actBook.Sheets(1) 'activate the sheet
xlSheet.Name = "BOM"

For i = 0 To UBound(blkData, 1)
For j = 0 To 1
xlSheet.Cells(i + 1, j + 1).Value = blkData(i, j)
Next j
Next i

xlSheet.UsedRange.Select
xlSheet.Columns.AutoFit
actBook.SaveAs xlFileName
actBook.Close
Set actBook = Nothing
xlApp.Quit
Set xlApp = Nothing
Unload Me 'ends program closes form

Err_Control:
If Err.Number <> 0 Then
MsgBox Err.Description
End If

End Sub

~'J'~

Re: vba & excel

Anonymous — Fri, 27 Nov 2009 11:19:48 GMT

Thanks for that although i have a few questions.
In the code you mention a userform and userform listbox etc there are no clues as to what they should do.
I have changed the reference "Block Name" to the actual Block name
I have also highlighted a few other syntax errors which appear in the code
The code seems to be opening a new worksheet rather than use the worksheet which is already open can this be changed.

Sub Test()
'send attribute data to excel
Dim i As Integer
Dim j As Integer
Dim intType(0 To 1) As Integer
Dim varData(0 To 1) As Variant

On Error Resume Next

If Not IsNull(oSset) Then

ThisDrawing.SelectionSets.Item("BOM").Delete
Else
End If

For i = 0 To UserForm1.ListBox1.ListCount '??????????
If UserForm1.ListBox1.Selected(i) = True Then

intType(0) = 0
varData(0) = "INSERT"
intType(1) = 2
varData(1) = UserForm1.ListBox1.List(i) '???????????????????/

Set oSset = ThisDrawing.SelectionSets.Add("BOM")
oSset.Select acSelectionSetAll, FilterType:=intType, FilterData:=varData
End If

Next i

Dim varPick As Variant
Dim objEnt As AcadEntity
Dim varAttribs As Variant
Dim strAttribs As String
Dim blkCount As Integer
Dim jCounter As Integer
Dim iCounter As Integer

On Error Resume Next

For Each objEnt In oSset
Set oBref = objEnt
If oBref.HasAttributes Then
iCounter = 1
'get attributes
varAttribs = oBref.GetAttributes

ReDim blkData(0 To 7, 0 To 1) As String
blkData(0, 0) = "a1_title" ' blkData(0, 0) = "Block Name" changed "Block Name" to actual block name
blkData(0, 1) = oBref.Name

For jCounter = LBound(varAttribs) + 1 To UBound(varAttribs) + 1
If varAttribs(jCounter - 1).TagString = "PROJECT" Or _
varAttribs(jCounter - 1).TagString = "ADDRESS" Or _
varAttribs(jCounter - 1).TagString = "SUBURB" Or _
varAttribs(jCounter - 1).TagString = "?" Or _
varAttribs(jCounter - 1).TagString = "TITLE" Then

blkData(jCounter, 0) = varAttribs(jCounter - 1).TagString 'oBRef.Name
blkData(jCounter, 1) = varAttribs(jCounter - 1).TextString
End If
Next jCounter
' iCounter = iCounter + 1
End If
Next objEnt

'export data to Excel
Dim xlApp As Object 'the Excel application
Dim xlSheet As Object 'the Excel sheet
Dim actBook As Object 'the Excel book
Dim xlBook As Object 'the Excel file

On Error GoTo Err_Control
On Error Resume Next 'prevent stopping if Excel is not open
Set xlApp = GetObject(, "Excel.application")
'activate Excel if open
If Err = 0 Then
Err.Clear
End If
On Error GoTo 0
'activate Excel if open
Set xlApp = CreateObject("Excel.application")
'Open Excel if not open
If Err 0 Then '??????????????????????/ highlights in vis bas editor as syntax error
MsgBox "Impossible to access Excel"
Exit Sub
End If
xlApp.Visible = True

Set xlBook = xlApp.Workbooks.Add()

Set actBook = xlApp.ActiveWorkbook
Set xlSheet = actBook.Sheets(1) 'activate the sheet
xlSheet.Name = "BOM"

For i = 0 To UBound(blkData, 1)
For j = 0 To 1
xlSheet.Cells(i + 1, j + 1).Value = blkData(i, j)
Next j
Next i

xlSheet.UsedRange.Select
xlSheet.Columns.AutoFit
actBook.SaveAs xlFileName
actBook.Close
Set actBook = Nothing
xlApp.Quit
Set xlApp = Nothing
Unload Me 'ends program closes form

Err_Control:

If Err.Number 0 Then '??????????????????????/ highlights in vis bas editor as syntax error

MsgBox Err.Description
End If

End Sub

Re: vba & excel

Hallex — Fri, 27 Nov 2009 12:08:59 GMT

Hi
You can remove the code block with listbox selection
and set block name directly instead with InputBox

This expression
{code}If Err.Number < > 0 Then{/code}
must be:
If Err.Number {here is opened and closed corner brackets - not equal to}0 Then
It's a forum editor bug

~'J'~

Re: vba & excel

Anonymous — Mon, 30 Nov 2009 10:42:10 GMT

I am sorry to bug you but i just cannot seem to get this to work when i try to remove the userform listbox reference or otherwise. also when i do get it to open in excel it opens a whole new instance of excel. Is at all possible you could finish the project for me so that

1. When Macro is run it automatically looks for a block in the drawing called a1_title

2. It then extracts the attributes as noted in the attached code and places them on seperate rows in the current open spreadsheet.

This one seems to be beyond me. Hoping you can help
JohnB