CAD VBA提取转角标注坐标的demo

Option Explicit

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

Public Function vbAssoc(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

Set VLisp = ThisDrawing.Application.GetInterfaceObject("VL.Application.16")
Set VLispFunc = VLisp.ActiveDocument.Functions

If Not TypeOf pAcadObj Is AcadBlock Then
    strHnd = pAcadObj.Handle
Else
    Dim lispStr As String
    lispStr = "(cdr (assoc 5 (entget (tblobjname " & Chr(34) & "Block" & Chr(34) & Chr(34) & pAcadObj.Name & Chr(34) & "))))"
    Set obj1 = VLispFunc.Item("read").Funcall(lispStr)
    strHnd = VLispFunc.Item("eval").Funcall(obj1)
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 (mapcar '(lambda (x) (if (= (type x) 'REAL) (rtos x 2 10) x)) (cdr (assoc pDXF (entget (handent pHandle)))))))")
varRetVal = VLispFunc.Item("eval").Funcall(obj1)
vbAssoc = varRetVal

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)

Set obj2 = Nothing
Set obj1 = Nothing
Set VLispFunc = Nothing
Set VLisp = Nothing
Exit Function

vbAssocError:
Set obj2 = Nothing
Set obj1 = Nothing
Set VLispFunc = Nothing
Set VLisp = Nothing
MsgBox "Error occurred " & Err.Description
End Function

Sub test()
    Dim dr As AcadDimRotated
    Dim sset As AcadSelectionSet
    Dim varTest As Variant, arrow2Pt As Variant
    Dim startPt As Variant, endPt As Variant
    
    Set sset = ThisDrawing.PickfirstSelectionSet
    sset.Clear
    sset.SelectOnScreen
        If sset.Count > 0 Then
        Set dr = sset.Item(0)
        varTest = vbAssoc(dr, 10)
        arrow2Pt = ParseDxfPoint(varTest)
        
        varTest = vbAssoc(dr, 13)
        startPt = ParseDxfPoint(varTest)
        
        varTest = vbAssoc(dr, 14)
        endPt = ParseDxfPoint(varTest)
        
        Dim msg As String
        msg = "点1：" & startPt(0) & "," & startPt(1) & "," & startPt(2)
        msg = msg & vbCrLf + "点2：" & endPt(0) & "," & endPt(1) & "," & endPt(2)
        msg = msg & vbCrLf + "文字：" & arrow2Pt(0) & "," & arrow2Pt(1) & "," & arrow2Pt(2)
        MsgBox msg
    End If
End Sub