[gizmo_zx]

здраствуйте.
помогите разодраться...
есть прога на VBA экспортирует этрибуты блоков в файл Excel.
есть желание немного поправить... но интеллекта нехватает, подскажите кому не лень... плиз.

1) Программа выкидывает все атрибуты выделенных блоков в файл Excel,
но при повторном запуске "помнит" выделенные блоки в прошлый раз и добавляет их к выделенным в этот раз. (приходится каждый раз закрывать файл и снова открывать, чтоб прога "забыла" прошлое выделение..
2) Очень хочется вконце открыть другой файл Excel, и запустить макрос, дольнейшей обработки в нем (файле Excel).



*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*

Код:

[Выделить все]

Option Explicit

Public Sub WriteAttributes()

Dim oSset As AcadSelectionSet
Dim oEnt As AcadEntity
Dim oBlkRef As AcadBlockReference
Dim oAtt As AcadAttributeReference
Dim varAtt As Variant
Dim i As Long
Dim ftype(1) As Integer
Dim fdata(1) As Variant
ftype(0) = 0: fdata(0) = "INSERT"
ftype(1) = 66: fdata(1) = 1
Dim dxftype As Variant
Dim dxfdata As Variant
dxftype = ftype
dxfdata = fdata
'---------------------
Dim xlApp As Object
Dim xlBook As Workbook
Dim xlSheet As Worksheet
Dim lngRow As Long, lngCol As Long

'---------------------
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Err.Clear
Set xlApp = CreateObject("Excel.Application")
If Err <> 0 Then
MsgBox "Impossible to initialize an Excel.", vbExclamation
End
End If
End If
'---------------------

On Error Resume Next
Set oSset = ThisDrawing.SelectionSets.Item("$Attribs$")
If Err Then
Err.Clear
Set oSset = ThisDrawing.SelectionSets.Add("$Attribs$")
End If

On Error GoTo Err_Control

oSset.SelectOnScreen dxftype, dxfdata
'---------------------
xlApp.Visible = True
Set xlBook = xlApp.Workbooks.Add
xlBook.Sheets.Add.Name = 1
Set xlSheet = xlBook.Sheets(1)
lngRow = 1
xlSheet.Cells(lngRow, 1).Value = "Block Name"
'For i = 2 To 11
'xlSheet.Cells(lngRow, i).Value = "Attribue " & CStr(i - 1)
'Next
'xlSheet.Rows(1).Font.Bold = True
'xlSheet.Rows(1).Font.ColorIndex = 5
'---------------------
lngRow = 2
Dim name_at As String
Dim ix As Integer

For Each oEnt In oSset

Set oBlkRef = oEnt
If oBlkRef.IsDynamicBlock Then
xlSheet.Cells(lngRow, 1).Value = oBlkRef.EffectiveName
Else
xlSheet.Cells(lngRow, 2).Value = oBlkRef.Name
End If
varAtt = oBlkRef.GetAttributes
lngCol = 2
lngCol = 7
For i = 0 To UBound(varAtt)
Set oAtt = varAtt(i)

'lngCol = 7
name_at = oAtt.TagString
If name_at = "NUM" Then
    lngCol = 3
End If
If name_at = "NOMINAL" Then
    lngCol = 4
End If
If name_at = "USTAVKA" Then
    lngCol = 5
End If
If name_at = "FAZA" Then
    lngCol = 6
End If
'xlSheet.Cells(lngRow, lngCol).Value = oAtt.TagString

If oAtt.TextString <> "" Then
    xlSheet.Cells(lngRow, lngCol).Value = oAtt.TextString
    lngCol = lngCol + 1
End If
Next i

lngRow = lngRow + 1

Next oEnt

'--------------------
Dim oRange As Range
Set oRange = xlSheet.UsedRange
For i = 1 To oRange.Columns.Count
xlSheet.Cells(1, i).Value = "Attribue " & CStr(i - 1)
Next
'--------------------
xlSheet.Columns.HorizontalAlignment = xlHAlignLeft
xlSheet.Columns.AutoFit
xlBook.SaveAs ThisDrawing.Path & "\Attributes.xls"
'xlBook.Close
'--------------------
'xlApp.Application.Quit
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
'--------------------
'MsgBox "Done"
'--------------------

'[А здесь выполняешь свой макрос]

Err_Control:

End Sub

*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*

где нашел не помню, но где то здесь.

[Кулик Алексей aka kpblc]

Наверное, получится нечто типа такого:

Код:

[Выделить все]

Option Explicit

Private Function GetOrCreateObject(ObjectString As String) As Object
Dim obj As Object
  On Error Resume Next
  Set obj = GetObject(, ObjectString)
  If Err <> 0 Then
    Err.Clear
    Set obj = CreateObject(ObjectString) ' Исправил.
    If Err <> 0 Then
      Set obj = Nothing
    End If
  End If
  Set GetOrCreateObject = obj
End Function

Private Function GetBlockName(ByRef oAcadBlock As AcadBlockReference) As String
  On Error GoTo lErrIsDyn
  GetBlockName = oAcadBlock.EffectiveName
  Exit Function
lErrIsDyn:
  GetBlockName = oAcadBlock.Name
  Exit Function
End Function

Public Sub WriteAttributes()
Dim fData(1) As Variant, fType(1) As Integer
  fType(0) = 0: fData(0) = "INSERT": fType(1) = 66: fData(1) = 1
Dim oSelSet As AcadSelectionSet, SelSetName As String
  SelSetName = "$Attribs$"
  For Each oSelSet In ThisDrawing.SelectionSets
    If oSelSet.Name = SelSetName Then
      oSelSet.Delete
      Exit For
    End If
  Next oSelSet
  Set oSelSet = ThisDrawing.SelectionSets.Add(SelSetName)
  oSelSet.SelectOnScreen fType, fData
Dim xlApp As Object, xlBook As Object, xlWorksheet As Object, xlSheet As Object
  xlApp = GetOrCreateObject("Excel.Application")
  If Not (xlApp Is Nothing) Then
    xlApp.Visible = True
    Set xlBook = xlApp.workbooks.Add
    xlBook.Sheets.Add.Name = 1
    Set xlSheet = xlBook.Sheets(1)
    lngRow = 1
    xlSheet.Cells(lngRow, 1).Value = "Block Name"
Dim oAcadBlock As AcadBlockReference, arAttr As Variant
Dim lCol As Long, lRow As Long, lCounter As Long
    lRow = 2
    For Each oAcadBlock In oSelSet
      arAttr = oAcadBlock.GetAttributes
      lCol = 7
      For lCounter = LBound(arAttr) To UBound(arAttr)
        Select Case UCase(arAttr(lCounter).TagString)
          Case "NUM"
            lCol = 3
          Case "NOMINAL"
            lCol = 4
          Case "USTAVKA"
            lCol = 5
          Case "FAZA"
            lCol = 6
          Case Else
            lCol = lCol + 7
        End Select
        If Trim(arAttr(lCounter).TextString) <> "" Then
          xlSheet.Cells(lRow, lCol).Value = arAttr(lCounter).TextString
          lCol = lCol + 1
        End If
      Next lCounter
      lRow = lRow + 1
    Next oAcadBlock
  End If
'--------------------
Dim oRange As Range
Set oRange = xlSheet.UsedRange
For i = 1 To oRange.Columns.Count
xlSheet.Cells(1, i).Value = "Attribue " & CStr(i - 1)
Next
'--------------------
xlSheet.Columns.HorizontalAlignment = xlHAlignLeft
xlSheet.Columns.AutoFit
xlBook.SaveAs ThisDrawing.Path & "\Attributes.xls"
'xlBook.Close
'--------------------
'xlApp.Application.Quit
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
'--------------------
'MsgBox "Done"
'--------------------

'[А здесь выполняешь свой макрос]

Err_Control:

End Sub

[gizmo_zx]

не работает
!!! Argument not optional!!!

строка 8
Set obj = CreateObject(, ObjectString)

и еще по поводу 2)
открыть файл "c:\primer.xls"
в нем запустить макрос "модуль1"

[Кулик Алексей aka kpblc]

Код исправил. Как открыть файл - ну это обычно не проблема. А вот как запустить в нем макрос - тайна лично для меня.

[gizmo_zx]

с очисткой списка разобрался одной строкой спасибо за идею

oSset.Clear

[Кулик Алексей aka kpblc]

Clear'ом SelectionSet только очищается, но не уничтожается. ИМХО лучше как раз уничтожать его, не трогая объекты (.Delete вроде бы).

[Клякса]

1) попробуй
Set obj =Nothing
это обнуляет переменную, также, как переменные с апплкейшеном, книгой и листом.

2) Запуск макроса программно
objWbNewBook.Application.Run ("Macross.xls!Пример") ' Запуск макроса

Здесь:

objWbNewBook As Object ' Переменная для объекта Книга
Macross.xls - имя файла, в котором "живет" твой макрос
Пример - имя макроса или сабы или функции или модуля. Можно как русскими, так и латинскими буквами называть.

У тебя эта строчка будет выглядеть как-то так:
xlBook.Application.Run("primer.xls!модуль1" )

[Клякса]

Вся прелесть ВБА под экселем в том, что можно записать макрос по запуску другого макроса :-)

[Кулик Алексей aka kpblc]

Клякса, спасибо за инфу.

[Клякса]

Кажется, я погорячился. Имя модуля все-таки в ту строчку писать нельзя, только имя макроса, который содержится в каком-либо модуле (в одном модуле м.б. несколько макросов).

[gizmo_zx]

всем спасибо!
если прога кому нужна обращайтесь,
по однолинейной схеме делает спецификацию в excel? а если Autocad 2008 можно и назад вставить готовую табличку

[VanDerKeen]

да, дай сцилку на прогу