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
CAD VBA提取转角标注坐标的demo
最新推荐文章于 2024-08-25 11:39:58 发布