[讨论]用VB做永久反应器
本帖最后由 作者 于 2004-11-29 22:55:02 编辑下面是个原型 2002版本：
2005版本：注册该Dll在VBA里引用一下下面是一段测试代码：在ThisDrawing模块加入下面的代码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 SubAutoCad2005Doc.lsp中加入(AutoVBALoad "Tlscad" '("TlsXHQ" "EventsInit") 0)
(c:EventsInit) 是不是每次都要加载该工程，这个永久反应器才能用？ 当然，myXHQSet_Modified事件是处理该反应器的代码，：） 本帖最后由 作者 于 2004-12-5 22:25:34 编辑
好像没有什么反应，：），自己顶一下，
我把对象双击事件也集成进来了，做的有点象“自定义”对象了
本帖最后由 作者 于 2004-12-5 22:26:55 编辑
测试代码：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 班主真好，其[[实也不能说大家不热心，班主的水平实在比常人高出一大截，无法与你平等的讨论，这也是一个类模块吗？类模块真的不好理解 真不错，可以使画出的实体，修改时更为方便了。 永久反应器有什么作用？能不能举一个例子。比如双击事件中跟一个逶明命令，把鼠标所在位置移动到屏幕中心 这个永久反应器有什么用？ <b> 虽然不知道“反应器”是什么，但只听名字就知道厉害了。</b><BR>