求助怎么快速生成矩形的黄金分割线？

月下闲人 · 发表于 2024-12-30 22:16:49

求助怎么快速生成矩形横向和纵向的黄金分割线？

xyp1964 · 发表于 2024-12-31 11:48:59

;; 实体黄金分割线

Bao_lai · 发表于 2024-12-30 22:52:57

距离的(√5-1)/2

月下闲人 · 发表于 2024-12-31 19:35:29

xyp1964 发表于 2024-12-31 11:48
;; 实体黄金分割线

很好→很棒！很好~很棒！！

月下闲人 · 发表于 2025-1-1 23:41:15

xyp1964 发表于 2024-12-31 11:48
;; 实体黄金分割线

院长我找到你多年以前的代码

;;;黄金比 : hjb
(defun c:hjb ()
(setq  pt1 (getpoint "\n起点 :")
  no6 (getreal "\n短边长 : ")
  leng    (/ (- (sqrt 5) 1) 2);黄金比长边尺寸
  pt2 (list (+ (car pt1) no6) (+ (cadr pt1) (* no6 leng)))
)
(command "rectang" pt1 pt2);黄金比的长方形
)

xyp1964 · 发表于 2025-1-2 13:08:08

月下闲人发表于 2025-1-1 23:41
院长我找到你多年以前的代码
;;;黄金比 : hjb
(defun c:hjb ()

(defun c:tt ()
"黄金比矩形"
(setq dd (Udist 7 "" "短边长<输入或鼠标直接量取>" dd nil)
sc (/ (- (sqrt 5) 1) 2.) ;黄金比
)
(while (setq p1 (getpoint "\n起点<退出>: "))
(setq p2 (list (+ (car p1) dd) (+ (cadr p1) (* dd sc)))
s1 (command "rectang" "non" p1 "non" p2)
)
)
(princ)
)

月下闲人 · 发表于 2025-1-2 20:46:56

xyp1964 发表于 2025-1-2 13:08

再次感谢很好用

月下闲人 · 发表于 2025-3-8 11:35:41

本帖最后由月下闲人于 2025-3-8 11:36 编辑

xyp1964 发表于 2024-12-31 11:48
;; 实体黄金分割线

院长好  麻烦帮我看看哪里不对  谢谢了

(defun c:HJJ (/ *acad* *doc* ss i ent obj result minPt maxPt width height hSplitY vSplitX)
  (vl-load-com)
  (setq *acad* (vlax-get-acad-object))
  (setq *doc* (vla-get-activedocument *acad*))

  ;; 创建或获取黄金分割线图层
  (if (not (tblsearch "LAYER" "HJX-黄金线"))
(vla-add (vla-get-layers *doc*) "HJX-黄金线")
  )
  (vla-put-color (vla-item (vla-get-layers *doc*) "HJX-黄金线") 1)
  (vla-put-linetype (vla-item (vla-get-layers *doc*) "HJX-黄金线") "Continuous")

  ;; 用户交互
  (prompt "\n请选择对象: ")
  (if (setq ss (ssget '((0 . "CIRCLE,ELLIPSE,LWPOLYLINE,POLYLINE,SPLINE,INSERT,HATCH"))))
(progn
   (repeat (setq i (sslength ss))
      (setq ent (ssname ss (setq i (1- i)))
            obj (vlax-ename->vla-object ent))
      ;; 安全获取边界框
      (setq result (vl-catch-all-apply 'vla-getboundingbox (list obj 'minPt 'maxPt)))
      (if (vl-catch-all-error-p result))
      (princ "\n错误: 无法获取对象的边界框。")
      (progn
         ;; 转换坐标数据
         (setq minPt (vlax-safearray->list (vlax-variant-value minPt)))
         (setq maxPt (vlax-safearray->list (vlax-variant-value maxPt)))
         ;; 计算尺寸
         (setq width (- (car maxPt) (car minPt))
               height (- (cadr maxPt) (cadr minPt)))
         )
         ;; 有效性检查
         (if (and (> width 1e-6) (> height 1e-6))  ; 避免浮点误差
            (progn
            ;; 计算黄金分割点
            (setq hSplitY (+ (cadr minPt) (* height 0.618))
            (setq vSplitX (+ (car minPt) (* width 0.618)))
            ;; 创建分割线
            (entmakex (list '(0 . "LINE")
                              '(8 . "HJX-黄金线")
                              (cons 10 (list (car minPt) hSplitY 0.0))
                              (cons 11 (list (car maxPt) hSplitY 0.0))
            )
            (entmakex (list '(0 . "LINE")
                              '(8 . "HJX-黄金线")
                              (cons 10 (list vSplitX (cadr minPt) 0.0))
                              (cons 11 (list vSplitX (cadr maxPt) 0.0))
            )
            )
            (princ "\n警告: 对象尺寸过小或无效，已跳过。")
         )
      )
      )
   )
)
(princ "\n未选择有效对象。"))
  (princ)
)

xyp1964 · 发表于 2025-3-8 16:35:19

月下闲人发表于 2025-3-8 11:35
院长好麻烦帮我看看哪里不对谢谢了

(defun c:HJJ (/ *acad* *doc* ss i ent obj result minPt max ...

(defun c:tt ()
(setq *doc* (vla-get-activedocument (vlax-get-acad-object)))
(vla-add (vla-get-layers *doc*) "HJX-黄金线")
(vla-put-color(vla-item (vla-get-layers *doc*)"HJX-黄金线")1)
(vla-put-linetype(vla-item (vla-get-layers *doc*)"HJX-黄金线")"Continuous")
(prompt "\n请选择对象: ")
(if (setq ss (ssget '((0 . "CIR*,ELL*,*LINE,INSERT,HATCH"))))
(repeat (setq i (sslength ss))
(setq ent (ssname ss (setq i (1- i)))
obj (vlax-ename->vla-object ent)
)
(vla-getboundingbox (vlax-ename->vla-object ent) 'p1 'p9)
(setq a (mapcar 'vlax-safearray->list (list p1 p9))
p1 (car a)
p9 (cadr a)
yy (+ (cadr p1) (* (- (cadr p9) (cadr p1)) 0.618))
xx (+ (car p1) (* (- (car p9) (car p1)) 0.618))
)
(entmakex (list '(0 . "LINE")
'(8 . "HJX-黄金线")
(cons 10 (list (car p1) yy))
(cons 11 (list (car p9) yy))
)
)
(entmakex (list '(0 . "LINE")
'(8 . "HJX-黄金线")
(cons 10 (list xx (cadr p1)))
(cons 11 (list xx (cadr p9)))
)
)
)
)
(princ)
)

(defun c:tt () 
  (setq *doc* (vla-get-activedocument (vlax-get-acad-object))) 
  (vla-add (vla-get-layers *doc*) "HJX-黄金线") 
  (vla-put-color(vla-item (vla-get-layers *doc*)"HJX-黄金线")1) 
  (vla-put-linetype(vla-item (vla-get-layers *doc*)"HJX-黄金线")"Continuous") 
  (prompt "\n请选择对象: ") 
  (if (setq ss (ssget '((0 . "CIR*,ELL*,*LINE,INSERT,HATCH")))) 
    (repeat (setq i (sslength ss)) 
      (setq ent (ssname ss (setq i (1- i))) 
            obj (vlax-ename->vla-object ent) 
      ) 
      (vla-getboundingbox (vlax-ename->vla-object ent) 'p1 'p9) 
      (setq a  (mapcar 'vlax-safearray->list (list p1 p9)) 
            p1 (car a) 
            p9 (cadr a) 
            yy (+ (cadr p1) (* (- (cadr p9) (cadr p1)) 0.618)) 
            xx (+ (car p1) (* (- (car p9) (car p1)) 0.618)) 
      ) 
      (entmakex (list '(0 . "LINE") 
                      '(8 . "HJX-黄金线") 
                      (cons 10 (list (car p1) yy)) 
                      (cons 11 (list (car p9) yy)) 
                ) 
      ) 
      (entmakex (list '(0 . "LINE") 
                      '(8 . "HJX-黄金线") 
                      (cons 10 (list xx (cadr p1))) 
                      (cons 11 (list xx (cadr p9))) 
                ) 
      ) 
    ) 
  ) 
  (princ) 
)

月下闲人 · 发表于 2025-3-9 00:18:58

xyp1964 发表于 2025-3-8 16:35

简洁又强大

非常棒感谢院长赐教

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

[提问] 求助怎么快速生成矩形的黄金分割线？

本帖子中包含更多资源

本帖子中包含更多资源