谁能找一个(或写一个)仿天正GBBL命令滴代码谢谢

flytoday

如下图:
只针对标注值..及相关文本有效就好哈...谢谢...

print1985

CTC 发表于 2012-5-12 11:23
我刚开始操作时,标注的全局比例是9倍的...出图比例放大再缩小等后,文字好像回不到我原来操作的样子了 ...

试试这个吧 分开命令的

flytoday

找到半个差不多的..要修改



(defun c:tt ()
  (vl-load-com)
  (setq en (car (entsel "\n选择一个尺寸标注:")))
  (setq obj (vlax-Ename->Vla-Object en))
  (setq old (vla-get-scalefactor obj))
  (if (setq new        (getreal (strcat "\n当前尺寸标注的比例系数为:<"
                                 (rtos old)
                                 ">,请输入新的比例系数:"
                         )
                )
      )
    (progn
      (setq ss (ssget '((0 . "DIMENSION,LEADER"))))
      (setq k 0)
      (repeat (sslength ss)
        (setq obj (vlax-Ename->Vla-Object (ssname ss k)))
        (setq h (vla-get-textheight obj ))
        (vla-put-textheight obj (* h 3.0));;3.0可以修改的
        (vla-put-scalefactor obj new)
        (setq k (1+ k))
      )
    )
  )
  (princ)
)

chpmould

论坛会有的，继续找

CTC

看来还是天正好用

print1985

“只针对标注值..及相关文本” 是天正的标注和天正文字吗，还是cad标注和cad文字？

flytoday

又找到半个哈.....
(defun c:mysc (/ sc ss i en ent pts pt s1)
  ;;出错处理函数
  (defun ss-errexit (msg)
    (command)
    (command)
    (if (or (= msg "Function cancelled")
     (= msg "quit / exit abort")
)
      (princ msg)
      (princ (strcat "\n错误: " msg))
    )
    (clos)
  )
  (svos)
  (setq sc (getreal "\n请输入缩放比例<1.0>:"))
  (if (null sc)
    (setq sc 1.0)
  )
  (setq ss (ssget))
  (setq i -1)
  (setvar "OSMODE" 0)
  (while (setq en (ssname ss (setq i (1+ i))))
    (setq pt (ss-getencen en NIL))
    (ss-en-scale en pt sc)
  )
  (clos)
)
(princ "\n高山流水图元中心缩放程序，命令mysc")
(princ)
;;;获取图元的视图中心
(defun ss-getencen (en onseg / Wmat Umat obj minPt maxPt)
  (if (and onseg (= (getvar "WORLDUCS") 0))
    (setq Wmat (gc:TMatrixFromTo 1 0)
   Umat (gc:TMatrixFromTo 0 1)
    )
  )
  (if en
    (progn
      (setq obj (vlax-ename->vla-object en))
      (if Wmat
(vla-TransformBy obj (vlax-tmatrix Wmat))
      )
      (vla-GetBoundingBox obj 'minpt 'maxpt)
      (setq minPt (vlax-safearray->list minPt))
      (setq maxPt (vlax-safearray->list maxPt))
      (if Umat
(vla-TransformBy obj (vlax-tmatrix Umat))
      )
      (midpt minpt maxpt)
    )
  )
)
;;;gile
(defun gc:TMatrixFromTo (from to)
  (append
    (mapcar
      (function
(lambda (v o)
   (append (trans v from to T) (list o))
)
      )
      (list '(1. 0. 0.) '(0. 1. 0.) '(0. 0. 1.))
      (trans '(0. 0. 0.) to from)
    )
    (list '(0. 0. 0. 1.))
  )
)
;;;图元基点缩放
(defun ss-en-scale (en pt sc / s1)
  (setq s1 (ssadd)
s1 (ssadd en s1)
  )
  (vl-cmdf "_.SCALE" s1 "" pt sc)
)
;;;保存原来的设定
(defun svos ()
;;;记录初始变量
  (setq gsls_oldosm    (getvar "OSMODE") ;捕捉设定
gsls_oldoth    (getvar "ORTHOMODE") ;正交设定
gsls_oldlye    (getvar "CLAYER") ;当前层
gsls_oldclr    (getvar "CECOLOR") ;当前颜色
gsls_plnwid    (getvar "PLINEWID") ;线宽设定
gsls_oldltp    (getvar "CELTYPE") ;保存当前线形
gsls_cmdecho   (getvar "CMDECHO") ;命令形式
gsls_elev      (getvar "ELEVATION")
gsls_pickstyle (getvar "PICKSTYLE")
gsls_olderr    *error*
*error*        ss-errexit
  )
  (vla-startundomark
    (vla-get-activedocument (vlax-get-acad-object))
  )
)
;;;恢复原来的设定
(defun clos ()
  (vla-EndUndoMark
    (vla-get-ActiveDocument (vlax-get-acad-object))
  )
  (setvar "OSMODE" gsls_oldosm)
  (setvar "ORTHOMODE" gsls_oldoth)
  (setvar "CLAYER" gsls_oldlye)
  (setvar "CECOLOR" gsls_oldclr)
  (setvar "CELTYPE" gsls_oldltp)
  (setvar "ELEVATION" gsls_elev)
  (setvar "CMDECHO" gsls_cmdecho)
  (setvar "PLINEWID" gsls_plnwid)
  (setvar "PICKSTYLE" gsls_pickstyle)
  (setq *error* gsls_olderr)
  (prin1)
)
;;;求两点中点
(defun midpt (pta ptb)
  (mapcar (function (lambda (x y)
        (/ (+ x y) 2.0)
      )
   )
   pta
   ptb
  )
)

print1985

试试 没啥技术含量 将就可以用
cad文字没有比例 是通过改字高实现

CTC

print1985 发表于 2012-5-12 01:42
试试 没啥技术含量 将就可以用
cad文字没有比例 是通过改字高实现

?????????????

print1985

你咋是乱码 那几个字应该是“请输入新的出图比例”