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

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

下面是个原型 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

2005Doc.lsp中加入复制代码

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

本帖以下内容被隐藏保护；需要你回复后，才能看到！

游客，如果您要查看本帖隐藏内容请回复

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

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

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

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

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

好像没有什么反应，：），自己顶一下，我把对象双击事件也集成进来了，做的有点象“自定义”对象了

请点击此处下载

请先注册会员后在进行下载

已注册会员，请先登录后下载

文件名称:osc2odhuhcu.rar
下载次数:0 文件大小:42.49 KB 售价:2银币 [记录]
下载权限: 不限以上或 Vip会员 [开通Vip] [签到领银币] [免费赚银币]

请点击此处下载

请先注册会员后在进行下载

已注册会员，请先登录后下载

文件名称:1i1zq05e4kk.rar
下载次数:0 文件大小:42.06 KB 售价:2银币 [记录]
下载权限: 不限以上或 Vip会员 [开通Vip] [签到领银币] [免费赚银币]

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

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

测试代码：

copy


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