乐筑天下

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

分解非均匀缩放的块

[复制链接]

9

主题

15

帖子

2

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
51
发表于 2007-2-26 20:07:05 | 显示全部楼层 |阅读模式
我想使用VBA执行爆炸非均匀缩放块。
在这种情况下,是否只有一种方法可以使用 SendCommand?
请提出建议。
  1. [color=green]'Bellow code is written by Randall Rath---------------------[/color]
  2. Public Function ExplodeEX(oBlkRef As AcadBlockReference, _
  3.     bKeep As Boolean) As Variant
  4.     Dim objEnt As AcadEntity
  5.     Dim objMT As AcadMText
  6.     Dim objBlk As AcadBlock
  7.     Dim objDoc As AcadDocument
  8.     Dim objArray() As AcadEntity
  9.     Dim objSpace As AcadBlock
  10.     Dim intCnt As Integer
  11.     Dim varTemp As Variant
  12.     Dim varPnt As Variant
  13.     Dim dblScale As Double
  14.     Dim dblRot As Double
  15.     Dim dblMatrix(3, 3) As Double
  16.     On Error GoTo Err_Control
  17.     'What document is the reference in?
  18.     Set objDoc = oBlkRef.Document
  19.     'Model space or layout?
  20.     Set objSpace = objDoc.ObjectIdToObject(oBlkRef.OwnerID)
  21.     Set objBlk = objDoc.Blocks(oBlkRef.Name)
  22.     varPnt = oBlkRef.InsertionPoint
  23.     dblScale = oBlkRef.XScaleFactor
  24.     dblRot = oBlkRef.Rotation
  25.     'Set the matrix for new objects transform
  26.     '*Note:
  27.     'This matrix uses only the X scale factor of the
  28.     'Block reference, many entities can not be scaled
  29.     'Non-uniformly!
  30.     dblMatrix(0, 0) = dblScale
  31.     dblMatrix(0, 1) = 0
  32.     dblMatrix(0, 2) = 0
  33.     dblMatrix(0, 3) = varPnt(0)
  34.     dblMatrix(1, 0) = 0
  35.     dblMatrix(1, 1) = dblScale
  36.     dblMatrix(1, 2) = 0
  37.     dblMatrix(1, 3) = varPnt(1)
  38.     dblMatrix(2, 0) = 0
  39.     dblMatrix(2, 1) = 0
  40.     dblMatrix(2, 2) = dblScale
  41.     dblMatrix(2, 3) = varPnt(2)
  42.     dblMatrix(3, 0) = 0
  43.     dblMatrix(3, 1) = 0
  44.     dblMatrix(3, 2) = 0
  45.     dblMatrix(3, 3) = 1
  46.     'Get all of the entities in the block
  47.     ReDim objArray(objBlk.Count - 1)
  48.     For Each objEnt In objBlk
  49.         Set objArray(intCnt) = objEnt
  50.         intCnt = intCnt + 1
  51.     Next objEnt
  52.     'Place them into the correct space
  53.     varTemp = objDoc.CopyObjects(objArray, objSpace)
  54.     'Transform & rotate
  55.     For intCnt = LBound(varTemp) To UBound(varTemp)
  56.         Set objEnt = varTemp(intCnt)
  57.         objEnt.TransformBy dblMatrix
  58.         objEnt.Rotate varPnt, dblRot
  59.     Next intCnt
  60.     'Keep the block reference?
  61.     If Not bKeep Then
  62.         oBlkRef.Delete
  63.     End If
  64.     'Return all of the new entities
  65.     ExplodeEX = varTemp
  66.     'Release memory
  67.     Set objDoc = Nothing
  68.     Set objBlk = Nothing
  69.     Set objSpace = Nothing
  70.     Exit_Here:
  71.     Exit Function
  72.     Err_Control:
  73.     MsgBox Err.Description
  74.     Resume Exit_Here
  75. End Function

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

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

使用道具 举报

170

主题

1424

帖子

8

银币

顶梁支柱

Rank: 50Rank: 50

铜币
2119
发表于 2007-2-27 00:36:24 | 显示全部楼层
太可惜了..
无论如何,谢谢布里科,格伦R..
回复

使用道具 举报

发表回复

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

本版积分规则

  • 微信公众平台

  • 扫描访问手机版

  • 点击图片下载手机App

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

GMT+8, 2025-7-7 09:54 , Processed in 0.663361 second(s), 56 queries .

© 2020-2025 乐筑天下

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