• На форуме с 21 марта 2011г.
  • Сообщений: 13
  • Спасибо: 0

Тема: Получение нужной информации от блока и масштабирование

Снова прошу у вас помощи
Я создаю блок через функцию AcadBlock потом добавляю к нему объект допустим тот же круг и вставляю блок через функцию AcadBlockReference указывая нужные координаты. В дальнейшем можно ли получать информацию от блока его название и координаты. Хотелось бы это делать путем выбирания блока мышкой на чертеже(для перегона названия и координат Х,Y в excel). Подскажите можно ли это как нибудь осуществить.

И еще один вопрос по масштабированию. Допустим тот же созданный блок если мне нужно увеличить чертеж в два раза то увеличивается и блок а мне нужно что б увеличились только координаты Х,Y.

Заранее всем огромное спасибо буду очень признателен за помощь. Если можно объясните поподробней

Ответ от AnatolyN (изменено: Anatoly, 4 июля 2011г. 11:16:41)

  • AnatolyN
  • Активный участник
  • Откуда: Москва
  • На форуме с 14 мая 2009г.
  • Сообщений: 178
  • Спасибо: 4

Re: Получение нужной информации от блока и масштабирование

Если выбирается один объект, то

ThisDrawing.Utility.GetEntity returnObj, basePnt, "Select an object"
If returnObj.ObjectName = "AcDbBlockReference" Then 
inspnt = returnObj.InsertionPoint
blknam = returnObj.Name
End If

basePnt-это координата, указанная мышкой, она не нужна.

Насчет масштабирования

Sub Example_XScaleFactor()
    ' This example creates a block containing a circle.
    ' It then inserts the block and changes the XScaleFactor.
    
    ' Create the block
    Dim blockObj As AcadBlock
    Dim insertionPnt(0 To 2) As Double
    insertionPnt(0) = 0#: insertionPnt(1) = 0#: insertionPnt(2) = 0#
    Set blockObj = ThisDrawing.Blocks.Add(insertionPnt, "CircleBlock")
    
    ' Add a circle to the block
    Dim circleObj As AcadCircle
    Dim center(0 To 2) As Double
    Dim radius As Double
    center(0) = 0: center(1) = 0: center(2) = 0
    radius = 1
    Set circleObj = blockObj.AddCircle(center, radius)
   
    ' Insert the block
    Dim blockRefObj As AcadBlockReference
    insertionPnt(0) = 2#: insertionPnt(1) = 2#: insertionPnt(2) = 0
    Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(insertionPnt, "CircleBlock", 1#, 1#, 1#, 0)
    
    ' Find the current XScaleFactor for the block reference
    Dim currXScaleFactor As Double
    currXScaleFactor = blockRefObj.XScaleFactor
    ZoomAll
    MsgBox "The current XScaleFactor for the block reference is " & blockRefObj.XScaleFactor, , "XScaleFactor Example"
    
    ' Change the XScaleFactor for the block reference
    blockRefObj.XScaleFactor = currXScaleFactor + 2
    ZoomAll
    MsgBox "The new XScaleFactor for the block reference is " & blockRefObj.XScaleFactor, , "XScaleFactor Example"
    
End Sub

Для Y - YScaleFactor

  • На форуме с 21 марта 2011г.
  • Сообщений: 13
  • Спасибо: 0

Re: Получение нужной информации от блока и масштабирование

Большое спасибо Anatoly!!!

  • На форуме с 21 марта 2011г.
  • Сообщений: 13
  • Спасибо: 0

Re: Получение нужной информации от блока и масштабирование

Помогите пожалуйста связать AcadText с блоком чтоб он вставлялся и был гибким. Я попытался но у меня не выходит пришлось сделать разными объектами ну меня так не устраивает. Посоветуйте как можно решить эту проблему

Sub draw_svetoor_M()

Dim nomer As String
Dim a As String
a = InputBox("Номер маневрового светофора: ", "Исходные данные:")
nomer = "світлофор М" & a
Dim insert_point As Variant
Dim rotate As Double
insert_point = ThisDrawing.Utility.GetPoint(, "X,Y светофора: ")
rotate = ThisDrawing.Utility.GetAngle(insert_point, vbCr & "угол поворота: ")
Dim manevroviy As AcadBlock
Dim manevroviy_point(2) As Double

manevroviy_point(0) = 0#: manevroviy_point(1) = 0#: _
manevroviy_point(2) = 0#

Set manevroviy = ThisDrawing.Blocks.Add(manevroviy_point, nomer)

Dim korpus As AcadLWPolyline
Dim korpus_point(7) As Double

korpus_point(0) = 1.5: korpus_point(1) = -0.5
korpus_point(2) = 0: korpus_point(3) = -0.5
korpus_point(4) = 0: korpus_point(5) = 0.5
korpus_point(6) = 1.5: korpus_point(7) = 0.5

Set korpus = manevroviy.AddLightWeightPolyline(korpus_point)

Dim krishka As AcadArc
Dim krishka_center(2) As Double
Dim krishka_radius As Double
Dim krishka_start As Double
Dim krishka_end As Double

krishka_center(0) = 1.5: krishka_center(1) = 0#: _
krishka_center(2) = 0#
krishka_radius = 0.5
krishka_start = 4.71238898
krishka_end = 1.570796327

Set krishka = manevroviy.AddArc(krishka_center, krishka_radius, krishka_start, krishka_end)

Dim hatch_linz_1 As AcadHatch
Dim linz_1patternName As String
Dim linz_1PatternType As Long
Dim linz_13bAssociativity As Boolean
   
linz_1patternName = "SOLID"
linz_1PatternType = acHatchPatternTypePreDefined
linz_1bAssociativity = True
       
Set hatch_linz_1 = manevroviy.AddHatch(linz_1PatternType, linz_1patternName, linz_1bAssociativity)
hatch_linz_1.Color = acWhite

Dim linz_1(0 To 0) As AcadEntity
Dim linz1_center(0 To 2) As Double
Dim linz1_radius As Double
   
linz1_center(0) = 0.5: linz1_center(1) = 0#: _
linz1_center(2) = 0#
linz1_radius = 0.08
       
Set linz_1(0) = manevroviy.AddCircle(linz1_center, linz1_radius)

hatch_linz_1.AppendOuterLoop (linz_1)
hatch_linz_1.Evaluate
ThisDrawing.Regen True

Dim hatch_linz_2 As AcadHatch
Dim linz_2patternName As String
Dim linz_2PatternType As Long
Dim linz_23bAssociativity As Boolean
   
linz_2patternName = "SOLID"
linz_2PatternType = acHatchPatternTypePreDefined
linz_2bAssociativity = True
       
Set hatch_linz_2 = manevroviy.AddHatch(linz_2PatternType, linz_2patternName, linz_2bAssociativity)
hatch_linz_2.Color = acWhite

Dim linz_2(0 To 0) As AcadEntity
Dim linz2_center(0 To 2) As Double
Dim linz2_radius As Double
   
linz2_center(0) = 1.5: linz2_center(1) = 0#: _
linz2_center(2) = 0#
linz2_radius = 0.08
       
Set linz_2(0) = manevroviy.AddCircle(linz2_center, linz2_radius)

hatch_linz_2.AppendOuterLoop (linz_2)
hatch_linz_2.Evaluate
ThisDrawing.Regen True

Dim name As AcadText
Dim name_point(2) As Double
Dim tip As String
Dim height As Double
    Select Case rotate
    Case Is >= 4.71238898
        Select Case Val(a)
        Case Is < 10
            name_point(0) = insert_point(0) - 4.4: name_point(1) = insert_point(1) - 0.8: _
            name_point(2) = 0#:
            tip = "M" & a
            height = 1.6
        Case Is <= 100
            name_point(0) = insert_point(0) - 6: name_point(1) = insert_point(1) - 0.8: _
            name_point(2) = 0#:
            tip = "M" & a
            height = 1.6
        Case Is >= 100
            name_point(0) = insert_point(0) - 7.6: name_point(1) = insert_point(1) - 0.8: _
            name_point(2) = 0#:
            tip = "M" & a
            height = 1.6
        End Select
Set name = ThisDrawing.ModelSpace.AddText(tip, name_point, height)
name.ObliqueAngle = 0.436332313
name.rotate insert_point, rotate
   Case 1.570796327 To 4.71238898
        Select Case Val(a)
        Case Is < 10
            name_point(0) = insert_point(0) + 1.25: name_point(1) = insert_point(1) - 0.8: _
            name_point(2) = 0#:
            tip = "M" & a
            height = 1.6
        Case Is <= 100
            name_point(0) = insert_point(0) + 1.25: name_point(1) = insert_point(1) - 0.8: _
            name_point(2) = 0#:
            tip = "M" & a
            height = 1.6
        Case Is >= 100
            name_point(0) = insert_point(0) + 1.25: name_point(1) = insert_point(1) - 0.8: _
            name_point(2) = 0#:
            tip = "M" & a
            height = 1.6
        End Select
Set name = ThisDrawing.ModelSpace.AddText(tip, name_point, height)
name.ObliqueAngle = 0.436332313
name.rotate insert_point, rotate - 3.141592654
    Case 0 To 1.570796327
        Select Case Val(a)
        Case Is < 10
            name_point(0) = insert_point(0) - 4.4: name_point(1) = insert_point(1) - 0.8: _
            name_point(2) = 0#:
            tip = "M" & a
            height = 1.6
        Case Is <= 100
            name_point(0) = insert_point(0) - 6: name_point(1) = insert_point(1) - 0.8: _
            name_point(2) = 0#:
            tip = "M" & a
            height = 1.6
        Case Is >= 100
            name_point(0) = insert_point(0) - 7.6: name_point(1) = insert_point(1) - 0.8: _
            name_point(2) = 0#:
            tip = "M" & a
            height = 1.6
        End Select
Set name = ThisDrawing.ModelSpace.AddText(tip, name_point, height)
name.ObliqueAngle = 0.436332313
name.rotate insert_point, rotate
    End Select
Dim manevroviy_ref As AcadBlockReference
Set manevroviy_ref = ThisDrawing.ModelSpace.InsertBlock(insert_point, nomer, 1#, 1#, 1#, rotate)

End Sub

  • На форуме с 21 марта 2011г.
  • Сообщений: 13
  • Спасибо: 0

Re: Получение нужной информации от блока и масштабирование

А как можно сделать что бы автоматически перебирались все блоки с лева на право т.е по оси Х от 0 и до конца чертежа

  • fixo
  • fixo
  • Активный участник
  • Откуда: СПб
  • На форуме с 7 февраля 2009г.
  • Сообщений: 869
  • Спасибо: 41

Re: Получение нужной информации от блока и масштабирование

Дима Сибилев пишет:

А как можно сделать что бы автоматически перебирались все блоки с лева на право т.е по оси Х от 0 и до конца чертежа

нашел в загашнике сортировку по Y
переделай под свои условия
*Sort selection by Y*

Option Explicit

Public Function SelectionSortY(oSset As AcadSelectionSet) As AcadSelectionSet

     Dim oSsetNew As AcadSelectionSet
     Dim oEnt As AcadEntity
     Dim oBlkRef As AcadBlockReference
     Dim i As Integer
     Dim Responce As Boolean
     Dim j As Integer
     Dim k As Integer
     Dim dblItm As Double
     Dim nCount As Integer
     Dim tempID As Long
     Dim ObjID() As Long
     Dim yPnt() As Double

     On Error GoTo Say_Cinthia_About_Error     ' use any name for error trapp
     ' Loop through all selection set in drawing to
     ' make sure it does not exist with the same name ("$SortedBlkRefs$")
     ' because we will be get an error occurance
     For Each oSsetNew In ThisDrawing.SelectionSets
          If oSsetNew.Name = "$SortedBlkRefs$" Then     'if this catched then kill 'em
               oSsetNew.Delete
               Exit For
          End If
     Next
     ' make new selection set instead of deleted or
     ' simply make new one if does not exist
     Set oSsetNew = ThisDrawing.SelectionSets.Add("$SortedBlkRefs$")

     nCount = oSset.Count
     ReDim ObjID(0 To (nCount - 1)) As Long
     ReDim yPnt(0 To (nCount - 1)) As Double

     k = 0

     For Each oEnt In oSset

          Set oBlkRef = oEnt
          yPnt(k) = oBlkRef.InsertionPoint(1)
          ObjID(k) = oBlkRef.ObjectID

          k = k + 1

     Next oEnt

     i = 0

     Responce = True

     Do While i < (nCount - 1) And Responce = True
     
          Responce = False
          
          j = 0
          
          Do While j <= nCount - i
          
               If yPnt(j) > yPnt(j + 1) Then
               
                    dblItm = yPnt(j)
                    
                    tempID = ObjID(j)
                    
                    yPnt(j) = yPnt(j + 1)
                    
                    ObjID(j) = ObjID(j + 1)
                    
                    yPnt(j + 1) = dblItm
                                       
                    ObjID(j + 1) = tempID
                    
                    Responce = True
                    
               End If
               
               j = j + 1
               
          Loop
          
          i = i + 1
          
     Loop

     ReDim Sortedobjs(0 To nCount) As AcadEntity
     
     Dim i As Integer
     
     For i = 0 To nCount
     
          Set Sortedobjs(i) = ThisDrawing.ObjectIdToObject(ObjID(i))
          
     Next
     ' Add the array of objects to the selection set
     oSsetNew.AddItems Sortedobjs

     Set SelectionSortY = oSsetNew

Say_Cinthia_About_Error:

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

End Function