针对PCCD的《批量打印程序》v5.3源码

langjs

w245272914 发表于 2018-1-11 11:04
langjs大师：
我是你的粉丝
关注你的程序太久了，基本每出一个， ...

没明白你是想要实现什么功能

w245272914

langjs 发表于 2018-1-11 23:58
没明白你是想要实现什么功能

langjs大师：
附件的程序已经打印PDF如图片一样了，只差最后一步保存。
每次打完图纸到如图片一样，我都要点保存PDF，可以用什么函数实现自动保存到该文件目录吗？

w245272914

langjs 发表于 2018-1-11 23:58
没明白你是想要实现什么功能

我放上源码，免费乱码。我们公司是繁体的

;;需建立打印每幅圖範圍多段線圖框及編號，並且令其處同一圖層
;;主程序
(defun c:sxdy ( / cmd doc e2 el2 i i2 itm lst lst1 lst2 msg n os p1 p3 sgel ss1 ss2 tc xy)
    (defun *error* (msg)
    (setvar "cmdecho" cmd) ;_ 恢复cmdecho系統變量
    (setvar "osmode" os) ;_ 恢复osmode系統變量
    (princ "error: ")
    (princ msg) ;_ 打印錯誤信息
    (princ)
  )
  (setq cmd (getvar "cmdecho")) ;_ 保存系統變量cmdecho值
  (setq os (getvar "osmode"))
  (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-StartUndoMark doc)
  (setvar "osmode" 0)
  (setq tc (assoc 8 (entget (car (entsel "\n 請選任選一打印序號==>> ")))))
  (command "-layer" "p" "n" (cdr tc) "")
  (print "\n 請選擇需要打印的範圍的圖框==>>")
  ;同時獲取圖框選擇集ss1 文字選擇集ss2
  (setq ss1 nil ss2 nil)
  (if (setq ss1 (ssget (list (cons 0 "TEXT,LWPOLYLINE") tc)))
    (foreach itm (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss1)))
      (if (= (cdr (assoc 0 (entget itm))) "TEXT")
        (progn
          (or ss2 (setq ss2 (ssadd)))
          (ssadd itm ss2)
          (ssdel itm ss1)
        )
      )
    )
  )
(setq i2 0)
(setq lst2 nil)
(repeat (sslength ss2)
  (setq e2 (ssname ss2 i2))
  (setq el2 (entget e2))
  (setq lst2 (append lst2 (list (list (read (cdr (assoc 1 el2))) (assoc 10 el2)))))
  (setq i2 (1+ i2))
  )
  (setq lst2 (sort lst2))     ;;已經按圖框內數字1,2,3,4進行排序的表lst2 ((序號1 (10 三維點)) (序?2 (10 三號)))
  (setq lst2 (vl lst2))       ;;去掉lst2中的序號，重組序號表 lst2
  (lstlw ss1)                 ;; 得到圖框角點坐標表lst1         
  (setq n 0)
  (setq lst nil)
  (repeat (length lst2)
    (setq sgel (nth n lst2))   ;;獲取單個序號坐座標
    (setq lst (append lst  (pp sgel lst1)))  ;;得到對應圖框坐標表
    (setq n (1+ n))
    )
  (setq i 0)
  (repeat (length lst)
    (setq xy (nth i lst))
    (setq p1 (car xy))
    (setq p3 (cadr (cdr xy)))
                ;由p1和p3坐標判斷是縱向還是橫向
        (if (> (cadr p1) (cadr p3)) (setq p4 p1
                                            p1 (list (car p1) (cadr p3) 0)
                                            p3 (list (car p3) (cadr p4) 0)))
        (setq x1 (car p1) y1 (cadr p1) x2 (car p3) y2 (cadr p3))
        (setq x (abs (- x1 x2)) y (abs (- y1 y2)) )
        (if (> y x) (setq st "p") (setq st "l"))
    (command "zoom" "w" p1 p3)
    (command "-plot" "y"         ; 是否需要詳細打印配置
       "模型"           ; 輸入布局、模型名稱
       "pdfFactory Pro"         ; 輸入輸出設備的名稱  此處舉例虛擬打印机 pdfFactory Pro
                                       ; (lisp語言中的一個 \ 符號需要用 \\符號表示，即\=>\\)
                                 ; 例如：共享打印机 \\Adminstractor\Kyocera KM-2560 KX應該表示為\\\\Adminstractor\\Kyocera KM-2560 KX
       "A4"          ; 輸入圖紙尺寸A4
       "m"           ; 輸入圖紙單位(I:英寸 M:毫米)
       st          ; 輸入圖形方向(縱向:P 橫向  )
       "n"           ; 是否反向打印
       "w"           ; 輸入打印區域(顯示:D范圍:E圖形界限 視圖:V 窗口:W)
       p1                   ; 打印圖框左下角點坐標
       p3                   ; 打印圖框右上角點坐標
       "f"           ; 輸入打印比例(F:布滿)
       "c"           ; 輸入打印偏移(居中打印:C)
       "y"           ; 是否按樣式打印
       "monochrome.ctb"           ; 輸入打印樣式名稱
       "y"           ; 是否打印線寬
       "a"           ; 輸入著色打印設置置(按顯示:A  線框:W
                     ; 消隱:H 渲染:R)
       "n"           ; 是否打印到文件
       "n"           ; 是否保存頁面設置的修改
       "y"           ; 是否繼續打印
    )
    (setq i (+ i 1))
  )
    (setvar "cmdecho" cmd) ;_ 恢复cmdecho系統變量
  (setvar "osmode" os)   ;_ 恢复osmode系統變量
  (vla-EndUndoMark doc)
  (vlax-release-object doc)
  (princ)
)

;獲取圖框集合多段點表總表
(defun lstlw (ss)
  (setq i1 0)
  (setq lst1 nil)
  (repeat (sslength ss)
    (setq e1 (ssname ss i1))
    (setq el1 (LWPL e1))
    (setq lst1 (append lst1 (list el1)))
    (setq i1 (1+ i1))
  )
)
;獲取多段線點表函數
(defun LWPL (x /)
  (vl-remove-if
    'not
    (mapcar
      '(lambda (x)
   (if (= (car x) 10)
     (append (cdr x) '(0))
   )
       )
      (entget x)
    )
  )
)

;;?((1 (10 1117.07 581.131 0.0)) (2 (10 1693.6 596.47 0.0)))中的序號1 2去掉
(defun  vl (lst)
   (mapcar '(lambda (x)
        (cdr (car (cdr x)))
      )
     lst
   )
)

;;提取出對應單個圖框的坐標表
(defun pp (pt lst)
  (vl-remove-if
    'not
    (mapcar
      '(lambda (x)
   (if (= T (isPtinPM pt x))
     x
   )
       )
      lst
    )
  )
)
;;根据文字內容進行表排序
(defun sort (LST / REC)
  (defun REC (A B)
    ;;遞歸
    (cond ((equal (car A) (car B) 1E-4)
     (REC (cdr A) (cdr B))
    )
    (T (< (car A) (car B)))
    )
  )
  (vl-sort LST '(lambda (P1 P2) (REC P1 P2)))
)
;;eg(1 (10 1117.07 581.131 0.0)) (2 (10 1693.6 596.47 0.0)) (3 (10 2284.33 603.215 0.0)))
;;;******************************************************************************
;;; No.51  判斷點是否在多邊形內(狂刀程序)                                       
;;;xPt是要判斷的點坐標(x y z ), Points是多邊形頂點列表((x1 y1 z1) (x2 y2 z2)...)
;;;******************************************************************************
(defun isPtinPM  (xPt Points)
  (equal
    PI
    (abs
      (apply
  '+
  (mapcar  '(lambda (x y) (rem (- (angle xPt x) (angle xPt y)) PI))
    (reverse (cdr (reverse (cons (last Points) Points))))
    Points
  )
      )
    )
    1e-6
  )          ;end_equal
)          ;end_defun

w245272914

langjs 发表于 2018-1-11 23:58
没明白你是想要实现什么功能

  大师，在不在呀。555
求帮忙修改下的

xiewu

虽然是好程序 但总是出错
还请大师  看下这个错误
命令: Prin 未知命令“PRIN”。按 F1 查看帮助。
谢谢

panliang9

没钱，先标记一个！后面搞点明经币再下

ssyfeng

支持楼主，看看好不好用

ssyfeng

怎么没看到代码的

wslb

来学习的~
感谢分享

韩非文

好东西，要学习