• На форуме с 10 января 2007г.
  • Сообщений: 11
  • Спасибо: 0

Тема: Проставка блоков по координатам из Excel+значения ячеек в атрибуты

Люди добрые, помогите пожалуйсто решить проблемку.
Сразу предупрежу что я начинающий в макросах.
Появилась потребность в макросе для Автокада под Excel-ем, который создаёт определённый блок с четырьмя атрибутами в Акаде и потом проставляет его по координатам из excela которые находятся в столбцах D;E;F присваивая значения из столбцов B;C;H;J соответственно 1;2;3;4 атрибутам. Вот вроде что то удалось смастерить до момента проставки блока по координатам включительно. только не могу заставить значения из столбцов B;C;H;J вписывать в значения атрибутов.Можете подсказать как это сделать?
И вот ещё две мелочи на которых я “застрял”: При создании блока идёт запрос о масштабе блока и если несколько раз запустим макрос с разными значениями масштаба, то макрос будет вставлять актуальный блок+все предыдущие блоки(с предыдущими масштабами) как сделать чтобы роставлял блоки только с актуальным масштабом?
При создании блока был создан и использован стиль текста “OKU” с высотой текста 2 и коэф.ширины  0.7 только почемуто в блоке всавляет мне текс с коэф.шир. 1...Если после проставки блока, вручную изменить стиль атрибута на “standart” и обратно на “OKU” то текст появляется с правильным коэф.ширины  0.7...
Буду очень благодарен если кто нибудь поможет решить ети вопросы.
Option Explicit
Public Sub ExportBlocks()
Dim vertlist() As Double
Dim vertlist1() As Double
Dim vertlist3(0 To 2) As Double
Dim objApp As AcadApplication
Dim objDoc As AcadDocument
Dim RowCount As Integer
Dim RowCount1 As Integer
Dim strPrmpt As String
Dim intCnt As Integer
Dim intcnt1 As Integer
Dim objCell As Object
Dim objSheet As Worksheet
Dim wykres_1 As AcadLayer
Dim i As Integer
Dim blok1 As AcadBlock
Dim pktwst(0 To 2) As Double
Dim poli As AcadPolyline
Dim pkt(0 To 29) As Double
Dim nowalin As AcadLine
Dim blokref As AcadBlockReference
Dim blokref1 As AcadBlockReference
Dim zazn As AcadSelectionSet
Dim alayer As String
Dim textst As AcadTextStyle
Dim textObj As AcadText
Dim text1 As String
Dim text2 As String
Dim text3 As String
Dim insPoint1(0 To 2) As Double
Dim insPoint2(0 To 2) As Double
Dim insPoint3(0 To 2) As Double
Dim atr As AcadAttribute
Dim atr1 As AcadAttribute
Dim atr2 As AcadAttribute
Dim atr3 As AcadAttribute
Dim mode As Long
Dim prompt As String
Dim tag As String
Dim prompt1 As String
Dim tag1 As String
Dim prompt2 As String
Dim tag2 As String
Dim prompt3 As String
Dim tag3 As String
Dim height As Double
Dim ap(0 To 2) As Double
Dim ap1(0 To 2) As Double
Dim ap2(0 To 2) As Double
Dim ap3(0 To 2) As Double
Dim sk As Integer
On Error GoTo Err_Control
On Error GoTo Koniec
Set objSheet = ThisWorkbook.Sheets(1)
Set objApp = GetObject(, "AutoCAD.Application")
Set objDoc = objApp.ActiveDocument
sk = objDoc.Utility.GetInteger("Input scale for block")
pktwst(0) = 10 * sk * 0.001
pktwst(1) = 3 * sk * 0.001
pktwst(2) = 0
Set textst = objDoc.TextStyles.Add("OKU")
textst.height = 2 * sk * 0.001
textst.Width = 0.7
textst.fontFile = "simplex.shx"
objDoc.ActiveTextStyle = textst
text1 = "Nr="
text2 = "RG"
text3 = "L="
insPoint1(0) = 0.25 * sk * 0.001
insPoint1(1) = 3.55 * sk * 0.001
insPoint1(2) = 0
insPoint2(0) = 0.25 * sk * 0.001
insPoint2(1) = 0.45 * sk * 0.001
insPoint2(2) = 0
insPoint3(0) = 10.3 * sk * 0.001
insPoint3(1) = 0.45 * sk * 0.001
insPoint3(2) = 0
pkt(0) = 0
pkt(1) = 0
pkt(2) = 0
pkt(3) = 20 * sk * 0.001
pkt(4) = 0
pkt(5) = 0
pkt(6) = 20 * sk * 0.001
pkt(7) = 6 * sk * 0.001
pkt(8) = 0
pkt(9) = 0
pkt(10) = 6 * sk * 0.001
pkt(11) = 0
pkt(12) = 0
pkt(13) = 0
pkt(14) = 0
pkt(15) = 0
pkt(16) = 3 * sk * 0.001
pkt(17) = 0
pkt(18) = 20 * sk * 0.001
pkt(19) = 3 * sk * 0.001
pkt(20) = 0
pkt(21) = 20 * sk * 0.001
pkt(22) = 6 * sk * 0.001
pkt(23) = 0
pkt(24) = 10 * sk * 0.001
pkt(25) = 6 * sk * 0.001
pkt(26) = 0
pkt(27) = 10 * sk * 0.001
pkt(28) = 0
pkt(29) = 0
height = 2 * sk * 0.001
mode = acAttributeModeNormal
ap(0) = -5.65 * sk * 0.001
ap(1) = 0.55 * sk * 0.001
ap(2) = 0
ap1(0) = 0.3 * sk * 0.001
ap1(1) = 0.55 * sk * 0.001
ap1(2) = 0 * 0.001
ap2(0) = -7.05 * sk * 0.001
ap2(1) = -2.55 * sk * 0.001
ap2(2) = 0
ap3(0) = 2.73 * sk * 0.001
ap3(1) = -2.55 * sk * 0.001
ap3(2) = 0
tag = "Nr pala": prompt = "Nr pala"
tag1 = "Przekr. pala": prompt1 = " "
tag2 = "Rzędna gł.": prompt2 = " "
tag3 = "Dł.pala": prompt3 = " "
Set blok1 = objDoc.Blocks.Add(pktwst, "tabelka1")
Set poli = blok1.AddPolyline(pkt)
Set textObj = blok1.AddText(text1, insPoint1, 2 * sk * 0.001)
Set textObj = blok1.AddText(text2, insPoint2, 2 * sk * 0.001)
Set textObj = blok1.AddText(text3, insPoint3, 2 * sk * 0.001)
Set atr = blok1.AddAttribute(height, mode, prompt, ap, tag, "123")
Set atr1 = blok1.AddAttribute(height, mode, prompt1, ap1, tag1, "pal30x30")
Set atr2 = blok1.AddAttribute(height, mode, prompt2, ap2, tag2, "999,99")
Set atr3 = blok1.AddAttribute(height, mode, prompt3, ap3, tag3, "99,9")
Set blokref = objDoc.ModelSpace.InsertBlock(pktwst, "tabelka1", 1#, 1#, 1#, 0)
blokref.Update
  RowCount = objSheet.UsedRange.Rows.Count
  ReDim vertlist((RowCount * 2) - 1)
  RowCount = 1
  alayer = ("0")
  objDoc.ActiveLayer = objDoc.Layers.Item(alayer)
  For intCnt = LBound(vertlist) To UBound(vertlist) Step 2
    vertlist(intCnt) = objSheet.Cells(RowCount, 2).Value
    vertlist(intCnt + 1) = objSheet.Cells(RowCount, 3).Value
    RowCount = RowCount + 1
Next
RowCount1 = objSheet.UsedRange.Rows.Count
ReDim vertlist1((RowCount1 * 2) - 1)
RowCount1 = 1
For intcnt1 = LBound(vertlist1) To UBound(vertlist1) Step 2
    vertlist1(intcnt1) = objSheet.Cells(RowCount1, 8).Value
    vertlist1(intcnt1 + 1) = objSheet.Cells(RowCount1, 10).Value
    RowCount1 = RowCount1 + 1
  Next
  For i = 1 To RowCount - 1
      vertlist3(0) = objSheet.Cells(i, 4).Value
      vertlist3(1) = objSheet.Cells(i, 5).Value
      vertlist3(2) = 0
      Set wykres_1 = objDoc.Layers.Add("OKU-tabelka-pale")
      wykres_1.Color = acYellow
      objDoc.ActiveLayer = wykres_1
      Set blokref1 = objDoc.ModelSpace.InsertBlock(vertlist3, "tabelka1", 1#, 1#, 1#, 0)
      blokref1.Update
    Next
   objDoc.Regen acActiveViewport
Koniec:
Set blokref = Nothing
Exit_Here:
  If Not objApp Is Nothing Then
    Set objApp = Nothing
    Set objDoc = Nothing
  End If
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub

  • Fatty
  • Восстановленный участник
  • На форуме с 30 мая 2006г.
  • Сообщений: 989
  • Спасибо: 2

Re: Проставка блоков по координатам из Excel+значения ячеек в атрибуты

> Алексей
У тебя там большая каша, сразу не въехать
много лишнего
Точки вставки атрибутов просчитаны неточно
Конечно для начала так и должно быть :)
Я тут кое-что добавил по атрибутам и тд,
но не конечный вариант, доделай сам

Option Explicit
Public Sub ExportBlocks()
'Dim vertlist() As Double
Dim vertlist1() As Double
Dim vertlist3(0 To 2) As Double
Dim objApp As AcadApplication
Dim objDoc As AcadDocument
Dim RowCount As Integer
Dim RowCount1 As Integer
Dim strPrmpt As String
Dim intCnt As Integer
Dim intcnt1 As Integer
Dim objCell As Object
Dim objSheet As Worksheet
Dim wykres_1 As AcadLayer
Dim i As Integer, a As Integer
Dim blok1 As AcadBlock
Dim pktwst(0 To 2) As Double
Dim poli As AcadPolyline
Dim pkt(0 To 29) As Double
Dim nowalin As AcadLine
Dim blokref As AcadBlockReference
Dim blokref1 As AcadBlockReference
Dim zazn As AcadSelectionSet
Dim alayer As String
Dim textst As AcadTextStyle
Dim textObj As AcadText
Dim text1 As String
Dim text2 As String
Dim text3 As String
Dim insPoint1(0 To 2) As Double
Dim insPoint2(0 To 2) As Double
Dim insPoint3(0 To 2) As Double
Dim atr As AcadAttribute
Dim atr1 As AcadAttribute
Dim atr2 As AcadAttribute
Dim atr3 As AcadAttribute
Dim mode As Long
Dim prompt As String
Dim tag As String
Dim prompt1 As String
Dim tag1 As String
Dim prompt2 As String
Dim tag2 As String
Dim prompt3 As String
Dim tag3 As String
Dim height As Double
Dim ap(0 To 2) As Double
Dim ap1(0 To 2) As Double
Dim ap2(0 To 2) As Double
Dim ap3(0 To 2) As Double
Dim sk As Integer
On Error GoTo Err_Control
On Error GoTo Koniec
Set objSheet = ThisWorkbook.Sheets(1)
Set objApp = GetObject(, "AutoCAD.Application")
Set objDoc = objApp.ActiveDocument
sk = objDoc.Utility.GetInteger("Input scale for block: ")
MsgBox (sk)
pktwst(0) = 10 * sk * 0.001
pktwst(1) = 3 * sk * 0.001
pktwst(2) = 0
Set textst = objDoc.TextStyles.Add("OKU")
textst.height = 2 * sk * 0.001
textst.Width = 0.7
textst.fontFile = "simplex.shx"
objDoc.ActiveTextStyle = textst
text1 = "Nr="
text2 = "RG"
text3 = "L="
insPoint1(0) = 0.25 * sk * 0.001
insPoint1(1) = 3.55 * sk * 0.001
insPoint1(2) = 0
insPoint2(0) = 0.25 * sk * 0.001
insPoint2(1) = 0.45 * sk * 0.001
insPoint2(2) = 0
insPoint3(0) = 10.3 * sk * 0.001
insPoint3(1) = 0.45 * sk * 0.001
insPoint3(2) = 0
pkt(0) = 0
pkt(1) = 0
pkt(2) = 0
pkt(3) = 20 * sk * 0.001
pkt(4) = 0
pkt(5) = 0
pkt(6) = 20 * sk * 0.001
pkt(7) = 6 * sk * 0.001
pkt(8) = 0
pkt(9) = 0
pkt(10) = 6 * sk * 0.001
pkt(11) = 0
pkt(12) = 0
pkt(13) = 0
pkt(14) = 0
pkt(15) = 0
pkt(16) = 3 * sk * 0.001
pkt(17) = 0
pkt(18) = 20 * sk * 0.001
pkt(19) = 3 * sk * 0.001
pkt(20) = 0
pkt(21) = 20 * sk * 0.001
pkt(22) = 6 * sk * 0.001
pkt(23) = 0
pkt(24) = 10 * sk * 0.001
pkt(25) = 6 * sk * 0.001
pkt(26) = 0
pkt(27) = 10 * sk * 0.001
pkt(28) = 0
pkt(29) = 0
height = 2 * sk * 0.001
mode = acAttributeModeNormal
ap(0) = -5.65 * sk * 0.001
ap(1) = 0.55 * sk * 0.001
ap(2) = 0
ap1(0) = 0.3 * sk * 0.001
ap1(1) = 0.55 * sk * 0.001
ap1(2) = 0 * 0.001
ap2(0) = -7.05 * sk * 0.001
ap2(1) = -2.55 * sk * 0.001
ap2(2) = 0
ap3(0) = 2.73 * sk * 0.001
ap3(1) = -2.55 * sk * 0.001
ap3(2) = 0
tag = "Nr pala": prompt = "Nr pala"
tag1 = "Przekr. pala": prompt1 = " "
tag2 = "Rzędna gł.": prompt2 = " "
tag3 = "Dł.pala": prompt3 = " "
Set blok1 = objDoc.Blocks.Add(pktwst, "tabelka1")
Set poli = blok1.AddPolyline(pkt)
Set textObj = blok1.AddText(text1, insPoint1, 2 * sk * 0.001)
Set textObj = blok1.AddText(text2, insPoint2, 2 * sk * 0.001)
Set textObj = blok1.AddText(text3, insPoint3, 2 * sk * 0.001)
Set atr = blok1.AddAttribute(height, mode, prompt, ap, tag, "123")
atr.ScaleFactor = 0.7
Set atr1 = blok1.AddAttribute(height, mode, prompt1, ap1, tag1, "pal30x30")
atr1.ScaleFactor = 0.7
Set atr2 = blok1.AddAttribute(height, mode, prompt2, ap2, tag2, "999,99")
atr2.ScaleFactor = 0.7
Set atr3 = blok1.AddAttribute(height, mode, prompt3, ap3, tag3, "99,9")
atr3.ScaleFactor = 0.7
Set blokref = objDoc.ModelSpace.InsertBlock(pktwst, "tabelka1", 1#, 1#, 1#, 0)
blokref.Update
alayer = "0"
objDoc.ActiveLayer = objDoc.Layers.Item(alayer)
'RowCount = objSheet.UsedRange.Rows.Count
'ReDim vertlist((RowCount * 2) - 1)
'RowCount = 1
'For intCnt = LBound(vertlist) To UBound(vertlist) Step 2
'vertlist(intCnt) = objSheet.Cells(RowCount, 2).Value
'vertlist(intCnt + 1) = objSheet.Cells(RowCount, 3).Value
'RowCount = RowCount + 1
'Next
RowCount1 = objSheet.UsedRange.Rows.Count
'ReDim vertlist1((RowCount1 * 2) - 1)
'RowCount1 = 1
'For intcnt1 = LBound(vertlist1) To UBound(vertlist1) Step 2
'vertlist1(intcnt1) = objSheet.Cells(RowCount1, 8).Value
'vertlist1(intcnt1 + 1) = objSheet.Cells(RowCount1, 10).Value
'RowCount1 = RowCount1 + 1
'Next
Dim attvar As Variant
Dim objAtt As AcadAttributeReference
For i = 1 To RowCount1 - 1
vertlist3(0) = objSheet.Cells(i, 4).Value
vertlist3(1) = objSheet.Cells(i, 5).Value
vertlist3(2) = objSheet.Cells(i, 6).Value
Set wykres_1 = objDoc.Layers.Add("OKU-tabelka-pale")
wykres_1.Color = acYellow
objDoc.ActiveLayer = wykres_1
Set blokref1 = objDoc.ModelSpace.InsertBlock(vertlist3, "tabelka1", sk, sk, sk, 0)
attvar = blokref1.GetAttributes
For a = 0 To UBound(attvar)
Set objAtt = attvar(a)
Select Case UCase(objAtt.TagString)
Case UCase("Nr pala")
objAtt.TextString = objSheet.Cells(i, 2).Value
Case UCase("Przekr. pala")
objAtt.TextString = objSheet.Cells(i, 3).Value
Case UCase("Rzędna gł.")
objAtt.TextString = objSheet.Cells(i, 8).Value
Case UCase("Nr pala")
objAtt.TextString = objSheet.Cells(i, 10).Value
End Select
Next a
blokref1.Update
Next
objDoc.Regen acActiveViewport
Koniec:
Set blokref = Nothing
Exit_Here:
If Not objApp Is Nothing Then
Set objApp = Nothing
Set objDoc = Nothing
End If
Exit Sub
Err_Control:
MsgBox Err.Description
Resume Exit_Here
End Sub

~'J'~

  • Dron
  • Восстановленный участник
  • На форуме с 17 марта 2007г.
  • Сообщений: 97
  • Спасибо: 0

Re: Проставка блоков по координатам из Excel+значения ячеек в атрибуты

Что касается стилей текста, то с ними глюк, при програмном создании. Я столкнулся с типом текста: жирный, курсив и так далее. Всегда показывает текст, с такими стилями, обычным. Причём если открыть менеджер стилей текста, то в превью(в правом нижнем углу), данный стиль показывается как положено, но пока мышкой не ткнёш в его тип на рисунке не изменится.
Что касается масштаба блоков, то проблем вроде нет.
Надеюсь справишся с адаптацией под свои цели.

Dim ACADApp As Object
Dim InsPoint(0 To 2) As Double
'Процедура запуска AutoCAD
'В параметрах определяем запуск в видимом режиме или скрытом
'Работать с активным файлом или нет
'Если не с активным то указываем файл рисунка или шаблона
Sub AutoCADAppOpen(AppVisible As Boolean, NotActiveFile As Boolean, _
                   ACADFileName As String)
   On Error Resume Next
   Set ACADApp = GetObject(, "AutoCAD.Application")
   If Err Then
      Err.Clear
      Set ACADApp = CreateObject("AutoCAD.Application")
      ACADApp.Visible = False
      Application.ScreenUpdating = True
      If Err Then GoTo On_Err
   End If
   On Error GoTo On_Err
   ACADApp.Visible = AppVisible
   AppActivate Application.Caption
   If NotActiveFile = True Then
      If Right(ACADFileName, 4) = ".dwt" Then ACADApp.Documents.Add ACADFileName _
      Else: ACADApp.Documents.Open ACADFileName
   End If
On_Err:
   If Err.Number <> 0 Then
      Set ACADApp = Nothing
      MsgBox "Ошибка # " & Str(Err.Number) & " возникла в " _
        & Err.Source & Chr(13) & Err.Description
   End If
End Sub
'Данная процедура проверяет наличие указанного слоя в активном файле
'Если не нашла то создаст его установит активным
'Иначе просто установит активным
Sub AddLayerToACAD(LayerName As String)
   With ACADApp.ActiveDocument
      For Each entry In .Layers
         If StrComp(entry.Name, LayerName, 1) = 0 Then
            .ActiveLayer = .Layers(LayerName)
            Exit Sub
         End If
      Next
      .Layers.Add LayerName
      .ActiveLayer = .Layers(LayerName)
   End With
End Sub
'Данная процедура проверяет наличие в рисунке блока "PICKET"
'Если не находит то создаёт
'Блок представляет из себя точку с четырьмя пикетами
Sub AddBlockToACAD()
Dim BlockObj As Object
   For Each entry In ACADApp.ActiveDocument.Blocks
      If entry.Name = "PICKET" Then Exit Sub
   Next
   InsPoint(0) = 0: InsPoint(1) = 0: InsPoint(2) = 0
   Set BlockObj = ACADApp.ActiveDocument.Blocks.Add(InsPoint, "PICKET")
   BlockObj.AddPoint InsPoint
   InsPoint(0) = 0.35: InsPoint(1) = 0.35: InsPoint(2) = 0
   BlockObj.AddAttribute 0.5, 4, "Номер пикета", InsPoint, "Number", ""
   InsPoint(0) = 0.35: InsPoint(1) = 0.9: InsPoint(2) = 0
   BlockObj.AddAttribute 0.5, 4, "X", InsPoint, "X", ""
   InsPoint(0) = 0.35: InsPoint(1) = 1.45: InsPoint(2) = 0
   BlockObj.AddAttribute 0.5, 4, "Y", InsPoint, "Y", ""
   InsPoint(0) = 0.35: InsPoint(1) = 2: InsPoint(2) = 0
   BlockObj.AddAttribute 0.5, 4, "Z", InsPoint, "Z", ""
End Sub
'Данная процедура вставляет созданный блок с именем "PICKET"
'и добавляет атрибуты
Sub InsertPicketToAcad(XPicket As Double, YPicket As Double, ZPicket As Double, _
       Attribut1 As String, Attribut2 As String, Attribut3 As String, Attribut4 As String)
Dim BlockObj As Object
Dim Attributes  As Variant
   InsPoint(0) = XPicket: InsPoint(1) = YPicket: InsPoint(2) = ZPicket
   Set BlockObj = ACADApp.ActiveDocument.ModelSpace.InsertBlock(InsPoint, "PICKET", 1, 1, 1, 0)
   Attributes = BlockObj.GetAttributes
   InsPoint(0) = InsPoint(0) + 0.35: InsPoint(1) = InsPoint(1) + 0.35
   Attributes(0).insertionPoint = InsPoint
   Attributes(0).textString = Attribut1
   InsPoint(1) = InsPoint(1) + 0.55
   Attributes(1).insertionPoint = InsPoint
   Attributes(1).textString = Attribut2
   InsPoint(1) = InsPoint(1) + 0.55
   Attributes(2).insertionPoint = InsPoint
   Attributes(2).textString = Attribut3
   InsPoint(1) = InsPoint(1) + 0.55
   Attributes(3).insertionPoint = InsPoint
   Attributes(3).textString = Attribut4
   Set BlockObj = Nothing
End Sub
'Запуск импорта таблицы
Sub StartImportTabl()
Dim XPicket As Double, YPicket As Double
Dim I As Long
   'Запускаем AutoCAD в видимом режиме и активным рабочим файлом
   AutoCADAppOpen True, False, ""
   AddLayerToACAD "PICKETS" ' Активируем или создаём рабочий слой
   AddBlockToACAD 'Создаём необходимый блок
   I = 1
   While Cells(I, 4).Value <> ""
      InsertPicketToAcad Cells(I, 4).Value, Cells(I, 5).Value, Cells(I, 6).Value, _
        Str(Cells(I, 2).Value), Str(Cells(I, 3).Value), _
        Str(Cells(I, 8).Value), Str(Cells(I, 10).Value)
      I = I + 1
   Wend
   ACADApp.ZoomExtents
   AppActivate ACADApp.Name
   Set ACADApp = Nothing
   If Err.Number <> 0 Then
      MsgBox True, "Ошибка # " & Str(Err.Number) & " возникла в " _
        & Err.Source & Chr(13) & Chr(10) & Err.Description
      Err.Clear
   End If
End Sub

  • На форуме с 10 января 2007г.
  • Сообщений: 11
  • Спасибо: 0

Re: Проставка блоков по координатам из Excel+значения ячеек в атрибуты

Спасибо огромное ВСЕМ!
Все вопросы решены, макрос работает так как и было задумано :о).
Если можно, вопрос к Fatty. Некоторое время назад Ты  мне помог с макросом который проставлял номера и вытягивал атрибуты блоков в Excel. Только вот номерация проставлялась после выделения всех желаемых блоков. Можно ли сделать так,чтоб номера проставлялись сразу после выделения каждого из блоков?Т.е щёлкаю на первый выбранный блок и после проставляется номер 1 ,щёлкаю на второй-проставляется номер 2 итд...
макрос:
Option Explicit
' by Fatty 2007
' Request reference to Microsoft Office 11.0 Object Library
Dim oSset As AcadSelectionSet
Sub WriteBlocks()
     Dim xlApp As Excel.Application
     Dim xlBook As Workbook
     Dim wbkobjs As Workbooks
     Dim xlSheet As Worksheet
     Dim shtobjs As Worksheets
     Dim xlPath As String
     xlPath = ThisDrawing.Path & "\MyBlocks2.xls"
     On Error Resume Next
     Err.Clear
     Set xlApp = GetObject(, "Excel.Application")
     If Err <> 0 Then
          Err.Clear
          Set xlApp = CreateObject("Excel.Application")
          If Err <> 0 Then
               MsgBox "Cannot start Excel", vbExclamation
               End
          End If
     End If
     On Error GoTo Err_Control
     xlApp.Visible = False
     Set xlBook = xlApp.Workbooks.Add
     Set xlSheet = xlBook.Worksheets(1)
     Dim fcode(1) As Integer
     Dim fData(1) As Variant
     Dim dxfcode, dxfdata
     Dim i As Long, j As Long, k As Long
     Dim setName As String
     Dim blkRef As AcadBlockReference
     Dim oEnt As AcadEntity
     Dim oText As AcadText
     Dim ins As Variant
     Dim upt As Variant
     Dim dblHgt As Double
     Dim attVar() As AcadAttributeReference
     Dim objAtt As AcadAttributeReference
     Dim NrPala As Integer
     Dim OKU_Nr As AcadLayer
     fcode(0) = 0
     fData(0) = "INSERT"
     fcode(1) = 66
     fData(1) = 1
     dxfcode = fcode
     dxfdata = fData
     setName = "$Blocks$"
     NrPala = ThisDrawing.Utility.GetInteger("Введи номер блока : ")
     For i = 0 To ThisDrawing.SelectionSets.Count - 1
          If ThisDrawing.SelectionSets.Item(i).Name = setName Then
               ThisDrawing.SelectionSets.Item(i).Delete
               Exit For
          End If
     Next i
     Set oSset = ThisDrawing.SelectionSets.Add(setName)
     oSset.SelectOnScreen dxfcode, dxfdata
     MsgBox oSset.Count
     j = 1
     k = NrPala
     Set OKU_Nr = ThisDrawing.Layers.Add("OKU_Nr")
     OKU_Nr.color = acGreen
     ThisDrawing.ActiveLayer = OKU_Nr
     dblHgt = ThisDrawing.GetVariable("DIMTXT") ' change text height you need
     For Each oEnt In oSset
          Set blkRef = oEnt
          ins = blkRef.InsertionPoint
          Set oText = ThisDrawing.ModelSpace.AddText(CStr(k), ins, dblHgt)
          oText.color = acYellow
          upt = ThisDrawing.Utility.TranslateCoordinates(ins, acWorld, acUCS, False)
          attVar = blkRef.GetAttributes
          xlSheet.Cells(j, 1) = "Nr pala"
          xlSheet.Cells(j, 2) = CStr(k)
          xlSheet.Cells(j, 3) = blkRef.Name
          xlSheet.Cells(j, 4) = CStr(upt(0))
          xlSheet.Cells(j, 5) = CStr(upt(1))
          xlSheet.Cells(j, 6) = CStr(upt(2))
          j = j + 0
          For i = 0 To UBound(attVar)
               Set objAtt = attVar(i)
               xlSheet.Cells(j - i, 7 + 2 * i) = objAtt.TagString
               xlSheet.Cells(j - i, 8 + 2 * i) = objAtt.TextString
               j = j + 1
          Next i
          j = j - UBound(attVar)
          k = k + 1
     Next oEnt
Exit_Here:
     xlSheet.UsedRange.Columns.AutoFit
     xlBook.SaveAs xlPath, , , , False
     xlBook.Close
     xlApp.Quit
     Exit Sub
Err_Control:
     If Err.Number <> 0 Then
          MsgBox Err.Number & " --> " & Err.Description
     Else
          MsgBox "Done"
     End If
     Set xlApp = Nothing
     Set xlBook = Nothing
     Set wbkobjs = Nothing
     Set xlSheet = Nothing
     Set shtobjs = Nothing
     Resume Exit_Here
End Sub

  • Fatty
  • Восстановленный участник
  • На форуме с 30 мая 2006г.
  • Сообщений: 989
  • Спасибо: 2

Re: Проставка блоков по координатам из Excel+значения ячеек в атрибуты

> Алексей
Я уже поудалял Эксель и чертеж где работал
Скинь оба-два на webfile.ru чтобы мне
не изобретать велосипед, а ссылку кинь сюда
Или поищи про нумерацию блоков по форумам
~'J'~

  • На форуме с 10 января 2007г.
  • Сообщений: 11
  • Спасибо: 0

Re: Проставка блоков по координатам из Excel+значения ячеек в атрибуты

Последний вклеенный мной макрос "WriteBlocks" это и есть тот к которому был ворос про номера блоков. В нём идёт нумерация после выделения всех желаемых блоков а нужно последовательно после выделения каждого по очереди...По форумам искал, сам пытаюсь поправить - покачто безрезультатно.

  • Fatty
  • Восстановленный участник
  • На форуме с 30 мая 2006г.
  • Сообщений: 989
  • Спасибо: 2

Re: Проставка блоков по координатам из Excel+значения ячеек в атрибуты

> Алексей
Я скинул небольшой пример в виде готового
проекта по нумерации блоков на сайт:
http://www.cadforyou.spb.ru/index.php?c … grams_page
Название:  BlockNum
Завтра должны загрузить
~'J'~