【越飞越高讲堂9】如何像photoshop那样-CAD中的平面几何变换及其矩阵 - AutoLISP/Visual LISP 编程技术 - AutoCAD论坛 - 明经CAD社区 - 第2页

ahlzl 发表于 2006-12-31 18:34:00

本帖最后由作者于 2006-12-31 18:36:53 编辑 我改了一下程序。现在能实现第8贴中图1的效果。Option Explicit Const PI As Double = 3.1415926535897Public Sub Chamfering()     On Error Resume Next         Dim SSet As AcadSelectionSet     If Not IsNull(ThisDrawing.SelectionSets.Item("chamfering")) Then         Set SSet = ThisDrawing.SelectionSets.Item("chamfering")         SSet.Delete     End If     Set SSet = ThisDrawing.SelectionSets.Add("chamfering")     ThisDrawing.Utility.Prompt ("选择要斜切的对象...")     SSet.SelectOnScreen         Dim ptBase As Variant     ptBase = ThisDrawing.Utility.GetPoint(, "请输入斜切对象的基点:")         Dim pt2 As Variant     pt2 = ThisDrawing.Utility.GetPoint(ptBase, "请输入斜切对象的插入点:")         Dim angle As Double     angle = ThisDrawing.Utility.GetAngle(ptBase, "请输入倾斜角度:")         If Abs((angle / (0.5 * PI)) - Int(angle / (0.5 * PI))) < 0.001 Then         MsgBox ("您输入的角度不合适,无法完成操作!")         Exit Sub     End If         Dim newb As AcadBlock, newbName As String, n As Integer     n = 1     newbName = "ahlzl" BLOCK2:     For Each newb In ThisDrawing.Blocks         If newb.Name = newbName Then             newbName = "ahlzl" & "_" & CStr(n)             n = n + 1             GoTo BLOCK2         End If     Next newb     Set newb = ThisDrawing.Blocks.Add(ptBase, newbName)         Dim objCollection0() As Object, i As Integer     ReDim objCollection0(SSet.Count - 1) As Object     For i = 0 To SSet.Count - 1         Set objCollection0(i) = SSet.Item(i)     Next         Dim retObjects0 As Variant     retObjects0 = ThisDrawing.CopyObjects(objCollection0, newb)         Dim a1 As AcadBlockReference     Set a1 = ThisDrawing.ModelSpace.InsertBlock(ptBase, newbName, 1 / Cos(angle), 1, 1, 0)         a1.Rotate ptBase, DegreeToRadian(-45)        Dim strBlkName As String     strBlkName = "CAD倾斜"     n = 1    Dim blockObj As AcadBlock BLOCK:     For Each blockObj In ThisDrawing.Blocks         If blockObj.Name = strBlkName Then             strBlkName = "CAD倾斜" & "_" & CStr(n)             n = n + 1             GoTo BLOCK         End If     Next blockObj     Set blockObj = ThisDrawing.Blocks.Add(ptBase, strBlkName)         Dim objCollection(0) As Object     Set objCollection(0) = a1       Dim retObjects As Variant     retObjects = ThisDrawing.CopyObjects(objCollection, blockObj)         Dim xScale As Double, yScale As Double, zScale As Double, ang As Double     xScale = Cos(PI / 4 - angle / 2) / Cos(DegreeToRadian(45))     yScale = Sin(PI / 4 - angle / 2) / Sin(DegreeToRadian(45))     zScale = 1     ang = PI / 4 + angle / 2       Dim ref1 As AcadBlockReference     Set ref1 = ThisDrawing.ModelSpace.InsertBlock(pt2, strBlkName, xScale, yScale, zScale, ang)         a1.Delete     SSet.Delete End SubPrivate Function DegreeToRadian(angle As Double) As Double     DegreeToRadian = angle * PI / 180 End Function

byghbcx 发表于 2007-1-8 11:28:00

感谢两位版主提供的程序代码,我试着对块进行转换,但对带属性的块不能生成无名块,还请high兄多指教.

byghbcx 发表于 2007-1-8 11:35:00

(<a href="http://www.mjtd.com/object/autolisp/defun.htm" target="_black">defun</a>
Nmblock
(ss pt k <a href="http://www.mjtd.com/object/autolisp/47.htm" target="_black">/</a> i n num) (<a href="http://www.mjtd.com/object/autolisp/entmake.htm" target="_black">entmake</a>(list(<a href="http://www.mjtd.com/object/autolisp/cons.htm" target="_black">cons</a>
0
"BLOCK")(<a href="http://www.mjtd.com/object/autolisp/cons.htm" target="_black">cons</a>
2
"*u")(<a href="http://www.mjtd.com/object/autolisp/cons.htm" target="_black">cons</a>
70
1)
(<a href="http://www.mjtd.com/object/autolisp/cons.htm" target="_black">cons</a>
10 pt))) (<a href="http://www.mjtd.com/object/autolisp/setq.htm" target="_black">setq</a> i (<a href="http://www.mjtd.com/object/autolisp/sslength.htm" target="_black">sslength</a> ss) n (-
1)) (<a href="http://www.mjtd.com/object/autolisp/repeat.htm" target="_black">repeat</a> i (<a href="http://www.mjtd.com/object/autolisp/entmake.htm" target="_black">entmake</a>(cdr (<a href="http://www.mjtd.com/object/autolisp/entget.htm" target="_black">entget</a>(ssname ss (<a href="http://www.mjtd.com/object/autolisp/setq.htm" target="_black">setq</a> n (<a href="http://www.mjtd.com/object/autolisp/1+.htm" target="_black">1+</a> n))))))) (<a href="http://www.mjtd.com/object/autolisp/setq.htm" target="_black">setq</a> num (<a href="http://www.mjtd.com/object/autolisp/entmake.htm" target="_black">entmake</a> '((0
.
"ENDBLK")))) (<a href="http://www.mjtd.com/object/autolisp/entmake.htm" target="_black">entmake</a>(list(<a href="http://www.mjtd.com/object/autolisp/cons.htm" target="_black">cons</a>
0
"INSERT")
(<a href="http://www.mjtd.com/object/autolisp/cons.htm" target="_black">cons</a>
2 num)
(<a href="http://www.mjtd.com/object/autolisp/cons.htm" target="_black">cons</a>
10 pt))) 
(<a href="http://www.mjtd.com/object/autolisp/if.htm" target="_black">if</a> k(<a href="http://www.mjtd.com/object/autolisp/progn.htm" target="_black">progn</a>(<a href="http://www.mjtd.com/object/autolisp/setq.htm" target="_black">setq</a> i (<a href="http://www.mjtd.com/object/autolisp/sslength.htm" target="_black">sslength</a> ss) n (-
1)) (<a href="http://www.mjtd.com/object/autolisp/repeat.htm" target="_black">repeat</a> i(<a href="http://www.mjtd.com/object/autolisp/entdel.htm" target="_black">entdel</a>(ssname ss (<a href="http://www.mjtd.com/object/autolisp/setq.htm" target="_black">setq</a> n (<a href="http://www.mjtd.com/object/autolisp/1+.htm" target="_black">1+</a> n))))))) 
; (<a href="http://www.mjtd.com/object/autolisp/command.htm" target="_black">command</a>
".erase" ss "") )

highflybir 发表于 2007-1-8 13:03:00

按照ahlzl的两次做块的思路，调整了其中的系数和数值，重新写了一个变换程序，这个程序已经能对任何CAD实体进行变换了。

byghbcx 发表于 2007-1-8 15:06:00

谢谢highflybir兄作出的及时回应,你的程序很好,在第二次匿名块名图块炸开后,有的东西又复原了,如尺寸线,文字等.不过用你的Nblock程序对带属性块有作用,加载到我的transblock中可以用.我的程序中还有就是没有清理无用的匿名块.加入反应器后,拉的次数过多,系统会吃不消.

changchangyouyu 发表于 2010-9-28 19:48:00

这么好的帖子，怎么就能沉呢，没天理。顶起！

yoyoho 发表于 2010-9-28 21:23:00

感谢分享程序
收藏学习!

cheng5276 发表于 2010-10-6 00:13:00

高手们在华山论剑！太强了！我等丐帮的2袋弟子只能瞠目结舌啊

lrd1861 发表于 2011-7-7 06:06:00

好贴顶起来

ljpnb 发表于 2011-7-7 06:27:01

确实强大,几位版大厉害,要努力学一下

页: 1 [2] 3

明经CAD社区's Archiver