[МишаИнженер]

Помогите пожалуйста получить точку привязки начала размера AutoCAD на VBA!
Посмотрел сам и понимаю что на VBA AutoCAD нельзя написать такой простой программы как замена нескольких размеров одним общим с повторением величин заменённых более мелких размеров.
Как было бы удобно пользоваться такой программой в AutoCAD! Подскажите пожалуйста как сделать такую программу на VBA!
Как получить точки привязки размеров на VBA?

[Boxa]

Эх... за два года так ничего и не написал, польстился на готовое. Грустно. =(

[МишаИнженер]

Сообщение от maratovich Решилось просто - первая и вторая точка по порядку и есть привязки размера. Ну вот и решение на VBA Автор сам разберешься что делать или как ?

Уважаемый Маратович! Подскажите пожалуйста, в каком списке, библиотеке или словаре вы нашли 12 точек из которых 1 и 2 точка это точки привязки размеров? Как получить доступ к этому списку точек на VBA?

Сообщение от Boxa Эх... за два года так ничего и не написал, польстился на готовое. Грустно. =(

Пока мне удалось сделать вот такую функцию:

Код:

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

Public Sub ПолучитьТочкиПривязкиРазмера(objAcadDoc As AcadDocument, objРазмер As AcadObject, _
Optional startPnt As Variant, Optional endPnt As Variant, Optional location As Variant, Optional PText As Variant)
'Функция получает точки привязки размера
Dim sТекст As String
   'В командную строку передается LISP-выражение, возвращающее первую точку в WCS (код DXF - 13)
    objAcadDoc.SendCommand ("(cdr (assoc 13 (entget (handent " & """" & objРазмер.Handle & """" & "))))" & vbCr)
'    Debug.Print ("(cdr (assoc 13 (entget (handent " & """" & objРазмер.Handle & """" & "))))" & vbCr)
    sТекст = Mid(CStr(objAcadDoc.GetVariable("lastprompt")), 2, Len(CStr(objAcadDoc.GetVariable("lastprompt"))) - 2)
    startPnt = SplitDbl(sТекст, " ")
   
    'В командную строку передается LISP-выражение, возвращающее вторую точку в WCS (код DXF - 14)
    objAcadDoc.SendCommand ("(cdr (assoc 14 (entget (handent " & """" & objРазмер.Handle & """" & "))))" & vbCr)
    sТекст = Mid(CStr(objAcadDoc.GetVariable("lastprompt")), 2, Len(CStr(objAcadDoc.GetVariable("lastprompt"))) - 2)
    'В переменную endPnt записывается массив с координатами второй точки
    endPnt = SplitDbl(sТекст, " ")
   
   'В командную строку передается LISP-выражение, возвращающее точку размерной линии в WCS (код DXF - 10)
    objAcadDoc.SendCommand ("(cdr (assoc 10 (entget (handent " & """" & objРазмер.Handle & """" & "))))" & vbCr)
    sТекст = Mid(CStr(objAcadDoc.GetVariable("lastprompt")), 2, Len(CStr(objAcadDoc.GetVariable("lastprompt"))) - 2)
    'В переменную endPnt записывается массив с координатами второй точки
    location = SplitDbl(sТекст, " ")
   
   'В командную строку передается LISP-выражение, возвращающее точку текста в WCS (код DXF - 11)
    objAcadDoc.SendCommand ("(cdr (assoc 11 (entget (handent " & """" & objРазмер.Handle & """" & "))))" & vbCr)
    sТекст = Mid(CStr(objAcadDoc.GetVariable("lastprompt")), 2, Len(CStr(objAcadDoc.GetVariable("lastprompt"))) - 2)
    PText = SplitDbl(sТекст, " ")
End Sub

Как можно отключить вывод промежуточных сообщений в командную строку при работе этой функции?

[Boxa]

Блин, тема от сентября 2013 года, 9 лет прошло, на предыдущей странице полностью расписано как получить точки размера на VBA, но автор стремится сделать какую то дичь...
Вот код, без проверок, надеюсь его адаптация займет у Вас гораздо меньше времени:

Код:

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

Sub sefgksef()

    Dim returnObj As AcadObject
    Dim basePnt As Variant
    
    On Error Resume Next
    
RETRY:
    ThisDrawing.Utility.GetEntity returnObj, basePnt, "Select an object"
    
    If Err <> 0 Then
        Err.Clear
        MsgBox "Program ended.", , "GetEntity Example"
        Exit Sub
    Else
        Dim btrH As String
        btrH = Format(Hex(CLng("&H" & returnObj.Handle) + 5), "000")

        Dim tempObj As AcadObject
        Set tempObj = ThisDrawing.HandleToObject(btrH)
        
        Dim points() As AcadPoint
        Dim idx As Integer
       
        For Each obj In tempObj
            If obj.EntityName = "AcDbPoint" Then
                ReDim Preserve points(idx)
                Set points(idx) = obj
                idx = idx + 1
            End If
        Next
    
        Dim sPoint As String ' начальная точка
        sPoint = points(0).Coordinates(0) & " " & points(0).Coordinates(1)
        
        Dim ePoint As String 'конечная точка
        ePoint = points(1).Coordinates(0) & " " & points(1).Coordinates(1)
        
        Dim mPoint As String ' точка линии выноски
        mPoint = points(2).Coordinates(0) & " " & points(2).Coordinates(1)
        
        ThisDrawing.Utility.Prompt "Dim start point: " & sPoint & vbCrLf
        ThisDrawing.Utility.Prompt "Dim end point: " & ePoint & vbCrLf
    End If
    
    GoTo RETRY
End Sub

Сообщение от МишаИнженер Как можно отключить вывод промежуточных сообщений в командную строку при работе этой функции?

есть системная переменная "CMDECHO"