在中点画圆+文字

兰州人

2. 'Creates a single line of text.
3. Function PipeNoText(cadApp As AcadApplication, pp, Str)
4.   Dim objText As AcadText, objCircle As AcadCircle
5.   Dim alignmentPoint(0 To 2) As Double
6.   For ii = 0 To 2
7.     alignmentPoint(ii) = pp(ii) '+ 0.001
8.   Next ii
9.   With cadApp.ActiveDocument.ModelSpace
10.     Set objText = .AddText(Str, pp, 4)
11.     With objText
12.      ' .Layer = "件号"
13.       .Alignment = acAlignmentMiddleCenter
14.       .TextAlignmentPoint = alignmentPoint 'alignmentPoint
15.     End With
16.     Set objCircle = .AddCircle(pp, 4)
17.     With objCircle
18.       '.Layer = "件号"
19.     End With
20.   End With
21. End Function
23. Sub ll()
24.   Dim cadApp As AcadApplication, objLine As AcadLine
25.   Dim Pt
26.   With ThisDrawing
27.     Set cadApp = ThisDrawing.Application
28.     Set objLine = .HandleToObject("89B")
29.     Pt = midPtOneLine(cadApp, objLine)
30.     temp = PipeNoText(cadApp, Pt, "ee")
31.   End With
32.   
33. End Sub
34. Function midPtOneLine(cadApp As AcadApplication, objLine As AcadLine) As Variant
35.    Dim Pt(2) As Double
36.    With objLine
37.      Pt(0) = .StartPoint(0) + (.EndPoint(0) - .StartPoint(0)) / 2
38.      Pt(1) = .StartPoint(1) + (.EndPoint(1) - .StartPoint(1)) / 2
39.    End With
40.    midPtOneLine = Pt
41.    Exit Function
42.    For ii = 0 To 2
43.      'midPtOneLine(ii) = Pt(ii)
44.    Next ii
45. End Function

'Creates a single line of text. Function PipeNoText(cadApp As AcadApplication, pp, Str)   Dim objText As AcadText, objCircle As AcadCircle   Dim alignmentPoint(0 To 2) As Double   For ii = 0 To 2     alignmentPoint(ii) = pp(ii) '+ 0.001   Next ii   With cadApp.ActiveDocument.ModelSpace     Set objText = .AddText(Str, pp, 4)     With objText      ' .Layer = "件号"       .Alignment = acAlignmentMiddleCenter       .TextAlignmentPoint = alignmentPoint 'alignmentPoint     End With     Set objCircle = .AddCircle(pp, 4)     With objCircle       '.Layer = "件号"     End With   End With End Function Sub ll()   Dim cadApp As AcadApplication, objLine As AcadLine   Dim Pt   With ThisDrawing     Set cadApp = ThisDrawing.Application     Set objLine = .HandleToObject("89B")     Pt = midPtOneLine(cadApp, objLine)     temp = PipeNoText(cadApp, Pt, "ee")   End With    End Sub Function midPtOneLine(cadApp As AcadApplication, objLine As AcadLine) As Variant    Dim Pt(2) As Double    With objLine      Pt(0) = .StartPoint(0) + (.EndPoint(0) - .StartPoint(0)) / 2      Pt(1) = .StartPoint(1) + (.EndPoint(1) - .StartPoint(1)) / 2    End With    midPtOneLine = Pt    Exit Function    For ii = 0 To 2      'midPtOneLine(ii) = Pt(ii)    Next ii End Function

yp9819

这个函数很好，怎么用这个函数呢？版主写一个调用这个函数的小程序吧 好吗 谢谢

QWQWQWQ

yp9819 发表于 2020-5-16 19:22
这个函数很好，怎么用这个函数呢？版主写一个调用这个函数的小程序吧 好吗 谢谢

temp问题在这里