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

雪山飞狐_lzh · 发表于 2004-11-28 21:00

本帖最后由作者于 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 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中加入

(AutoVBALoad "Tlscad" '("TlsXHQ" "EventsInit") 0)
(c:EventsInit)

复制代码

cag · 发表于 2004-11-28 21:04

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

雪山飞狐_lzh · 发表于 2004-11-28 21:07

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

雪山飞狐_lzh · 发表于 2004-12-3 22:21

本帖最后由作者于 2004-12-5 22:25:34 编辑

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

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

雪山飞狐_lzh · 发表于 2004-12-3 23:27

本帖最后由作者于 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

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

齿轮设计 · 发表于 2004-12-4 22:48

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

cag · 发表于 2004-12-11 09:40

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

zhang007 · 发表于 2004-12-11 10:56

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

haohaohapp · 发表于 2005-1-20 10:12

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

my_computer · 发表于 2005-1-22 08:23

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

账号		自动登录	找回密码
密码			注册

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

本帖子中包含更多资源

本帖子中包含更多资源