【越飞越高讲堂9】如何像photoshop那样---CAD中的平面几何变换及其矩阵

ahlzl

我改了一下程序。现在能实现第8贴中图1的效果。

Option Explicit
Const PI As Double = 3.1415926535897

Public 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 Sub

Private Function DegreeToRadian(angle As Double) As Double
    DegreeToRadian = angle * PI / 180
End Function

byghbcx

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

byghbcx

(defun Nmblock (ss pt k / i n num)
(entmake(list(cons 0 "BLOCK")(cons 2 "*u")(cons 70 1) (cons 10 pt)))
(setq i (sslength ss) n (- 1))
(repeat i (entmake(cdr (entget(ssname ss (setq n (1+ n)))))))
(setq num (entmake '((0 . "ENDBLK"))))
(entmake(list(cons 0 "INSERT") (cons 2 num) (cons 10 pt)))
(if k(progn(setq i (sslength ss) n (- 1))
(repeat i(entdel(ssname ss (setq n (1+ n)))))))
; (command ".erase" ss "")

)

highflybir

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

byghbcx

谢谢highflybir兄作出的及时回应,你的程序很好,在第二次匿名块名图块炸开后,有的东西又复原了,如尺寸线,文字等.

不过用你的Nblock程序对带属性块有作用,加载到我的transblock中可以用.我的程序中还有就是没有清理无用的匿名块.加入反应器后,拉的次数过多,系统会吃不消.

 

changchangyouyu

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

yoyoho

感谢分享程序

收藏学习!

cheng5276

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

lrd1861

好贴   顶起来

ljpnb

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