（完成 8.2 更新）[编程申请]：可否编将文字与线齐平功能拓展，选中块的某一边将他与

心竹 · 发表于 2004-6-24 10:19:28

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

这两天在做村规，以保留改造为主，现状房子基本都不平行，要见缝插针的布置规划民宅，我在用align命令对齐，感觉还是很麻烦，想要更简便的方法见下图，即选中套型块A的一边，在选中要与之平行的线，块马上就能与线平行（块中带圆圈的线与参照线齐平）

eachy · 发表于 2004-6-24 11:22:32

你说的不充分，CAD中的线有起始点之分，你点两个线能对齐但有可能反向。

;; 单一实体（块、多义线）某一曲线对齐，相当于 align 中的两点对齐
;; 现在只要选择两个线就可以，对齐基准为鼠标临近点
(defun c:xdtb_align (/ $getpoint e1 e2 pt1 pt2 tf an mat mat0 v v1 v2)
(defun $getpoint (e / p blk mat p1 etyp ptl
sp ep p2 pam index1 index2
lst blk e1
)
(setq p (cadr e)
e1 (car e)
)
(if (= (length e) 4) ;Insert
(setq blk (last (last e)) ;Block
mat (xdrx_matrix_block2wcs blk)
p1 (xdrx_point_transform p (xdrx_matrix_inverse mat))
;WCS->OCS
)
)
(xdrx_setenttodb e1)
(setq etyp (xdrx_getentdxf 0)
ptl (xdrx_curve_getpoint e1)
)
(cond
((= etyp "LINE")
(setq sp (car ptl)
ep (last ptl)
)
)
((wcmatch etyp "*POLYLINE")
(setq p2 (xdrx_curve_getclosestpoint
e1
(if p1
p1
p
)
)
pam (xdrx_curve_getparamatpoint e1 p2)
index1 (fix pam)
)
(if (< index1 pam)
(setq index2 (1+ index1))
(setq index2 (1- index1))
)
(setq sp (xdrx_polyline_getpointAt e1 index1)
ep (xdrx_polyline_getpointat e1 index2)
)
(if (not ep)
(setq ep (last ptl))
)
)
(t)
)
(if sp
(progn
(if blk
(setq sp (xdrx_point_transform sp mat)
ep (xdrx_point_transform ep mat)
)
)
(if (<= (distance p sp) (distance p ep))
(setq lst (list sp ep))
(setq lst (list ep sp))
)
)
)
)
(setq tf t)
;;main
(while tf
(if (and (setq e1 (nentsel "\n拾取目标实体的对齐线: "))
(setq e2 (nentsel "\n拾取源实体的对齐线: "))
(setq pt1 ($getpoint e1))
(setq pt2 ($getpoint e2))
)
(progn
(setq v1 (mapcar '- (car pt1) (cadr pt1))
v2 (mapcar '- (car pt2) (cadr pt2))
v (mapcar '- (car pt1) (car pt2))
an (- (angle '(0. 0.) v1) (angle '(0. 0.) v2))
mat (xdrx_matrix_identity 3)
mat0 (xdrx_matrix_Product
(xdrx_matrix_settranslation mat v)
(xdrx_matrix_setrotation mat an '(0. 0. 1.) (car pt2))
)
)
;(xdrx_entity_transformedcopy
(xdrx_entity_transform
(if (= (length e2) 2)
(car e2)
(last (last e2))
)
mat0
)
)
(setq tf nil)
)
)
(princ)
)

;; 单一实体（块、多义线）某一曲线对齐，相当于 align 中的两点对齐 
;; 现在只要选择两个线就可以，对齐基准为鼠标临近点 
(defun c:xdtb_align (/ $getpoint e1 e2 pt1 pt2 tf an mat mat0 v v1 v2) 
  (defun $getpoint (e          /        p     blk   mat          p1        etyp  ptl 
                    sp          ep        p2    pam   index1        index2 
                    lst          blk        e1 
                   ) 
    (setq p  (cadr e) 
          e1 (car e) 
    ) 
    (if        (= (length e) 4)                ;Insert 
      (setq blk        (last (last e))                ;Block 
            mat        (xdrx_matrix_block2wcs blk) 
            p1        (xdrx_point_transform p (xdrx_matrix_inverse mat)) 
                                        ;WCS->OCS 
      ) 
    ) 
    (xdrx_setenttodb e1) 
    (setq etyp (xdrx_getentdxf 0) 
          ptl  (xdrx_curve_getpoint e1) 
    ) 
    (cond 
      ((= etyp "LINE") 
       (setq sp        (car ptl) 
             ep        (last ptl) 
       ) 
      ) 
      ((wcmatch etyp "*POLYLINE") 
       (setq p2            (xdrx_curve_getclosestpoint 
                      e1 
                      (if p1 
                        p1 
                        p 
                      ) 
                    ) 
             pam    (xdrx_curve_getparamatpoint e1 p2) 
             index1 (fix pam) 
       ) 
       (if (< index1 pam) 
         (setq index2 (1+ index1)) 
         (setq index2 (1- index1)) 
       ) 
       (setq sp        (xdrx_polyline_getpointAt e1 index1) 
             ep        (xdrx_polyline_getpointat e1 index2) 
       ) 
       (if (not ep) 
         (setq ep (last ptl)) 
       ) 
      ) 
      (t) 
    ) 
    (if        sp 
      (progn 
        (if blk 
          (setq        sp (xdrx_point_transform sp mat) 
                ep (xdrx_point_transform ep mat) 
          ) 
        ) 
        (if (<= (distance p sp) (distance p ep)) 
          (setq lst (list sp ep)) 
          (setq lst (list ep sp)) 
        ) 
      ) 
    ) 
  ) 
  (setq tf t) 
  ;;main 
  (while tf 
    (if        (and (setq e1 (nentsel "\n拾取目标实体的对齐线: ")) 
             (setq e2 (nentsel "\n拾取源实体的对齐线: ")) 
             (setq pt1 ($getpoint e1)) 
             (setq pt2 ($getpoint e2)) 
        ) 
      (progn 
        (setq v1   (mapcar '- (car pt1) (cadr pt1)) 
              v2   (mapcar '- (car pt2) (cadr pt2)) 
              v           (mapcar '- (car pt1) (car pt2)) 
              an   (- (angle '(0. 0.) v1) (angle '(0. 0.) v2)) 
              mat  (xdrx_matrix_identity 3) 
              mat0 (xdrx_matrix_Product 
                     (xdrx_matrix_settranslation mat v) 
                     (xdrx_matrix_setrotation mat an '(0. 0. 1.) (car pt2)) 
                   ) 
        ) 
                                        ;(xdrx_entity_transformedcopy 
        (xdrx_entity_transform 
          (if (= (length e2) 2) 
            (car e2) 
            (last (last e2)) 
          ) 
          mat0 
        ) 
      ) 
      (setq tf nil) 
    ) 
  ) 
  (princ) 
)

心竹 · 发表于 2004-6-25 23:45:51

ea试了一下，总感觉还模不到规律
用一个带缺口的长方形块做试验，想让缺口边线和目标线对齐，结果相反，碰见了一个奇怪的现象，将线条设置颜色做成的块运行命令后跑到很远去了。

心竹 · 发表于 2004-6-25 23:47:07

试验的图

自由的鱼 · 发表于 2004-6-26 00:20:25

试试这个程序，可以完成平行，当然房子必须是一个整体！
图中1-2方向为参照方向，3-4,5-6为要旋转的轴！打开捕捉，用点选，1、2、3、4、5、6。。。这样连续选下去，选完所有要旋转的房子后，回车，OK！程序有点乱，也没写错误处理，等有时间再完善！：）

Option Explicit

Sub rott()
On Error Resume Next
Dim sset As AcadSelectionSet
Dim czfx As Double
Dim pnt() As Variant
Dim zds As Integer
'Dim pnt2 As Variant
Dim czfx1 As Double
Dim fxc As Double
Dim i As Integer
Dim j As Integer
i = 0
On Error GoTo 1
Do
ReDim Preserve pnt(i)
pnt(i) = ThisDrawing.Utility.GetPoint(, "choose")
' For j = 0 To 2
' Debug.Print pnt(i)(j)
' Next

i = i + 1
zds = i
Loop

1:

Set sset = ThisDrawing.SelectionSets.Add("t111t1")

'MsgBox zds
czfx = ThisDrawing.Utility.AngleFromXAxis(pnt(0), pnt(1))
On Error Resume Next
For i = 2 To zds - 1 Step 2
sset.SelectAtPoint (pnt(i))
czfx1 = ThisDrawing.Utility.AngleFromXAxis(pnt(i), pnt(i + 1))
fxc = czfx1 - czfx
      If fxc > 0 Then
         sset.Item(0).Rotate pnt(i), -fxc
         Else
         sset.Item(0).Rotate pnt(i), fxc
      End If
sset.Clear
Next
sset.Delete

'MsgBox czfx
Exit Sub
err:
Exit Sub
End Sub

eachy · 发表于 2004-6-26 16:40:42

最初由心竹发布
[B]ea试了一下，总感觉还模不到规律
用一个带缺口的长方形块做试验，想让缺口边线和目标线对齐，结果相反，碰见了一个奇怪的现象，将线条设置颜色做成的块运行命令后跑到很远去了。 [/B]

是块内实体的的坐标转换问题，解决中

陌生人 · 发表于 2004-6-27 21:13:15

;;发个用命令的。可连续选择.
[php]
(defun c:xal (/ e1 p1 p1s p1m e2 p2 p2s p2m pt )
 (vl-cmdf ".undo" "be")
 (arxload "geom3d")
 (setq e1 (nentsel "\n选align参照实体/<退出>:"))
 (setq p1 (trans (cadr e1) 2 1)
p1s (osnap p1 "end")
p1m (osnap p1 "nea"))
 (princ "\n选align目标实体/<退出>:")
 (while (setq pt (getpoint))
(if
 (and(setq e2 (nentselp pt))
 (setq ss (ssget pt)
 p2 (trans (cadr e2) 2 1)
 p2m (osnap p2 "nea")
 p2s (osnap p2 "end"))
 (and p1s p1m p2s p2m ss)
 )
 ;(vl-cmdf ".move" ss "" p2s p1s ".rotate" ss "" p1s "r" p2s p2m p1m)
 (align ss p2s p1s p2m p1m "" "")
)
 )
 (vl-cmdf ".undo" "e")
 (princ)
)
[/php]
演示中有些点取实体的关键贞没捕捉到：（

eachy · 发表于 2004-6-27 21:26:55

最初由陌生人发布
[B];;发个用命令的。可连续选择.
[php]
(defun c:xal (/ e1 p1 p1s p1m e2 p2 p2s p2m pt )
 (vl-cmdf ".undo" "be")
 (setq e1 (nentsel "\n选align参照实体/<退出>:"))
 (setq p1 (trans (cadr e1) 2 1)
p... [/B]

既然点都有了，还可以使用 align 命令

心竹 · 发表于 2004-6-28 08:28:28

鱼儿和陌生银，俺好感动哦，你门太瞧得起俺了，可俺是菜鸟级，你门贴的这些东东怎么用？拷贝下来存成什么格式的文件？

民工 · 发表于 2004-6-28 14:05:34

最初由心竹发布
[B]鱼儿和陌生银，俺好感动哦，你门太瞧得起俺了，可俺是菜鸟级，你门贴的这些东东怎么用？拷贝下来存成什么格式的文件？ [/B]

下载附件的lsp文件
在acad里面加载，命令名我改成ag了，简单点

自由的鱼 · 发表于 2004-6-28 18:23:18

最初由心竹发布
[B]鱼儿和陌生银，俺好感动哦，你门太瞧得起俺了，可俺是菜鸟级，你门贴的这些东东怎么用？拷贝下来存成什么格式的文件？ [/B]

vba程序COPY下来，在CAD命令行中输入vbaide，然后把代码贴进去，保存成DVB文件！

寒梅 · 发表于 2004-7-31 12:14:49

ea，这个命令有没有最新的改进版本？感觉用起来还不是很好，不稳定，我没法掌握他的规律，有时要出错

寒梅 · 发表于 2004-7-31 12:16:30

这是我演示用的图

民工 · 发表于 2004-8-1 01:31:05

我用rectang创建的矩形在对齐的时候也是出错，只是将角上的端点对齐了，点选的边没有对齐

寒梅 · 发表于 2004-8-2 22:14:46

谢谢ea的修改，程序现在已经很好用了，感兴趣的朋友可以将二楼的内容复制存成lisp，用appload加载。
——ea还有个小小请求，现在的对齐一次只能对齐一个物体，能不能选择多个物体？

账号		自动登录	找回密码
密码			立即注册

（完成 8.2 更新）[编程申请]：可否编将文字与线齐平功能拓展，选中块的某一边将他与

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子