Lisp向excel指定单元格插入图片

admin1

Lisp向excel指定单元格插入图片



(defun $excel-cha-ru-tu-pian$ (xlapp    sh-n     ID      path
                   xlapprelease?     LST      /
                   H    H1     L      Mergerange
                   P    Pic     Picname  sc
                   ShapeRange     W      W1
                   xlrange    xlsheet
                  )
                    ;插入图片
                    ;xlapp excel对象
                    ;sh-n sheet表名
                    ;id 单元格
                    ;path 图片路径
                    ;xlapprelease? 程序结束后是否需要释放excel?
                    ;lst 预留参数
  (OR ID (setq id "A1"))
  (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    Pic
     (vl-catch-all-apply
       'vlax-invoke-method
       (list
         (vl-catch-all-apply
           'vlax-invoke-method
           (list xlsheet 'Pictures)
         )
         'Insert
         path
       )
     )
  )
  (setq    Picname
     (vl-catch-all-apply
       'vlax-get-property
       (list Pic 'Name)
     )
  )
  (setq W1 (vl-catch-all-apply 'vlax-get-property (list Pic 'Width)))
  (setq H1 (vl-catch-all-apply 'vlax-get-property (list Pic 'Height)))
  (setq    xlrange
     (vl-catch-all-apply
       'vlax-get-property
       (list
         (vl-catch-all-apply
           'vlax-get
           (list (vl-catch-all-apply
               'vlax-get-property
               (list xlapp "ActiveWorkbook")
             )
             'ActiveSheet
           )
         )
         'range
         id
       )
     )
  )
  (setq
    L (vl-catch-all-apply
    'vlax-variant-value
    (LIST
      (vl-catch-all-apply 'vlax-get-property (LIST xlrange 'Left))
    )
      )
  )
  (SETQ
    P (vl-catch-all-apply
    'vlax-variant-value
    (LIST
      (vl-catch-all-apply 'vlax-get-property (LIST xlrange 'Top))
    )
      )
  )
  (SETQ    W (vl-catch-all-apply
        'vlax-variant-value
        (LIST (vl-catch-all-apply
            'vlax-get-property
            (LIST xlrange 'Width)
          )
        )
      )
  )
  (SETQ    H (vl-catch-all-apply
        'vlax-variant-value
        (LIST (vl-catch-all-apply
            'vlax-get-property
            (LIST xlrange 'Height)
          )
        )
      )
  )
  (vl-catch-all-apply 'vlax-put-property (LIST Pic 'Left L))
  (vl-catch-all-apply 'vlax-put-property (LIST Pic 'Top P))
  (setq    ShapeRange
     (vl-catch-all-apply
       'vlax-get-property
       (LIST
         (vl-catch-all-apply
           'vlax-get-property
           (LIST xlsheet 'Shapes)
         )
         'Range
         Picname
       )
     )
  )
  (vl-catch-all-apply
    'vlax-put-property
    (LIST
      ShapeRange
      'LockAspectRatio
      :vlax-true
    )
  )
  (if (AND W
       (NOT (VL-CATCH-ALL-ERROR-P W))
       W1
       (NOT (VL-CATCH-ALL-ERROR-P W1))
       H1
       (NOT (VL-CATCH-ALL-ERROR-P H1))
       H
       (NOT (VL-CATCH-ALL-ERROR-P H))
      )
    (if    (>= (/ W H) (/ W1 H1))
      (progn
    (SETQ SC (/ (- W (* (/ W1 H1) H)) 2))
    (vl-catch-all-apply
      'vlax-put-property
      (LIST ShapeRange 'Height H)
    )
    (vl-catch-all-apply
      'vlax-invoke-method
      (LIST ShapeRange 'IncrementLeft SC)
    )
      )
      (progn
    (SETQ SC (/ (- H (* (/ H1 W1) W)) 2))
    (vl-catch-all-apply
      'vlax-put-property
      (LIST ShapeRange 'Width W)
    )
    (vl-catch-all-apply
      'vlax-invoke-method
      (list ShapeRange 'IncrementTop SC)
    )
      )
    )
  )
  (vl-catch-all-apply
    'vlax-put-property
    (LIST Pic
      'Placement
      (vl-catch-all-apply 'vlax-make-variant (LIST 1 2))
    )
  )
  (if xlapprelease?            ;释放吗？
    (progn (vl-catch-all-apply 'vlax-release-object (list xlapp))
       (setq xlapp nil)
    )
  )
  (princ)
)