Связка Autocad и Excel (Страница 1 из 2)

;;; demo.lsp
; -- Function emake-pline
; minimum to entmake closed lwpolyline.
; Arguments [Type]:
;   pts = 2d point list [list]
; Return nil
;
(defun emake-pline (pts)
    (entmake
      (append (list (cons 0  "LWPOLYLINE")
        (cons 100  "AcDbEntity")
        (cons 100  "AcDbPolyline")
        (cons 90 (length pts))
        (cons 70  129))
              (mapcar '(lambda (pt)
            (cons 10 pt)) pts)
      )
    )
  )
;
; -- Function MeFormatNums
; Formats the precision of decimal numbers.
; Copyright:
;   ©2001-2005 MENZI ENGINEERING GmbH
; Arguments [Type]:
;   Val = Value [REAL/STR]
;   Pre = Precision [INT]
; Return [Type]:
;   > Formatted value [STR]
; Notes:
;   None
;
(defun MeFormatNums (Val Pre / CurStr DecVal PntPos)
 (setq CurStr (if (= (type Val) 'REAL) (rtos Val 2 Pre) Val)
       PntPos (vl-string-position 46 CurStr)
       PntPos (if (> PntPos 0) PntPos (strlen CurStr))
       DecVal (substr CurStr (+ PntPos 2))
 )
 (repeat (- Pre (strlen DecVal))
  (setq DecVal (strcat DecVal "0"))
 )
 (strcat (substr CurStr 1 PntPos) "." DecVal)
)
; -- Function MeGetExcelVer
; Returns the most recent installed Excel version.
; Copyright:
;   ©2001-2005 MENZI ENGINEERING GmbH
; Arguments [Type]:
;   --- = 
; Return [Type]:
;   > Excel version [STR]
;   > "0" if no valid Excel version installed.
; Notes:
;   - Check for Excel version 8 to 20
;
(defun MeGetExcelVer ( / AppKey MaxVer MinVer RegVal RetVal TmpVal)
 (setq AppKey "HKEY_LOCAL_MACHINE\\Software\\Microsoft\\Office\\"
       MinVer 8.0
       MaxVer 20.0
       RetVal "0"
 )
 (while (>= MaxVer MinVer)
  (setq TmpVal (strcat AppKey (MeFormatNums MaxVer 1) "\\Common\\InstallRoot")
        RegVal (if (> MaxVer 8.0)
                (vl-registry-read TmpVal "Path")
                (vl-registry-read TmpVal "OfficeBin")
               )
        RegVal (if (and RegVal (eq (substr RegVal (strlen RegVal)) "\\"))
                (substr RegVal 1 (1- (strlen RegVal)))
                RegVal
               )
  )
  (if (and RegVal (findfile (strcat RegVal "\\Excel.exe")))
   (setq RetVal (rtos MaxVer 2 0)
         MaxVer 0
   )
   (setq MaxVer (1- MaxVer))
  )
 )
 RetVal
)

; -- Function EXD
; return range value as list.
; Copyright:
;   ©2007 fixo * all rights removed
; Arguments [Type]:
;   r1 = first cell address [STR]
;   c1 = last cell address [STR]
; Return [Type]:
;   > Formatted value [list]
; Notes:
;   None
;
(defun EXD (r1 c1 / data excelapp retVal path Sht sheet_name_or_number data_range workbook)
  
  (vl-load-com)
    (setq path (getfiled    "Select Excel file to read :"
            (getvar "dwgprefix")
            "xlsx;xls;csv"
            16
          )
  )
  (setq sheet_name_or_number 1) 
  (setq ExcelApp (vlax-get-or-create-object (strcat "Excel.Application." (MeGetExcelVer))))
  (vla-put-visible ExcelApp :vlax-true)
  (setq Workbook (vl-catch-all-apply 'vla-open
             (list (vlax-get-property ExcelApp "WorkBooks") path)))
         (setq Sht (vl-catch-all-apply 'vlax-get-property
                   (list (vlax-get-property Workbook "Sheets")
                     "Item" sheet_name_or_number)))
      (vlax-invoke-method Sht "Activate")
          (setq data_range (vlax-get-property ExcelApp 'Range
                 (vlax-make-variant r1) (vlax-make-variant c1))
                retVal (vlax-safearray->list (vlax-variant-value
                        (vlax-get-property data_range 'Value))))
(setq data (mapcar (function (lambda (x)(mapcar 'vlax-variant-value x))) retVal))

      (vl-catch-all-apply
    'vlax-invoke-method
    (list Workbook "Close")
      )


    (vl-catch-all-apply
      'vlax-invoke-method
      (list ExcelApp "Quit")
    )



  (mapcar
    (function (lambda (x)
        (if (not (vlax-object-released-p x))
        
          (vlax-release-object x)
        )
          )
    )
    (list data_range Sht WorkBook ExcelApp)
  )
  (setq    data_range nil
    Sht nil
    WorkBook nil
    ExcelApp nil
  )
  (gc)
  (gc)
  
  data
)
; -- Function EXD
; return range value as list.
; Copyright:
;   ©2007 fixo * all rights removed
; Arguments [Type]:
;   r1 = first cell address [STR]
;   c1 = last cell address [STR]
; Return [Type]:
;   > Formatted value [list]
; Notes:
;   None
;
(defun EXR ( / data excelapp retVal path Sht sheet_name_or_number data_range workbook)
  
  (vl-load-com)
    (setq path (getfiled    "Select Excel file to read :"
            (getvar "dwgprefix")
            "xlsx;xls;csv"
            16
          )
  )
  (setq sheet_name_or_number 1) 
  (setq ExcelApp (vlax-get-or-create-object (strcat "Excel.Application." (MeGetExcelVer))))
  (vla-put-visible ExcelApp :vlax-true)
  (setq Workbook (vl-catch-all-apply 'vla-open
             (list (vlax-get-property ExcelApp "WorkBooks") path)))
         (setq Sht (vl-catch-all-apply 'vlax-get-property
                   (list (vlax-get-property Workbook "Sheets")
                     "Item" sheet_name_or_number)))
      (vlax-invoke-method Sht "Activate")
          (setq data_range (vlax-get-property Sht 'UsedRange)
;;;                 (vlax-make-variant r1) (vlax-make-variant c1))
                retVal (vlax-safearray->list (vlax-variant-value
                        (vlax-get-property data_range 'Value))))
(setq data (mapcar (function (lambda (x)(mapcar 'vlax-variant-value x))) retVal))

      (vl-catch-all-apply
    'vlax-invoke-method
    (list Workbook "Close")
      )


    (vl-catch-all-apply
      'vlax-invoke-method
      (list ExcelApp "Quit")
    )



  (mapcar
    (function (lambda (x)
        (if (not (vlax-object-released-p x))
        
          (vlax-release-object x)
        )
          )
    )
    (list data_range Sht WorkBook ExcelApp)
  )
  (setq    data_range nil
    Sht nil
    WorkBook nil
    ExcelApp nil
  )
  (gc)
  (gc)

  data
)
;; Тест:
;;------------------------------------------------;;
(defun C:demo (/ data pt1 pt2 x y)
  ;; 1-й вариант по точкам
(setq data (exd "B3" "C6"))

(emake-pline data)
  ;; 2-й вариант по размерам
 (setq data (exd "F3" "F4"))
  (setq x (caar data)
    y (caadr data)
    )
  (setvar "osmode" 1)
  (setq    pt1 (getpoint "\nУкажи точку: ")
    pt1 (list (car pt1) (cadr pt1))
    pt2 (list (+ (car pt1) x) (+ (cadr pt1)y))
  )
  (command "_rectang" "_W" 0.0 ^C
  "_rectang" "_non" pt1 "_non" pt2)
  
  (princ)
)
(princ  "\n\t\t---\tКоманда на выполнение: DEMO\t---")
(prin1)
(or (vl-load-com)
    (princ))

;opory.lsp
;
; -- Function emake-pline
; minimum to entmake closed lwpolyline.
; Arguments [Type]:
;   pts = 2d point list [list]
; Return nil
;
(defun emake-pline (pts)
    (entmake
      (append (list (cons 0  "LWPOLYLINE")
        (cons 100  "AcDbEntity")
        (cons 100  "AcDbPolyline")
        (cons 90 (length pts))
        (cons 70  129))
              (mapcar '(lambda (pt)
            (cons 10 pt)) pts)
      )
    )
  )

;
; -- Function MeFormatNums
; Formats the precision of decimal numbers.
; Copyright:
;   ©2001-2005 MENZI ENGINEERING GmbH
; Arguments [Type]:
;   Val = Value [REAL/STR]
;   Pre = Precision [INT]
; Return [Type]:
;   > Formatted value [STR]
; Notes:
;   None
;
(defun MeFormatNums (Val Pre / CurStr DecVal PntPos)
 (setq CurStr (if (= (type Val) 'REAL) (rtos Val 2 Pre) Val)
       PntPos (vl-string-position 46 CurStr)
       PntPos (if (> PntPos 0) PntPos (strlen CurStr))
       DecVal (substr CurStr (+ PntPos 2))
 )
 (repeat (- Pre (strlen DecVal))
  (setq DecVal (strcat DecVal "0"))
 )
 (strcat (substr CurStr 1 PntPos) "." DecVal)
)
;
; -- Function MeGetExcelVer
; Returns the most recent installed Excel version.
; Copyright:
;   ©2001-2005 MENZI ENGINEERING GmbH
; Arguments [Type]:
;   --- = 
; Return [Type]:
;   > Excel version [STR]
;   > "0" if no valid Excel version installed.
; Notes:
;   - Check for Excel version 8 to 20
;
(defun MeGetExcelVer ( / AppKey MaxVer MinVer RegVal RetVal TmpVal)
 (setq AppKey "HKEY_LOCAL_MACHINE\\Software\\Microsoft\\Office\\"
       MinVer 8.0
       MaxVer 20.0
       RetVal "0"
 )
 (while (>= MaxVer MinVer)
  (setq TmpVal (strcat AppKey (MeFormatNums MaxVer 1) "\\Common\\InstallRoot")
        RegVal (if (> MaxVer 8.0)
                (vl-registry-read TmpVal "Path")
                (vl-registry-read TmpVal "OfficeBin")
               )
        RegVal (if (and RegVal (eq (substr RegVal (strlen RegVal)) "\\"))
                (substr RegVal 1 (1- (strlen RegVal)))
                RegVal
               )
  )
  (if (and RegVal (findfile (strcat RegVal "\\Excel.exe")))
   (setq RetVal (rtos MaxVer 2 0)
         MaxVer 0
   )
   (setq MaxVer (1- MaxVer))
  )
 )
 RetVal
)

;
(defun ru-text-entmake (txt pnt height rotation justification / ent_list)
  ;;;ShaggyDoc
  ;;;https://www.caduser.ru/forum/topic30276.html
  (setq   ent_list (list   '(0 . "TEXT")
      '(100 . "AcDbEntity")
      '(100 . "AcDbText")
      (list 10 (car pnt) (cadr pnt) 0.0)
      (cons 1 txt)
      (cons 40 height)
      (cons 7 (getvar "textstyle"))
      (if justification
        (cond
          ((= justification "C")
           '(72 . 1)
          )
          ((= justification "R")
           '(72 . 2)
          )
          ((= justification "A")
           '(72 . 3)
          )
          ((= justification "M")
           '(72 . 4)
          )
          ((= justification "F")
           '(72 . 5)
          )
          (t
           '(72 . 0)
          )
        ) ;_ end of cond
        '(72 . 0)
      ) ;_ end of if
      (cons 50 rotation)
      (list 11 (car pnt) (cadr pnt) 0.0)
     ) ;_ end of list
   ) ;_ end of setq
   (entmakex ent_list)
)

;
; -- Function EXS
; Read selection and return its value as a list.
; Copyright:
;   ©2007 fixo * all rights removed
; Arguments [None]:
; Return [Type]:
;   > Formatted value [list]
; Notes:
;   None
;
(defun EXS (/ data excelapp retVal path data_range workbook)
  
  (vl-load-com)
    (setq path (getfiled    "Select Excel file to read :"
            (getvar "dwgprefix")
            "xls;xlsx;xlsm"
            16
          )
  )

  (setq ExcelApp (vlax-get-or-create-object (strcat "Excel.Application." (MeGetExcelVer))))
  (vla-put-visible ExcelApp :vlax-true)
  (setq Workbook (vl-catch-all-apply 'vla-open
             (list (vlax-get-property ExcelApp "WorkBooks") path)))

          (setq data_range (vlax-get-property ExcelApp 'Selection)

                retVal (vlax-safearray->list (vlax-variant-value
                        (vlax-get-property data_range 'Value))))
(setq data (mapcar (function (lambda (x)(mapcar 'vlax-variant-value x))) retVal))

      (vl-catch-all-apply
    'vlax-invoke-method
    (list Workbook "Close")
      )


    (vl-catch-all-apply
      'vlax-invoke-method
      (list ExcelApp "Quit")
    )



  (mapcar
    (function (lambda (x)
        (if (not (vlax-object-released-p x))
        
          (vlax-release-object x)
        )
          )
    )
    (list data_range  WorkBook ExcelApp)
  )
  (setq    data_range nil
    WorkBook nil
    ExcelApp nil
  )
  (gc)
  (gc)
  
  data
)
;
;; Тест:
;
;;---------------------------------------------------------------------------;;
(defun C:YO (/ data dlinatr levels n nameop nord numop p sumdlina texts ugolop ugoltr vysota west x)
(alert (strcat "Перед запуском этой программы:\n"
           "Окрыть файл Эксель,\n"
           "Выделить номера нужных строк,\n"
           "Сохранить файл Эксель и закрыть"))
(setq data (exs))
  ;;
(setq data (mapcar '(lambda(x)(vl-remove-if 'not x)) data))

  (setq levels (list 1.0 6.0 11.0 17.0));   --- расстояние по высоте между текстами
  ;;Построчно все столбцы:
  (foreach record data
    (setq numop (car record)
      nameop (nth 1 record)
      ugolop (nth 2 record)
      nord (nth 3 record)
      west (nth 4 record)
      vysota (nth 5 record)
      ugoltr (nth 6 record)
      dlinatr (nth 7 record)
      sumdlina (nth 8 record)
;; ---   здесь добавь что надо плюс вычисления и тд   ---  ;;
)
    
    ;; для примера рисуем текст столбцом
    (setq texts (list numop sumdlina dlinatr vysota));   --- выбранные текстовые данные
    (setq p (getpoint "\Указать точку : "))
    (setq n 0)
    (foreach yd levels
      
    (ru-text-entmake (nth n texts)(list (car p) (+ (cadr p)yd) 0.0) 2.0 0.0 nil)
      (setq n (1+ n))
    )
    )


  (princ)
)
(princ  "\n\t\t---\tКоманда на выполнение: YO\t---")
(prin1)
(or (vl-load-com)
    (princ))

;; SKV.lsp
(defun GetXlRangeByMatch(filename sheetname skv_id / all_skvs xlbook xlrange xlsheet xlapp skv_records)
  
  (vl-load-com)

  
    (setq xlapp(vlax-get-or-create-object "Excel.Application"))
    (vla-put-visible xlapp :vlax-false)
    (vlax-put-property xlapp 'DisplayAlerts :vlax-false)
  (if (zerop (vlax-get-property(vlax-get-property xlapp 'workbooks) 'count))
     (setq xlbook (vl-catch-all-apply
        'vla-open
        (list (vlax-get-property xlapp 'WorkBooks) fileName)
        )
      )
  (setq xlbook (vl-catch-all-apply 'vlax-get-property (list xlapp 'activeworkbook))))


(setq xlsheet (vl-catch-all-apply
        'vlax-get-property
        (list (vlax-get-property xlbook 'Sheets)
          'Item
          1 ;|"список"|;;< --- sheet name or number
          )
        )
      )
  
    (vlax-invoke-method xlsheet 'Activate)
  
 (setq xlrange (vlax-get-property xlsheet 'usedrange))
 (setq all_skvs (vlax-get-property xlrange 'value2))
 (setq all_skvs(mapcar '(lambda(x)(mapcar 'vlax-variant-value x)) (vlax-safearray->list (vlax-variant-value all_skvs))))
 (setq skv_records (vl-remove-if-not '(lambda (x)(eq skv_id (car x)))all_skvs))

   (vl-catch-all-apply 'vlax-invoke-method (list xlbook 'Close :vlax-false))
  (vlax-put-property xlapp 'DisplayAlerts :vlax-true)
  (gc);; before QUIT
    (vl-catch-all-apply 'vlax-invoke-method (list xlapp 'Quit))
  (mapcar '(lambda(x)(if (and x (not (vlax-object-released-p x)))
               (progn(vlax-release-object x)(setq x nil))))
      (list xlrange xlsheet xlbook xlapp))
  
  (gc);; after QUIT

      skv_records
  )


(defun C:SKV(/ filename mydata sheetname)

           (setq filename
              ;; change full path name if not working: 
              (findfile "сводная.xls") ;_ end of findfile
           ) ;_ end of setq
           (setq sheetname "список");|1|;
          (setq skv_id "С-1")
  (setq mydata (GetXlRangeByMatch filename sheetname skv_id))
  
  (print mydata)

(princ)
  )
(prompt
  "\n\t\t---\tType SKV for the quick test \t---")
(prin1)
(or (vl-load-com)(princ))