乐筑天下

搜索
欢迎各位开发者和用户入驻本平台 尊重版权,从我做起,拒绝盗版,拒绝倒卖 签到、发布资源、邀请好友注册,可以获得银币 请注意保管好自己的密码,避免账户资金被盗
查看: 139|回复: 9

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

[复制链接]

72

主题

2726

帖子

9

银币

社区元老

Rank: 75Rank: 75Rank: 75

铜币
3014
发表于 2004-11-28 21:00:00 | 显示全部楼层 |阅读模式
下面是个原型 2002版本:
  
2005版本:
注册该Dll在VBA里引用一下下面是一段测试代码:在ThisDrawing模块加入下面的代码
  1. Private WithEvents myXHQSet As TlsEntitySet Public Sub EventsInit()
  2. On Error GoTo ErrHandle
  3.        If myXHQSet Is Nothing Then
  4.                Set myXHQSet = New TlsEntitySet
  5.                myXHQSet.Name = "TlsXHQ"
  6.                myXHQSet.Application = ThisDrawing.Application
  7.        End If
  8.        myXHQSet.InitDoc
  9. ErrHandle:
  10. End SubSub TlsXHQ()
  11. On Error GoTo ErrHandle       Dim pLine As AcadLine
  12.        Dim pCircle As AcadCircle       p1 = ThisDrawing.Utility.GetPoint(, "输入第一点:")
  13.        p2 = ThisDrawing.Utility.GetPoint(p1, "输入第二点:")
  14.        Set pLine = ThisDrawing.ModelSpace.AddLine(p1, p2)
  15.        pDis = ThisDrawing.Utility.GetDistance(p2, "输入圆半径:")
  16.        Set pCircle = ThisDrawing.ModelSpace.AddCircle(p2, pDis)
  17.        myXHQSet.Add pCircle, Array(pLine.Handle)
  18. ErrHandle:
  19. End SubPrivate Sub myXHQSet_Modified(ByVal pObject As IAcadObject, ByVal Value As Variant)
  20. On Error GoTo ErrHandle       Dim pObj As AcadLine
  21.        Dim pStart, pEnd
  22.       
  23.        Set pObj = ThisDrawing.HandleToObject(Value(0))       pStart = pObj.StartPoint
  24.        pEnd = pObject.Center
  25.        pAngle = ThisDrawing.Utility.AngleFromXAxis(pStart, pEnd)
  26.        pDis = ((pStart(0) - pEnd(0)) ^ 2 + (pStart(1) - pEnd(1)) ^ 2) ^ 0.5 - pObject.Radius
  27.        pObj.EndPoint = ThisDrawing.Utility.PolarPoint(pStart, pAngle, pDis)ErrHandle:
  28. End Sub
2005Doc.lsp中加入复制代码


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

本帖以下内容被隐藏保护;需要你回复后,才能看到!

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

使用道具 举报

cag

87

主题

265

帖子

10

银币

中流砥柱

Rank: 25

铜币
613
发表于 2004-11-28 21:04:00 | 显示全部楼层
是不是每次都要加载该工程,这个永久反应器才能用?
回复

使用道具 举报

72

主题

2726

帖子

9

银币

社区元老

Rank: 75Rank: 75Rank: 75

铜币
3014
发表于 2004-11-28 21:07:00 | 显示全部楼层
当然,myXHQSet_Modified事件是处理该反应器的代码,:)
回复

使用道具 举报

72

主题

2726

帖子

9

银币

社区元老

Rank: 75Rank: 75Rank: 75

铜币
3014
发表于 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做永久反应器
回复

使用道具 举报

72

主题

2726

帖子

9

银币

社区元老

Rank: 75Rank: 75Rank: 75

铜币
3014
发表于 2004-12-3 23:27:00 | 显示全部楼层

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

使用道具 举报

4

主题

19

帖子

2

银币

初来乍到

Rank: 1

铜币
35
发表于 2004-12-4 22:48:00 | 显示全部楼层
班主真好,其[[实也不能说大家不热心,班主的水平实在比常人高出一大截,无法与你平等的讨论,这也是一个类模块吗?类模块真的不好理解
回复

使用道具 举报

cag

87

主题

265

帖子

10

银币

中流砥柱

Rank: 25

铜币
613
发表于 2004-12-11 09:40:00 | 显示全部楼层
真不错,可以使画出的实体,修改时更为方便了。
回复

使用道具 举报

10

主题

131

帖子

7

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
171
发表于 2004-12-11 10:56:00 | 显示全部楼层
永久反应器有什么作用?能不能举一个例子。比如双击事件中跟一个逶明命令,把鼠标所在位置移动到屏幕中心
回复

使用道具 举报

9

主题

33

帖子

2

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
69
发表于 2005-1-20 10:12:00 | 显示全部楼层
这个永久反应器有什么用?
回复

使用道具 举报

12

主题

135

帖子

5

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
183
发表于 2005-1-22 08:23:00 | 显示全部楼层
虽然不知道“反应器”是什么,但只听名字就知道厉害了。
回复

使用道具 举报

发表回复

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

  • 微信公众平台

  • 扫描访问手机版

  • 点击图片下载手机App

QQ|关于我们|小黑屋|乐筑天下 繁体中文

GMT+8, 2025-3-16 19:43 , Processed in 1.164714 second(s), 82 queries .

© 2020-2025 乐筑天下

联系客服 关注微信 帮助中心 下载APP 返回顶部 返回列表