[分享]：用VB做的反应器

雪山飞狐(lzh)

注册压缩包里的Dll(AutoCad版本为2005)，并在VBA里引用
在ThisDrawing模块加入下列示例代码

2. 
   
3. Public TlsApp As New TlsApplication
   
4. Private WithEvents m_XhqReactor As TlsReactor
   
5. 
   
6. Public Sub TlsCadInit()
   
7.     TlsApp.Application = Application
   
8.     Set m_XhqReactor = TlsApp.Reactors("TlsXHQ")
   
9. End Sub
   
10. 
    
11. Private Sub m_XhqReactor_DoubleClick(ByVal pObject As IAcadObject, ByVal Value As Variant)
    
12. On Error GoTo ErrHandle
    
13.     Dim oBlock As AcadBlock
    
14.     Dim oText As AcadText
    
15.     Set oBlock = ThisDrawing.Blocks(pObject.Name)
    
16.     Set oText = oBlock(1)
    
17.     oText.TextString = InputBox("请输入序号", "TlsCad", oText.TextString)
    
18.     pObject.Update
    
19. ErrHandle:
    
20. End Sub
    
21. 
    
22. Private Sub m_XhqReactor_Erased(ByVal Value As Variant)
    
23.     MsgBox "Delete"
    
24. End Sub
    
25. 
    
26. Private Sub m_XhqReactor_Modified(ByVal pObject As IAcadObject, ByVal Value As Variant)
    
27. On Error GoTo ErrHandle
    
28. 
    
29.     Dim oLine As AcadLine
    
30.     Dim pStart, pEnd, pAngle, pDis
    
31.    
    
32.     Set oLine = ThisDrawing.HandleToObject(Value(0))
    
33. 
    
34.     pStart = oLine.StartPoint
    
35.     pEnd = pObject.InsertionPoint
    
36.     pEnd = ThisDrawing.Utility.PolarPoint(pEnd, Atn(1) * 6, 5 * pObject.XScaleFactor)
    
37.     pAngle = ThisDrawing.Utility.AngleFromXAxis(pStart, pEnd)
    
38.     pDis = ((pStart(0) - pEnd(0)) ^ 2 + (pStart(1) - pEnd(1)) ^ 2) ^ 0.5 - 5 * pObject.XScaleFactor
    
39.     oLine.EndPoint = ThisDrawing.Utility.PolarPoint(pStart, pAngle, pDis)
    
40. 
    
41. ErrHandle:
    
42. End Sub
    
43. 
    
44. 
    
45. Sub TlsXHQ()
    
46. On Error GoTo ErrHandle
    
47.     Dim oLine As AcadLine
    
48.     Dim oBlock As AcadBlock
    
49.     Dim oText As AcadText
    
50.    
    
51.     s = ThisDrawing.Utility.GetString(False, "输入序号:")
    
52.     p1 = ThisDrawing.Utility.getpoint(, "输入第一点:")
    
53.     p2 = ThisDrawing.Utility.getpoint(p1, "输入第二点:")
    
54.     Set oLine = ThisDrawing.ModelSpace.AddLine(p1, p2)
    
55.    
    
56.     p1 = TlsApp.Utility.CreatePoint
    
57.     Set oBlock = ThisDrawing.Blocks.Add(p1, "*U")
    
58.     p1 = ThisDrawing.Utility.PolarPoint(p1, Atn(1) * 6, 5)
    
59.     oBlock.AddCircle p1, 5
    
60.     Set oText = oBlock.AddText(s, p1, 5)
    
61.     oText.Alignment = acAlignmentMiddleCenter
    
62.     oText.TextAlignmentPoint = p1
    
63.    
    
64.     m_XhqReactor.Add ThisDrawing.ModelSpace.InsertBlock(ThisDrawing.Utility.PolarPoint(p2, Atn(1) * 2, 5), oBlock.Name, 1, 1, 1, 0), Array(oLine.Handle)
    
65. 
    
66. ErrHandle:
    
67. End Sub
    

<br /> Public TlsApp As New TlsApplication<br /> Private WithEvents m_XhqReactor As TlsReactor<br /> <br /> Public Sub TlsCadInit()<br />     TlsApp.Application = Application<br />     Set m_XhqReactor = TlsApp.Reactors("TlsXHQ")<br /> End Sub<br /> <br /> Private Sub m_XhqReactor_DoubleClick(ByVal pObject As IAcadObject, ByVal Value As Variant)<br /> On Error GoTo ErrHandle<br />     Dim oBlock As AcadBlock<br />     Dim oText As AcadText<br />     Set oBlock = ThisDrawing.Blocks(pObject.Name)<br />     Set oText = oBlock(1)<br />     oText.TextString = InputBox("请输入序号", "TlsCad", oText.TextString)<br />     pObject.Update<br /> ErrHandle:<br /> End Sub<br /> <br /> Private Sub m_XhqReactor_Erased(ByVal Value As Variant)<br />     MsgBox "Delete"<br /> End Sub<br /> <br /> Private Sub m_XhqReactor_Modified(ByVal pObject As IAcadObject, ByVal Value As Variant)<br /> On Error GoTo ErrHandle<br /> <br />     Dim oLine As AcadLine<br />     Dim pStart, pEnd, pAngle, pDis<br />     <br />     Set oLine = ThisDrawing.HandleToObject(Value(0))<br /> <br />     pStart = oLine.StartPoint<br />     pEnd = pObject.InsertionPoint<br />     pEnd = ThisDrawing.Utility.PolarPoint(pEnd, Atn(1) * 6, 5 * pObject.XScaleFactor)<br />     pAngle = ThisDrawing.Utility.AngleFromXAxis(pStart, pEnd)<br />     pDis = ((pStart(0) - pEnd(0)) ^ 2 + (pStart(1) - pEnd(1)) ^ 2) ^ 0.5 - 5 * pObject.XScaleFactor<br />     oLine.EndPoint = ThisDrawing.Utility.PolarPoint(pStart, pAngle, pDis)<br /> <br /> ErrHandle:<br /> End Sub<br /> <br /> <br /> Sub TlsXHQ()<br /> On Error GoTo ErrHandle<br />     Dim oLine As AcadLine<br />     Dim oBlock As AcadBlock<br />     Dim oText As AcadText<br />     <br />     s = ThisDrawing.Utility.GetString(False, "输入序号:")<br />     p1 = ThisDrawing.Utility.getpoint(, "输入第一点:")<br />     p2 = ThisDrawing.Utility.getpoint(p1, "输入第二点:")<br />     Set oLine = ThisDrawing.ModelSpace.AddLine(p1, p2)<br />     <br />     p1 = TlsApp.Utility.CreatePoint<br />     Set oBlock = ThisDrawing.Blocks.Add(p1, "*U")<br />     p1 = ThisDrawing.Utility.PolarPoint(p1, Atn(1) * 6, 5)<br />     oBlock.AddCircle p1, 5<br />     Set oText = oBlock.AddText(s, p1, 5)<br />     oText.Alignment = acAlignmentMiddleCenter<br />     oText.TextAlignmentPoint = p1<br />     <br />     m_XhqReactor.Add ThisDrawing.ModelSpace.InsertBlock(ThisDrawing.Utility.PolarPoint(p2, Atn(1) * 2, 5), oBlock.Name, 1, 1, 1, 0), Array(oLine.Handle)<br /> <br /> ErrHandle:<br /> End Sub<br />

Acad2005Doc.lsp文件加入：

1. 
   
2. (vla-RunMacro (vlax-get-acad-object) "tlscadinit")
   

复制代码

上面的示例是一个简单的序号球原型，TlsXHQ宏创建序号球实体
移动球体，直线会跟随，双击球体，可以改变序号球的值