[讨论]用VB做永久反应器

雪山飞狐_lzh

下面是个原型 2002版本：
  2005版本：注册该Dll在VBA里引用一下下面是一段测试代码：在ThisDrawing模块加入下面的代码

2. Private WithEvents myXHQSet As TlsEntitySet Public Sub EventsInit()
3. On Error GoTo ErrHandle
4.        If myXHQSet Is Nothing Then
5.                Set myXHQSet = New TlsEntitySet
6.                myXHQSet.Name = "TlsXHQ"
7.                myXHQSet.Application = ThisDrawing.Application
8.        End If
9.        myXHQSet.InitDoc
10. ErrHandle:
11. End SubSub TlsXHQ()
12. On Error GoTo ErrHandle       Dim pLine As AcadLine
13.        Dim pCircle As AcadCircle       p1 = ThisDrawing.Utility.GetPoint(, "输入第一点:")
14.        p2 = ThisDrawing.Utility.GetPoint(p1, "输入第二点:")
15.        Set pLine = ThisDrawing.ModelSpace.AddLine(p1, p2)
16.        pDis = ThisDrawing.Utility.GetDistance(p2, "输入圆半径:")
17.        Set pCircle = ThisDrawing.ModelSpace.AddCircle(p2, pDis)
18.        myXHQSet.Add pCircle, Array(pLine.Handle)
19. ErrHandle:
20. End SubPrivate Sub myXHQSet_Modified(ByVal pObject As IAcadObject, ByVal Value As Variant)
21. On Error GoTo ErrHandle       Dim pObj As AcadLine
22.        Dim pStart, pEnd
23.       
24.        Set pObj = ThisDrawing.HandleToObject(Value(0))       pStart = pObj.StartPoint
25.        pEnd = pObject.Center
26.        pAngle = ThisDrawing.Utility.AngleFromXAxis(pStart, pEnd)
27.        pDis = ((pStart(0) - pEnd(0)) ^ 2 + (pStart(1) - pEnd(1)) ^ 2) ^ 0.5 - pObject.Radius
28.        pObj.EndPoint = ThisDrawing.Utility.PolarPoint(pStart, pAngle, pDis)ErrHandle:
29. End Sub

Private WithEvents myXHQSet As TlsEntitySet Public Sub EventsInit() On Error GoTo ErrHandle        If myXHQSet Is Nothing Then                Set myXHQSet = New TlsEntitySet                myXHQSet.Name = "TlsXHQ"                myXHQSet.Application = ThisDrawing.Application        End If        myXHQSet.InitDoc ErrHandle: End SubSub TlsXHQ() On Error GoTo ErrHandle       Dim pLine As AcadLine        Dim pCircle As AcadCircle       p1 = ThisDrawing.Utility.GetPoint(, "输入第一点:")        p2 = ThisDrawing.Utility.GetPoint(p1, "输入第二点:")        Set pLine = ThisDrawing.ModelSpace.AddLine(p1, p2)        pDis = ThisDrawing.Utility.GetDistance(p2, "输入圆半径:")        Set pCircle = ThisDrawing.ModelSpace.AddCircle(p2, pDis)        myXHQSet.Add pCircle, Array(pLine.Handle) ErrHandle: End SubPrivate Sub myXHQSet_Modified(ByVal pObject As IAcadObject, ByVal Value As Variant) On Error GoTo ErrHandle       Dim pObj As AcadLine        Dim pStart, pEnd               Set pObj = ThisDrawing.HandleToObject(Value(0))       pStart = pObj.StartPoint        pEnd = pObject.Center        pAngle = ThisDrawing.Utility.AngleFromXAxis(pStart, pEnd)        pDis = ((pStart(0) - pEnd(0)) ^ 2 + (pStart(1) - pEnd(1)) ^ 2) ^ 0.5 - pObject.Radius        pObj.EndPoint = ThisDrawing.Utility.PolarPoint(pStart, pAngle, pDis)ErrHandle: End Sub

AutoCAD2005Doc.lsp中加入

1. (AutoVBALoad "Tlscad" '("TlsXHQ" "EventsInit") 0)
2. (c:EventsInit)

复制代码

cag

是不是每次都要加载该工程，这个永久反应器才能用？

雪山飞狐_lzh

当然，myXHQSet_Modified事件是处理该反应器的代码，：）

雪山飞狐_lzh

好像没有什么反应，：），自己顶一下，



我把对象双击事件也集成进来了，做的有点象“自定义”对象了

雪山飞狐_lzh

测试代码：

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

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

齿轮设计

班主真好，其[[实也不能说大家不热心，班主的水平实在比常人高出一大截，无法与你平等的讨论，这也是一个类模块吗？类模块真的不好理解

cag

真不错，可以使画出的实体，修改时更为方便了。

zhang007

永久反应器有什么作用？能不能举一个例子。比如双击事件中跟一个逶明命令，把鼠标所在位置移动到屏幕中心

haohaohapp

这个永久反应器有什么用？

my_computer

虽然不知道“反应器”是什么，但只听名字就知道厉害了。