Yep! Missing an End If statement...


Public Sub ExtractAttributes()
' AutoCad VBA macro:
' Automates Excel to list any Block Attributes found in a Dwg file.
' Uses late binding so setting refernce to Excel is not required.

Dim appXL As Excel.Application, wksXL As Object, wkbXL As Object
Dim Header As Boolean, lRow&, n&, k&, j&, sTags$, sEnts$
Dim vTmp, vEntity As AcadEntity, vTags, vaDataOut()

Const sFilePath$ = "C:\Desktop\TempImport.xlsx"
Const sBlockRef$ = "AcDbBlockReference"

On Error GoTo ErrExit

'Start an automated instance of Excel
Set appXL = CreateObject("Excel.Application")
Set wkbXL = appXL.Workbooks.Open(sFilePath, ReadOnly:=False)
Set wksXL = wkbXL.Worksheets("DwgAttributes")
appXL.Visible = True 'False

lRow = 1: sTags = "HANDLE" '//initialize vars

'Find all block references
For Each vEntity In ThisDrawing.ModelSpace
With vEntity
If bBlockRefsFound(.EntityName, sBlockRef) Then
'Get a list of any Attributes
If .HasAttributes Then
sEnts = sEnts & "," & .EntityName '//list its name
vTmp = .GetAttributes
For n = LBound(vTmp) To UBound(vTmp)
If Not InStr(sTags, vTmp(n).TagString) 0 _
Then sTags = sTags & "," & vTmp(n).TagString
Next 'n
End If '.HasAttributes
End If 'bBlockRefsFound
End With 'vEntity
Next 'vEntity

'Set the attribute TagStrings as headers in row 1
vTags = Split(sTags, ",")
With wksXL
.Cells.Clear
.Cells(1, 1).Resize(1, UBound(vTags) + 1) = vTags
End With 'wksXL

'Dim the output array
k = UBound(Split(Mid(sEnts, 2), ","))
ReDim vaDataOut(k, UBound(vTags)): lRow = lRow + 1:

'Load the array with attribute values
For Each vEntity In ThisDrawing.ModelSpace
If InStr(sEnts, vEntity.EntityName) 0 Then
vTmp = vEntity.GetAttributes
For n = LBound(vaDataOut) To UBound(vaDataOut)
For k = LBound(vTmp) To UBound(vTmp)
For j = LBound(vTags) To UBound(vTags)
If j = 0 Then
vaDataOut(n, j) = Format(vEntity.Handle, "'@")
Else
If vTmp(k).TagString = vTags(j) Then
vaDataOut(n, j) = vTmp(k).TextString: Exit For
End If
End If 'j=0
Next 'j
Next 'k
Next 'n
End If
Next 'vEntity

With wksXL
.Cells(lRow, 1).Resize(UBound(vaDataOut) + 1, UBound(vaDataOut, 2)
+ 1) = vaDataOut
.Cells.EntireColumn.AutoFit
End With


ErrExit:

MsgBox Err.Number & " - " & Err.Description & " Error occurred in
Excel App Process"

' appXL.DisplayAlerts = False
If (Err = 0) Then
wkbXL.Save
Else
wkbXL.Close SaveChanges:=True '*** uncomment to keep open
End If '(Err = 0)
' appXL.DisplayAlerts = True
appXL.Quit

Set wksXL = Nothing: Set wkbXL = Nothing: Set appXL = Nothing
End Sub

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion