Lisp向excel单元格插入批注

admin1

Lisp向excel单元格插入批注



(defun $excel-dan-yuan-ge-pi-zhu$ (xlapp sh-n address-str-h lst / $set-font-size$ xlsheet zt)
                    ;Excel单元格插入批注
                    ;xlapp excel对象
                    ;sh-n 表的名字
                    ;address-str-h  三个值：单元格地址、字串、文字大小
                    ;lst 预留参数
                    ;($excel-dan-yuan-ge-pi-zhu$  xlapp  "Sheet2"(list(list "A1" "中线CAD:\n这个列不能删除，删除后将会带来灾乱性后果")(list "B2" "秦始皇：\n您好呀，我是批注"))nil)
  (defun $set-font-size$ (range h)
    (vl-catch-all-apply
      'vlax-put-property
      (list
    (vl-catch-all-apply
      'vlax-get-property
      (list
        (vl-catch-all-apply
          'vlax-invoke-method
          (list
        (vl-catch-all-apply
          'vlax-get-property
          (list
            (vl-catch-all-apply
              'vlax-get-property
              (list
            (vl-catch-all-apply
              'vlax-get-property
              (list range 'Comment)
            )
            'Shape
              )
            )
            'TextFrame
          )
        )
        'Characters
          )
        )
        'font
      )
    )
    'size
    h                ;文字高度
      )
    )
  )
  (or xlapp (setq xlapp ($xlapp-New$ NIL nil nil)))
  (setq    xlsheet
     (vl-catch-all-apply
       'vlax-get-property
       (list (vl-catch-all-apply
           'vlax-get-property
           (list (vl-catch-all-apply
               'vlax-get-property
               (list xlapp 'activeworkbook)
             )
             'Sheets
           )
         )
         'Item
         sh-n
       )
     )
  )                    ;工作表对象
  (setq    zt (mapcar (function (lambda (a / address str h range zt)
                   (setq address (car a))
                   (setq str (cadr a))
                   (setq h (caddr a))
                   (or h (setq h 8))
                   (if str
                 (progn
                   (SETQ
                     range (vl-catch-all-apply
                         'msxlp-get-range
                         (list xlsheet address)
                       )
                   )    ;单元格对象
                   (vl-catch-all-apply
                     'vlax-invoke-method
                     (list range 'ClearComments)
                   )    ;删除历史批注  
                   (setq zt (vl-catch-all-apply
                          'vlax-invoke-method
                          (list
                        range
                        'AddComment.Text
                        str
                          )
                        )
                   )    ;添加批注
                   ($set-font-size$ range h)
                 )
                   )
                   zt
                 )
           )
           address-str-h
       )
  )
  zt
)