设为首页收藏本站转
发帖领奖家园QQ群申请版主版主评价切换到宽版

 找回密码
 立即注册

QQ登录

只需一步，快速开始

扫一扫，访问微社区

晓东CAD家园-论坛»论坛 › ╃CAD编程开发 › A/VLISP › EXCEL插入图片问题，内有源码
返回列表 发新帖
查看: 283|回复: 2

[求助] EXCEL插入图片问题，内有源码

[复制链接]
a117034423

已领礼包: 201个

财富等级: 日进斗金
发表于 2022-8-8 21:09:00 | 显示全部楼层 |阅读模式
【广而告之】积分规则、D豆获取攻略       窝窝空间装扮攻略

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要 登录 才可以下载或查看，没有账号？立即注册

×
本帖最后由 a117034423 于 2022-8-8 21:12 编辑

  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. )

论坛内源码，我测试了好久了，求大神帮解决一下 让他顺畅运行吧，实在是找不到问题所在，里面所用到的ActiveX方法，全部找不到案例，小弟在此拜谢

论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复

使用道具 举报

qyming2000

已领礼包: 158个

财富等级: 日进斗金
发表于 2022-8-14 18:31:55 | 显示全部楼层
  1. (defun Excel:inspic (sht id path / h h1 l p pic picname sc shaperange w w1 xlrange)
  2.   (setq xlrange (vlax-get-property sht 'range id))
  3.   (setq        pic (vlax-invoke
  4.               (vlax-invoke sht 'pictures)
  5.               'insert
  6.               path
  7.             )
  8.   )
  9.   (setq picname (vlax-get-property pic 'name))
  10.   (setq w1 (vlax-get-property pic 'width))
  11.   (setq h1 (vlax-get-property pic 'height))
  12.   (setq l (vlax-variant-value (vlax-get-property xlrange 'left)))
  13.   (setq p (vlax-variant-value (vlax-get-property xlrange 'top)))
  14.   (setq w (vlax-variant-value (vlax-get-property xlrange 'width)))
  15.   (setq h (vlax-variant-value (vlax-get-property xlrange 'height)))
  16.   (vlax-put-property pic 'left l)
  17.   (vlax-put-property pic 'top p)
  18.   (setq        shaperange (vlax-get-property
  19.                      (vlax-get-property sht 'shapes)
  20.                      'range
  21.                      picname
  22.                    )
  23.   )
  24.   (if (>= (/ w h) (/ w1 h1))
  25.     (progn
  26.       (setq sc (/ (- w (* (/ w1 h1) h)) 2))
  27.       (vlax-put-property shaperange 'height h)
  28.       (vlax-invoke shaperange 'incrementleft sc)
  29.     )
  30.     (progn
  31.       (setq sc (/ (- h (* (/ h1 w1) w)) 2))
  32.       (vlax-put-property shaperange 'width w)
  33.       (vlax-invoke shaperange 'incrementtop sc)
  34.     )
  35.   )
  36.   (princ)
  37. )
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

libo20000
发表于 2023-6-24 02:29:40 | 显示全部楼层
【广而告之】积分规则、D豆获取攻略       窝窝空间装扮攻略
本帖最后由 libo20000 于 2023-6-24 03:07 编辑
qyming2000 发表于 2022-8-14 18:31
如何把path改为读取剪贴板的内容,怎么处理？
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )

GMT+8, 2024-4-30 17:25 , Processed in 0.424803 second(s), 32 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

快速回复 返回顶部 返回列表