excel插入图片-无法正常运行

晴空O_o

1. (defun excel-inspic (xlapp  sh-n   ID    path
   
2.              xlapprelease   LST    /
   
3.              H  H1   L    Mergerange
   
4.              P  Pic   Picname  sc
   
5.              ShapeRange   W    W1
   
6.              xlrange  xlsheet
   
7.             )
   
8.           ;插入图片
   
9.           ;xlapp excel对象
   
10.           ;sh-n sheet表名
    
11.           ;id 单元格
    
12.           ;path 图片路径
    
13.           ;xlapprelease 程序结束后是否需要释放excel?
    
14.           ;lst 预留参数
    
15.   (setq  xlsheet sh-n);(vlax-get-property (vlax-get-property (vlax-get-property xlapp 'activeworkbook) 'Sheets) 'Item sh-n))
    
16.   (setq  Pic (vlax-invoke-method (vlax-invoke-method xlsheet 'Pictures) 'Insert path))
    
17.   (setq  Picname (vlax-get-property Pic 'Name))
    
18.   (setq  W1 (vlax-get-property Pic 'Width))
    
19.   (setq  H1 (vlax-get-property Pic 'Height))
    
20.   (setq  xlrange (vlax-get-property (vlax-get (vlax-get-property xlapp "ActiveWorkbook") 'ActiveSheet) 'range id))
    
21.   (setq  L (vlax-variant-value (vlax-get-property xlrange 'Left)))
    
22.   (SETQ  P (vlax-variant-value (vlax-get-property xlrange 'Top)))
    
23.   (SETQ  W (vlax-variant-value (vlax-get-property xlrange 'Width)))
    
24.   (SETQ  H (vlax-variant-value (vlax-get-property xlrange 'Height)))
    
25.   (vlax-put-property Pic 'Left L)
    
26.   (vlax-put-property Pic 'Top P)
    
27.   (setq  ShapeRange (vlax-get-property (vlax-get-property xlsheet 'Shapes) 'Range Picname))
    
28.   (vlax-put-property ShapeRange 'LockAspectRatio)
    
29.   (if (AND W
    
30.      (NOT (VL-CATCH-ALL-ERROR-P W))
    
31.      W1
    
32.      (NOT (VL-CATCH-ALL-ERROR-P W1))
    
33.      H1
    
34.      (NOT (VL-CATCH-ALL-ERROR-P H1))
    
35.      H
    
36.      (NOT (VL-CATCH-ALL-ERROR-P H))
    
37.       )
    
38.     (if  (>= (/ W H) (/ W1 H1))
    
39.       (progn
    
40.   (SETQ SC (/ (- W (* (/ W1 H1) H)) 2))
    
41.   (vlax-put-property ShapeRange 'Height H)
    
42.   (vlax-invoke-method ShapeRange 'IncrementLeft SC)
    
43.       )
    
44.       (progn
    
45.   (SETQ SC (/ (- H (* (/ H1 W1) W)) 2))
    
46.   (vlax-put-property ShapeRange 'Width W)
    
47.   (vlax-invoke-method ShapeRange 'IncrementTop SC)
    
48.       )
    
49.     )
    
50.   (vlax-put-property Pic 'Placement (vlax-make-variant 1 2))
    
51.   )
    
52.   (princ)
    
53. )

(defun excel-inspic (xlapp  sh-n   ID    path<br />              xlapprelease   LST    /<br />              H  H1   L    Mergerange<br />              P  Pic   Picname  sc<br />              ShapeRange   W    W1<br />              xlrange  xlsheet<br />             )<br />           ;插入图片<br />           ;xlapp excel对象<br />           ;sh-n sheet表名<br />           ;id 单元格<br />           ;path 图片路径<br />           ;xlapprelease 程序结束后是否需要释放excel?<br />           ;lst 预留参数<br />   (setq  xlsheet sh-n);(vlax-get-property (vlax-get-property (vlax-get-property xlapp 'activeworkbook) 'Sheets) 'Item sh-n))<br />   (setq  Pic (vlax-invoke-method (vlax-invoke-method xlsheet 'Pictures) 'Insert path))<br />   (setq  Picname (vlax-get-property Pic 'Name))<br />   (setq  W1 (vlax-get-property Pic 'Width))<br />   (setq  H1 (vlax-get-property Pic 'Height))<br />   (setq  xlrange (vlax-get-property (vlax-get (vlax-get-property xlapp "ActiveWorkbook") 'ActiveSheet) 'range id))<br />   (setq  L (vlax-variant-value (vlax-get-property xlrange 'Left)))<br />   (SETQ  P (vlax-variant-value (vlax-get-property xlrange 'Top)))<br />   (SETQ  W (vlax-variant-value (vlax-get-property xlrange 'Width)))<br />   (SETQ  H (vlax-variant-value (vlax-get-property xlrange 'Height)))<br />   (vlax-put-property Pic 'Left L)<br />   (vlax-put-property Pic 'Top P)<br />   (setq  ShapeRange (vlax-get-property (vlax-get-property xlsheet 'Shapes) 'Range Picname))<br />   (vlax-put-property ShapeRange 'LockAspectRatio)<br />   (if (AND W<br />      (NOT (VL-CATCH-ALL-ERROR-P W))<br />      W1<br />      (NOT (VL-CATCH-ALL-ERROR-P W1))<br />      H1<br />      (NOT (VL-CATCH-ALL-ERROR-P H1))<br />      H<br />      (NOT (VL-CATCH-ALL-ERROR-P H))<br />       )<br />     (if  (>= (/ W H) (/ W1 H1))<br />       (progn<br />   (SETQ SC (/ (- W (* (/ W1 H1) H)) 2))<br />   (vlax-put-property ShapeRange 'Height H)<br />   (vlax-invoke-method ShapeRange 'IncrementLeft SC)<br />       )<br />       (progn<br />   (SETQ SC (/ (- H (* (/ H1 W1) W)) 2))<br />   (vlax-put-property ShapeRange 'Width W)<br />   (vlax-invoke-method ShapeRange 'IncrementTop SC)<br />       )<br />     )<br />   (vlax-put-property Pic 'Placement (vlax-make-variant 1 2))<br />   )<br />   (princ)<br /> )

代码是在论坛找的 ，相关ActiveX方法实在是找不到说明 帮助文件里没有，求大神答疑解惑

自贡黄明儒

可以在excel录制宏来参考

晴空O_o

自贡黄明儒 发表于 2022-8-8 21:55
可以在excel录制宏来参考

谢了 黄总 真不容易啊

晴空O_o

自贡黄明儒 发表于 2022-8-8 21:55
可以在excel录制宏来参考

黄总 能再详细指导一下嘛 有点抓瞎

渠辉

(setq xlrange (vlax-get-property
                 (setq xlsheet (vlax-get (vlax-get-property xlapp "activeworkbook")
                                         'activesheet
                               )
                 )
                 'range
                 "C40"
               )
)
(setq pic (vlax-invoke
            (vlax-invoke xlsheet 'pictures)
            'insert
            "d:\\122.bmp"
          )
)

渠辉

1. ;; (excel-inspic (vlax-get xlapp 'activesheet)  "A1" "D:\\122.bmp")
   
2. (defun excel-inspic (sht id path / h h1        l p pic        picname        sc shaperange w        w1 xlrang)
   
3.   (setq xlrange (vlax-get-property sht 'range id))
   
4.   (setq        pic (vlax-invoke
   
5.               (vlax-invoke sht 'pictures)
   
6.               'insert
   
7.               path
   
8.             )
   
9.   )
   
10.   (setq picname (vlax-get-property pic 'name))
    
11.   (setq w1 (vlax-get-property pic 'width))
    
12.   (setq h1 (vlax-get-property pic 'height))
    
13. 
    
14.   (setq l (vlax-variant-value (vlax-get-property xlrange 'left)))
    
15.   (setq p (vlax-variant-value (vlax-get-property xlrange 'top)))
    
16.   (setq w (vlax-variant-value (vlax-get-property xlrange 'width)))
    
17.   (setq h (vlax-variant-value (vlax-get-property xlrange 'height)))
    
18.   (vlax-put-property pic 'left l)
    
19.   (vlax-put-property pic 'top p)
    
20.   (setq        shaperange (vlax-get-property
    
21.                      (vlax-get-property sht 'shapes)
    
22.                      'range
    
23.                      picname
    
24.                    )
    
25.   )
    
26. 
    
27.   (if (>= (/ w h) (/ w1 h1))
    
28.     (progn
    
29.       (setq sc (/ (- w (* (/ w1 h1) h)) 2))
    
30.       (vlax-put-property shaperange 'height h)
    
31.       (vlax-invoke shaperange 'incrementleft sc)
    
32.     )
    
33.     (progn
    
34.       (setq sc (/ (- h (* (/ h1 w1) w)) 2))
    
35.       (vlax-put-property shaperange 'width w)
    
36.       (vlax-invoke shaperange 'incrementtop sc)
    
37.     )
    
38.   )
    
39.   (princ)
    
40. )

;; (excel-inspic (vlax-get xlapp 'activesheet)  "A1" "D:\\122.bmp")<br /> (defun excel-inspic (sht id path / h h1        l p pic        picname        sc shaperange w        w1 xlrang)<br />   (setq xlrange (vlax-get-property sht 'range id))<br />   (setq        pic (vlax-invoke<br />               (vlax-invoke sht 'pictures)<br />               'insert<br />               path<br />             )<br />   )<br />   (setq picname (vlax-get-property pic 'name))<br />   (setq w1 (vlax-get-property pic 'width))<br />   (setq h1 (vlax-get-property pic 'height))<br /> <br />   (setq l (vlax-variant-value (vlax-get-property xlrange 'left)))<br />   (setq p (vlax-variant-value (vlax-get-property xlrange 'top)))<br />   (setq w (vlax-variant-value (vlax-get-property xlrange 'width)))<br />   (setq h (vlax-variant-value (vlax-get-property xlrange 'height)))<br />   (vlax-put-property pic 'left l)<br />   (vlax-put-property pic 'top p)<br />   (setq        shaperange (vlax-get-property<br />                      (vlax-get-property sht 'shapes)<br />                      'range<br />                      picname<br />                    )<br />   )<br /> <br />   (if (>= (/ w h) (/ w1 h1))<br />     (progn<br />       (setq sc (/ (- w (* (/ w1 h1) h)) 2))<br />       (vlax-put-property shaperange 'height h)<br />       (vlax-invoke shaperange 'incrementleft sc)<br />     )<br />     (progn<br />       (setq sc (/ (- h (* (/ h1 w1) w)) 2))<br />       (vlax-put-property shaperange 'width w)<br />       (vlax-invoke shaperange 'incrementtop sc)<br />     )<br />   )<br />   (princ)<br /> )

libo2000

path如何修改为插入剪贴板内的图像?

libo2000

Excel插入图片后，是链接类型的图片，一旦删除图片就没法显示了。如何插入时直接粘贴到excel内，而不是链接？