• На форуме с 29 апреля 2010г.
  • Сообщений: 56
  • Спасибо: 2

Тема: Как получить доступ к точкам привязки размеров, средствами VBA (AcadDimRotated)

Добрый день, уважаемые коллеги. Аналогичная тема уже рассматривалась.
http://forum.dwg.ru/showthread.php?t=66011
Подскажите есть ли способ получать точки привязки и назначать точки привязки
размеров. Кроме солянки, ранее предложенной в голову ничего не приходит.

Sub selectRotatedDimension()
Dim returnObj As AcadEntity
Dim temp, startPnt, endPnt, varCancel As Variant
Dim control As Boolean
On Error GoTo Error_Control
control = False
'Программа выполняется до тех пор, пока не выбран нужный примитив или не нажата клавиша ESC
Do Until control = True
    ThisDrawing.Utility.GetEntity returnObj, startPnt, vbCrLf & "Command: Выберите объект типа AcDbRotatedDimension:"
    If returnObj.ObjectName = "AcDbRotatedDimension" Then
        'В командную строку передается LISP-выражение, возвращающее первую точку в WCS (код DXF - 13)
        ThisDrawing.SendCommand ("(cdr (assoc 13 (entget (handent " & """" & returnObj.Handle & """" & "))))" & vbCr)
        temp = Mid(CStr(ThisDrawing.GetVariable("lastprompt")), 2, Len(CStr(ThisDrawing.GetVariable("lastprompt"))) - 2)
        'В переменную startPnt записывается массив с координатами первой точки
        startPnt = Split(temp, " ", , vbTextCompare)
        If IsArray(startPnt) Then
            MsgBox "Первая точка: " & startPnt(0) & ";" & startPnt(1) & ";" & startPnt(2)
        End If
        'В командную строку передается LISP-выражение, возвращающее вторую точку в WCS (код DXF - 14)
        ThisDrawing.SendCommand ("(cdr (assoc 14 (entget (handent " & """" & returnObj.Handle & """" & "))))" & vbCr)
        temp = Mid(CStr(ThisDrawing.GetVariable("lastprompt")), 2, Len(CStr(ThisDrawing.GetVariable("lastprompt"))) - 2)
        'В переменную endPnt записывается массив с координатами второй точки
        endPnt = Split(temp, " ", , vbTextCompare)
        If IsArray(endPnt) Then
            MsgBox "Вторая точка: " & endPnt(0) & ";" & endPnt(1) & ";" & endPnt(2)
        End If
        control = True
    Else
        MsgBox "Выбранный объект не является объектом типа AcDbRotatedDimension."
    End If
Loop
GoTo Exit_Here
Error_Control:
Select Case Err.Number
    Case -2147352567
        varCancel = ThisDrawing.GetVariable("LASTPROMPT")
        If InStr(1, varCancel, "*Cancel*") <> 0 Then
            ThisDrawing.Utility.Prompt "Выполнение программы прервано."
            Err.Clear
            Resume Exit_Here
        Else
            Err.Clear
            Resume
        End If
    Case -2145320928
        Err.Clear
        Resume Exit_Here
    Case Else
        MsgBox Err.Description & " " & Err.Number
        Err.Clear
        Resume Exit_Here
End Select
Exit_Here:
Set returnObj = Nothing
Set temp = Nothing
Set startPnt = Nothing
Set endPnt = Nothing
Set varCancel = Nothing
End Sub

  • На форуме с 29 апреля 2010г.
  • Сообщений: 56
  • Спасибо: 2

Re: Как получить доступ к точкам привязки размеров, средствами VBA (AcadDimRotated)

Как Вам такое извращение?

Function ParseDxfPoint(DxfPoint)

    Dim Pt(2) As Double
    Dim Gap1, Gap2
    Gap1 = InStr(2, DxfPoint, " ", vbTextCompare)
    Pt(0) = Mid(DxfPoint, 2, Gap1 - 1)
    Gap2 = InStr(Gap1 + 1, DxfPoint, " ", vbTextCompare)
    Pt(1) = Mid(DxfPoint, Gap1 + 1, Gap2 - (Gap1 + 1))
    Pt(2) = Mid(DxfPoint, Gap2 + 1, Len(DxfPoint) - (Gap2 + 1))
    ParseDxfPoint = Pt
    
End Function

'SomeCallMeDave
'http://www.vbdesign.net/expresso/showthread.php?postid=83887#post83887
'Changed pAcadObj As AcadObject to pAcadObj As Object to access imagedef as well
'Modified by Jeff Mishler, March 2006, to get the Block table object, not Block_Record table object
Public Function vbAssoc2(pAcadObj, pDXFCode As Integer) As Variant

Dim VLisp As Object
Dim VLispFunc As Object
Dim varRetVal As Variant

Dim obj1 As Object
Dim obj2 As Object

Dim strHnd As String
Dim strVer As String

Dim lngCount As Long
Dim i As Long
Dim J As Long

On Error GoTo vbAssocError
    
If Left(ThisDrawing.Application.Version, 2) = "16" Then
  Set VLisp = ThisDrawing.Application.GetInterfaceObject("VL.Application.16")
Else
  Set VLisp = ThisDrawing.Application.GetInterfaceObject("VL.Application.1")
End If

Set VLispFunc = VLisp.ActiveDocument.Functions


strHnd = pAcadObj.Handle

If TypeOf pAcadObj Is AcadBlock Then
    strHnd = Hex(1 + Val("&H" & strHnd))
End If


Set obj1 = VLispFunc.Item("read").Funcall("pDXF")
  varRetVal = VLispFunc.Item("set").Funcall(obj1, pDXFCode)
Set obj1 = VLispFunc.Item("read").Funcall("pHandle")
  varRetVal = VLispFunc.Item("set").Funcall(obj1, strHnd)
Set obj1 = VLispFunc.Item("read").Funcall("(vl-princ-to-string (cdr (assoc pDXF (entget (handent pHandle)))))")
  varRetVal = VLispFunc.Item("eval").Funcall(obj1)

vbAssoc2 = varRetVal

'clean up the newly created LISP symbols
Set obj1 = VLispFunc.Item("read").Funcall("(setq pDXF nil)")
  varRetVal = VLispFunc.Item("eval").Funcall(obj1)
Set obj1 = VLispFunc.Item("read").Funcall("(setq pHandle nil)")
  varRetVal = VLispFunc.Item("eval").Funcall(obj1)

'release the objects or Autocad gets squirrely (no offense RR)
Set obj2 = Nothing
Set obj1 = Nothing
Set VLispFunc = Nothing
Set VLisp = Nothing

Exit Function