设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 【越飞越高讲堂1】ActiveX 和脚本技术在CAD的运用
12345678910... 12下一页
返回列表 发新帖
查看: 45375|回复: 115

[【高飞鸟】] 【越飞越高讲堂1】ActiveX 和脚本技术在CAD的运用

    [复制链接]
highflybir
发表于 2011-1-10 19:22 | 显示全部楼层 |阅读模式
本帖最后由 highflybir 于 2013-8-6 20:27 编辑

越飞越高讲堂（1）ActiveX 和脚本技术在CAD的运用
首先申明，这篇帖子不建议初学者浏览。一则我不能一一回答不明白者的提问，二则避免初学者钻牛角尖。因此有很多地方并不给出完整的代码。此贴及其附件中不含主命令。其中有些C:开头的命令可以运行，有些则不可以。
=========================================
2013.05.17更新
如果对帖子中的代码有疑问或者可能的抄录笔误，请下载下面附件：

=========================================
脚本有很多用处，在CAD中如果能灵活运用，也可以为图纸之外的事情发挥较大作用。譬如近来有很多帖子问及系统中有多少
个磁盘，设备系列号，屏幕分辨率，等等。如果知道了这方面的知识，完全是可以几行代码就解决问题的。
关于脚本的更多请搜索。
AutoCAD作为一种具有高度开放结构的CAD平台软件，它提供了强大的二次开发环境。从AutoCAD R14版开始，AutoCAD引入了ActiveX Automation技术。由于ActiveX技术是一种完全面向对象的技术，所以许多面向对象化编程的语言和应用程序，可以
通过ActiveX与AutoCAD进行通信，并操纵AutoCAD的许多功能。
AutoCAD ActiveX技术提供了一种机制，该机制可使编程者通过编程手段从AutoCAD的内部或外部来操纵AutoCAD。ActiveX是
由一系列的对象，按一定的层次组成的一种对象结构，每一个对象代表了AutoCAD中一个明确的功能，如绘制图形对象、定义
块和属性等等。ActiveX所具备的绝大多数AutoCAD功能，均以方法和属性的方式被封装在ActiveX对象中，只要使用某种方式
，使ActiveX对象得以“暴露”，那么就可以使用各种面向对象编程的语言对其中的方法、属性进行引用，从而达到对
AutoCAD实现编程的目的。
这两者我不再详细描述。
CAD中执行ActiveX函数的方法有两种，
一种用vlax-import-type-library函数引入，
另外一种用vlax-invoke,和vlax-get（或者vlax-invoke-methode,和vlax-get-property）;
后一种比前一种更广，但前一种 它的优势在于 可以写更少的代码，更智能化，能利用Vlisp编辑器的自动完成功能获得更多
的用法。但对于有的不能用vlax-import-type-library。
本帖大多数用的是前者。
首先用了一个函数，为后面的程序做准备。
;;;获得系统工作路径
  1. (defun GetSpecialPath (n / fso path)
  2.   (setq fso  (vlax-create-object "Scripting.FileSystemObject"))
  3.   (setq path (vlax-get (vlax-invoke fso 'GetSpecialFolder n) 'path))
  4.   (vlax-release-object fso)
  5.   path
  6. )

脚本技术中有几个很重要的东西: WScipt.Shell对象，FileSystemObject对象，Shell.Application对象，WMI，以及
ScriptControl对象。这几个对象我不再介绍了。

脚本宿主对象
  1. setq path (strcat (GetSpecialPath 1) "/wshom.ocx")) ;;
  2. (if (not wc-Alias)
  3.   (vlax-import-type-library
  4.     :tlb-filename   path
  5.     :methods-prefix   "wm-"
  6.     :properties-prefix  "wp-"
  7.     :constants-prefix  "wc-"
  8.   )
  9. )
  10. (setq wsh (vlax-create-object "WScript.shell"))

脚本本身
  1. (setq path (strcat (GetSpecialPath 1) "/msscript.ocx"))
  2. (if (not sc-Connected)
  3.   (vlax-import-type-library
  4.     :tlb-filename   path
  5.     :methods-prefix   "sm-"
  6.     :properties-prefix  "sp-"
  7.     :constants-prefix  "sc-"
  8.   )
  9. )
  10. (setq scr (vlax-create-object "ScriptControl"))

文件系统对象
  1. (setq path (strcat (getSpecialPath 1) "/scrrun.dll"))
  2. (if (not fc-Alias)
  3.   (vlax-import-type-library
  4.     :tlb-filename   path
  5.     :methods-prefix   "fm-"
  6.     :properties-prefix  "fp-"
  7.     :constants-prefix  "fc-"
  8.   )
  9. )
  10. (setq fso (vlax-create-object "Scripting.FileSystemObject"))

Shell对象
  1. (setq path (strcat (getSpecialPath 1) "/shell32.dll"))
  2. (if (not ac-ssfwindows)
  3.   (vlax-import-type-library
  4.     :tlb-filename  path
  5.     :methods-prefix "am-"
  6.     :properties-prefix "ap-"
  7.     :constants-prefix "ac-"
  8.   )
  9. )
  10. (setq sha (vlax-create-object "shell.application"))

下面我一一介绍它们的用法。

WSH对象，ScriptControl对象和WMI

  ;;简单的欢迎
  
  1. (wm-Popup wsh "Hello,World!")
  

  ;;输入框
  (vlax-invoke scr 'ExecuteStatement "str=InputBox(\"输入您的名字:\", \"输入框\")")
  (sm-ExecuteStatement scr "str=InputBox(\"输入您的名字:\", \"输入框\")")

  ;;求值
  (vlax-invoke scr 'eval "str")
  (sm-eval scr "str")

  ;;发送一个命令
  (wm-sendkeys wsh "C{ENTER}0,0{ENTER}100{ENTER}")   ;在CAD命令状态下画一个圆
  (WM-SENDKEYS wsh "赌")                    ;很神奇的，居然是打开我的电脑
  (WM-SENDKEYS wsh "品")    ;打开计算器
  (WM-SENDKEYS wsh "血")    ;打开搜索
  (WM-SENDKEYS wsh "恋")     ;打开媒体播放器
  (WM-SENDKEYS wsh "爽")     ;打开主页

  ;;创建一个URL的快捷方式
  (setq Spec (wp-get-SpecialFolders wsh))
  (setq deskTopPath (wm-item spec "DeskTop"))
  (setq url (wm-CreateShortcut wsh (strcat deskTopPath "/MyTest.URL")))
  (wp-put-TargetPath url http://bbs.mjtd.com)
  (wm-save url)

  ;;创建一个快捷方式并指定快捷键
  (setq link (wm-CreateShortcut wsh (strcat DeskTopPath "/测试快捷方式.lnk")))
  (wp-put-TargetPath link http://bbs.mjtd.com)
  (wp-put-WindowStyle link 1)
  (wp-put-Hotkey link "Ctrl+Alt+e")
  (wp-put-IconLocation link "shell32.dll,14")
  (wp-put-Description link "测试快捷方式的描述")
  (wp-put-WorkingDirectory link "c:/")
  (wm-save link)

  ;;运行命令
  (wm-run wsh "cmd.exe /C dir c:\\temp\\*.* /a /s >>c:\\1.txt")

  ;;获得系统环境变量
  (Setq env (wp-get-Environment wsh "System"))

  ;;系统目录
  (alert (wp-get-item env "WINDIR"))
  (alert (wm-ExpandEnvironmentStrings wsh "%windir%"))
  (alert (wp-get-Item env "TMP"))
  (alert (wp-get-Item env "TEMP"))

  ;;增加和移除环境变量
  (alert "Add a test var to the system!")
  (wp-put-item env "TestVar" "Windows Script Host")
  (alert "Remove the test var from the system!")
  (wm-remove env "TestVar")

  ;;列出某个环境变量的全部
  (setq i 0)
  (repeat (wm-count env)
    (princ (wp-get-item env i))    ;但是不会显现出来在vbs中运行正常
    (setq i (1+ i))
  )

  ;;以下相同
   (setq str
  "Set WshShell = CreateObject(\"WScript.Shell\")
  Msgbox \"Environment.item: \"& WshShell.Environment.item(\"WINDIR\")
  Msgbox \"ExpandEnvironmentStrings: \"& WshShell.ExpandEnvironmentStrings(\"%windir%\")
  set oEnv=WshShell.Environment(\"System\")
  
  Msgbox \"Adding ( TestVar=Windows Script Host ) to the System type environment\"
         oEnv(\"TestVar\") = \"Windows Script Host\"
         Msgbox \"removing ( TestVar=Windows Script Host ) from the System type environment\"
         oEnv.Remove \"TestVar\"
  for each sitem in oEnv
  strval=strval & sItem & vbcrlf
  next
  Msgbox \"System Environment:\" & vbcrlf & vbcrlf & strval
  strval=\"\"'
  
  set oEnv=WshShell.Environment(\"Process\")
  for each sitem in oEnv
  strval=strval & sItem & vbcrlf
  next
  Msgbox \"Process Environment:\" & vbcrlf & vbcrlf & strval
  strval=\"\"
  set oEnv=WshShell.Environment(\"User\")
  for each sitem in oEnv
  strval=strval & sItem & vbcrlf
  next
  Msgbox \"User Environment:\" & vbcrlf & vbcrlf & strval
  strval=\"\"
  set oEnv=WshShell.Environment(\"Volatile\")
  for each sitem in oEnv
  strval=strval & sItem & vbcrlf
  next
  Msgbox \"Volatile Environment:\" & vbcrlf & vbcrlf & strval
  strval=\"\"
  set oEnv = nothing
  set WshShell = nothing
  "
  )
  (vlax-invoke Scr 'ExecuteStatement str)

;;读写注册表 regread ,regwrite,regdelete
(vlax-invoke wsh 'RegRead "HKCU\\Software\\AutoDesk\\AutoCAD\\R16.2\\curver")  ;确保你装的是autocad 2006否则出错

;;系统信息篇
  ;;（如获取机器的物理地址）
  (setq str "Set mc=GetObject(\"Winmgmts:\")")
  (SM-EXECUTESTATEMENT scr str)
  (setq objWMI (vla-eval scr "mc"))
  (setq objNet (vlax-invoke objWMI 'InstancesOF "Win32_NetworkAdapterConfiguration"))
  (princ "\n物理地址是:")
  (vlax-for obj objNet
    (if(/= (vlax-get obj 'IPEnabled) 0)
      (princ (vlax-get obj 'MacAddress))
    )
  )

;;也可以按照如下方式获得详细信息
  (foreach p (list
        "Win32_ComputerSystem"
        "Win32_Service"
        "Win32_LogicalMemoryConfiguration"
        "Win32_Process"
        "Win32_Processor"
        "Win32_OperatingSystem"
        "Win32_WMISetting"
        "__NAMESPACE"
        "win32_baseboard"
        "win32_videocontroller"
        "win32_DiskDrive"
        "win32_physicalMemory"
        "Win32_Environment"
        "Win32_ProcessStartTrace"
        "Win32_PnpDevice"
        "Win32_SoundDevice"
        "Win32_ProductCheck"
        "Win32_NetworkAdapter"
        "Win32_CDROMDrive"
        "Win32_DesktopMonitor"
        "Win32_NetworkAdapterConfiguration"
        ;;"Win32_NTLogEvent"  ;太多了
      )
    (setq objSYS (vlax-invoke objWMI 'InstancesOf p))
    (vlax-for n objSYS
      (alert (vlax-invoke n 'GetObjectText_))  
    )
  )

  ;;以下相同只不过只是收集简单的信息
  (setq WMI (vla-eval scr "mc"))

  ;;收集计算机用户信息
  (setq col (vlax-invoke WMI 'ExecQuery "Select * from Win32_ComputerSystem" "WQL" 48))
  (vlax-for n Col
    (princ "\n用户名是:")
    (princ (vlax-get n 'name))
  )

;;获取进程
  (setq col (vlax-invoke WMI 'ExecQuery "Select * from Win32_Process" "WQL" 48))
  (vlax-for n Col
    (princ (vlax-get n 'name))
  )

;;获取CPU信息
   (setq col (vlax-invoke WMI 'ExecQuery "Select * from Win32_Processor" "WQL" 48))
  (vlax-for n Col
    (princ (vlax-get n 'name))
  )

;;获取内存总容量
  (setq col (vlax-invoke WMI 'ExecQuery "Select * from Win32_ComputerSystem" "WQL" 48))
  (vlax-for n Col
    (princ (/ (read (vlax-get n 'TotalPhysicalMemory)) 1048576))
    (princ "M")
  )

;;获取内存外频和数量信息
  (setq col (vlax-invoke WMI 'ExecQuery "Select * from Win32_PhysicalMemory" "WQL" 48))
  (vlax-for n Col
    (princ "\n")
    (princ (vlax-get n 'Description))
    (princ "\n")
    (princ (vlax-get n 'DeviceLocator))
    (princ "\n")
    (princ (vlax-get n 'speed))
  )

;;获取显卡信息
  (setq col (vlax-invoke WMI 'ExecQuery "Select * from Win32_VideoController" "WQL" 48))
  (vlax-for n Col
    (princ "\n")
    (princ (vlax-get n 'Caption))
    (princ "\n")
    (princ (vlax-get n 'VideoModeDescription))
  )

;;获取硬盘基本信息
  (setq col (vlax-invoke WMI 'ExecQuery "Select * from Win32_DiskDrive" "WQL" 48))
  (vlax-for n Col
    (princ "\n硬盘的设备编号是:")
    (princ (vlax-get n 'Caption))
    (princ "\n这个硬盘的容量是:")
    (princ (/ (read (vlax-get n 'size)) 1073741824))
    (princ "G")
  )

;;获取声卡信息
  (setq col (vlax-invoke WMI 'ExecQuery "Select * from Win32_SoundDevice" "WQL" 48))
  (vlax-for n Col
    (princ "\n声卡的信息是:")
    (princ (vlax-get n 'ProductName))
  )

;;获取网卡信息
  (setq col (vlax-invoke WMI 'ExecQuery "Select * from Win32_NetworkAdapter" "WQL" 48))
  (vlax-for n Col
    (princ "\n网卡的设备描述是:")
    (princ (vlax-get n 'Description))
    (princ "\n网卡的信MAC地址是:")
    (princ (vlax-get n 'MACAddress))
  )

  
  ;;获取软驱信息
  (setq col (vlax-invoke WMI 'ExecQuery "Select * from Win32_FloppyDrive" "WQL" 48))
  (vlax-for n Col
    (princ "\n软驱的信息是:")
    (princ (vlax-get n 'Caption))
  )

;;获取CD/DVD ROM信息
  (setq col (vlax-invoke WMI 'ExecQuery "Select * from Win32_CDROMDrive" "WQL" 48))
  (vlax-for n Col
    (princ "\n光驱的信息是:")
    (princ (vlax-get n 'Name))
    (princ "\n光驱的信息是:")
    (princ (vlax-get n 'Description))   
  )

  
  ;;获取屏幕分辨率
  (setq CoL (vlax-invoke WMI 'ExecQuery "Select * from Win32_DesktopMonitor" "WQL" 48))
  (vlax-for n Col
    (princ "\n屏幕横向分辨率为:")
    (princ (vlax-get n 'ScreenWidth))
    (princ "\n屏幕竖向分辨率为:")
    (princ (vlax-get n 'ScreenHeight))
  )

小提醒：如果用vlax-Create-object方法创建了一个对象，别忘记用vlax-release-object释放它。





本帖子中包含更多资源

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

x

评分

参与人数 16威望 +3 明经币 +12 金钱 +361 收起 理由
南风枕流 + 1
434939575 + 1 很给力!
自贡黄明儒 + 1 神贴
mn1k + 20 精品文章
zark + 20 很深
jicqj + 20 很全面 很强大
skymudy + 6
lyy + 1 + 3 + 30 好文章
qjchen + 50 精品文章，高人高贴
露水2 + 25 有点提高

查看全部评分

"觉得好，就打赏"
打赏
共1人打赏

本帖被以下淘专辑推荐:

回复

使用道具 举报

highflybird
发表于 2011-7-27 21:09 | 显示全部楼层
本帖最后由 highflybird 于 2011-7-27 21:12 编辑

ADODB.Stream
展示如何打包二进制文件和读写二进制文件。

  2. (defun c:test ()
  3.   ;;Read a Binary  file
  4.   (defun ReadBinary (FileName / stream arr)
  5.     (setq stream (vlax-create-object "ADODB.Stream"))
  6.     (vlax-put stream 'type 1)       ;adTypeBinary
  7.     (vlax-invoke stream 'open)      ;adModeRead  =1 adModeWrite  =2 adModeReadWrite =3
  8.     (vlax-invoke stream 'LoadFromFile filename)
  9.     (setq Arr (vlax-invoke-method stream 'read (vlax-get stream 'SIZE)));read stream
  10.     (vlax-invoke stream 'close)
  11.     (vlax-release-object stream)
  12.     (vlax-safearray->list (vlax-variant-value arr))   ;if a large size file ,it will take a long time in this step
  13.   )
  14.   ;;Write to a Binary  file from a text stream
  15.   (defun WriteBinary (FileName Array / stream)
  16.     (setq stream (vlax-create-object "ADODB.Stream"))
  17.     (vlax-put stream 'type 1)       ;adTypeBinary
  18.     (vlax-invoke stream 'open)      ;adModeRead  =1 adModeWrite  =2 adModeReadWrite =3
  19.     (vlax-invoke-method stream 'Write array)    ;write stream
  20.     (vlax-invoke stream 'saveToFile fileName 2)    ;save
  21.     (vlax-invoke stream 'close)
  22.     (vlax-release-object stream)
  23.   )

  25.   (setq path (getfiled "Please select a binary file:" "c:/" "" 8 ))     ;get file path
  26.   (setq f (open "C:\\test.txt" "W"))
  27.   (setq data (readBinary path))
  28.   (princ data f)
  29.   (close F)
  30.   ;;(setq stream (vl-get-resource "test"))                              ;we can wrap this text file into .vlx file
  31.   (setq f (open "C:\\test.txt" "R"))                                    ;open for read
  32.   (setq l "")
  33.   (while (setq s (read-line f))
  34.     (setq l (strcat l s))
  35.   )
  36.   (setq array (read l))
  37.   (close f)
  38.   
  39.   (setq dat (vlax-make-safearray 17 (cons 0 (1- (length array)))))      ;17 for unsigned char
  40.   (vlax-safearray-fill dat array)
  41.   (setq bin (vlax-make-variant dat))
  42.   (writeBinary "C:\\test.jpg" bin)     ;write binary file.
  43. )


回复 支持 2 反对 0

使用道具 举报

highflybir
 楼主| 发表于 2011-1-10 19:32 | 显示全部楼层
本帖最后由 highflybir 于 2011-1-11 20:49 编辑

回复 highflybir 的帖子

Shell.Application篇

;;;windows shell
  1.   (setq path (strcat (getSpecialPath 1) "/shell32.dll"))
  2.   (if (not ac-ssfwindows)
  3.     (vlax-import-type-library
  4.       :tlb-filename  path
  5.       :methods-prefix "am-"
  6.       :properties-prefix "ap-"
  7.       :constants-prefix "ac-"
  8.     )
  9.   )
  10.   (setq shapp (vlax-create-object "shell.application"))

以下种种用法：
  1. (am-CascadeWindows shapp)   

;层叠窗口
  1. (am-ControlPanelItem shapp "inetcpl.cpl" )  
           
;打开控制面板(internet)
  1. (am-settime shapp)  
   
;打开时间和日期设置对话框
  1. (am-TrayProperties shapp)
   
;日期和时间 属性
  1.   (am-explore shapp "c:\\")  
                                 
;打开 C 盘
  1.   (am-FindComputer shapp)
   
;搜索计算机
  1. (am-findPrinter shapp "canno")   
                             
;搜索打印机
  1.   (am-GetSystemInformation shapp "ProcessorSpeed")
            
;处理器速度:运行windows 7 和vista
  1. (am-GetSystemInformation shapp "PhysicalMemoryInstalled")
     
;物理内存容量
  1. (am-GetSystemInformation shapp "IsOS_Professional")  
        
;是否是专业版
  1. (am-filerun shapp)  
                                          
;打开运行窗口
  1. (am-ShutdownWindows shapp)  
                                 
;关机对话框
  1. (am-findfiles shapp)  
                                       
;搜索文件
  1. (am-toggledesktop shapp)  
                                   
;显示桌面
  1. (am-IsServiceRunning shapp "Spooler")
  
;检测某项服务(打印机)是否在运行
  1. (am-WindowsSecurity shapp)
                                   
;Windows安全
  1. (am-AddToRecent shapp "c:\\1.txt")
   
;添加到最近打开文档
  1. (am-namespace shapp "c:\\")  
                                 
;返回所打开的Folder对象

;选择文件夹对话框
  1.   (am-BrowseForFolder shapp   
  2.     (vla-get-hwnd (vlax-get-acad-object) )
  3.     "Select a folder"
  4.     64
  5.   )     
     
  1. (am-BrowseForFolder shapp 0 "我的电脑" 16 17)  

;打开文件浏览对话框，并获得文件夹对象
  1. (am-open shapp "c:\\")     

;打开某个目录

;;获得图像的详细信息，包括分辨率等等
  
  1. (defun GetInfoOfPic(shapp path name / info root file i l)
  2.     (setq root (am-namespace shapp path))
  3.     (setq file (am-ParseName root name))
  4.     (setq i 0)
  5.     (repeat 256
  6.       (setq info (am-GetDetailsOf root file i))
  7.       (if (/= info "")
  8. (progn
  9.           (princ (strcat "\nIndex " (itoa i) ": " info))
  10.    (setq l (cons info l))
  11. )
  12.       )
  13.       (setq i (1+ i))
  14.     )
  15.     (reverse l)
  16.   )
  17.   (getInfoOfPic shapp "D:\\" "1.jpg")
  
;;下面是一个小小的程序，用来获得某个目录下的文件夹和文件名
  
  1. (defun BrowseFolder(shapp fp / root items count i item path name)
  2.     (setq root (am-namespace shapp fp))
  3.     (setq items (am-items root))
  4.     (setq count (ap-get-Count items))
  5.     (setq i 0)
  6.     (repeat count
  7.       (setq item (am-item items i))
  8.       (setq path (ap-get-path item))
  9.       (setq name (ap-get-name item))
  10.       (if (= (ap-get-IsFolder item) :vlax-true)   ;zip 也是folder??呵呵
  11. (progn
  12.    (princ (strcat "\n---Folder:" path))
  13.    (BrowseFolder shapp path)
  14. )
  15. (princ (strcat "\nFile name:" name))
  16.       )
  17.       (setq i (1+ i))
  18.     )
  19.   )
  20.   (BrowseFolder shapp "C:\\Program Files\\AutoCAD 2006")
  
;;创建一个新的文件夹(移动MoveHere，拷贝copyhere，等)
  1. (setq root (am-namespace shapp "d:\\"))
  2.   (am-NewFolder root "Test")
  3.   (setq file (am-ParseName root "1.jpg"))
  4.   (am-copyhere (am-namespace shapp "c:\\") file 16)
  5.   (am-movehere (am-namespace shapp "c:\\") file 0)
  
;;得到某些特殊文件夹
  1. (am-NameSpace shapp "shell:PrintersFolder")
  2.   (am-NameSpace shapp "shell:personal")
  3.   (am-NameSpace shapp "shell:drivefolder")
  4.   ;;(am-ShowBrowserBar shapp "{C4EE31F3-4768-11D2-BE5C-00A0C9A83DA1}" :vlax-true);;???
                              
;;执行跟一个文件或者文件夹相关联的
  1.   (am-doit (am-item (am-verbs (ap-get-self root)) 0))
  2.   (am-doit (am-item (am-verbs file) 0))
  
;;调出控制面版选项
  1.   (am-ShellExecute shapp "Explorer.exe" "::{20D04FE0-3AEA-1069-A2D8-08002B30309D}")  ;//打开我的电脑
  2.   (am-ShellExecute shapp "Rundll32.exe" "shell32.dll,Control_RunDLL sysdm.cpl,,2" )
  3.   (am-ShellExecute shapp "Rundll32.exe" "shell32.dll,Control_RunDLL netcpl.cpl,,1")
  4.   (am-ShellExecute shapp "Rundll32.exe" "shell32.dll,SHCreateLocalServerRunDll {601ac3dc-786a-4eb0-bf40-ee3521e70bfb}");
  5.   (am-ShellExecute shapp "Rundll32.exe" "shdocvw.dll,OpenURL")   ;//Internet 快捷方式 要IE8,IE7?
  6.   (am-ShellExecute shapp "Rundll32.exe" "msconf.dll,OpenConfLink")  ;//SpeedDial
  7.   (am-ShellExecute shapp "Rundll32.exe" "zipfldr.dll,RouteTheCall")  ;//压缩文件夹shdocvw.dll,OpenURL
  8.   (am-ShellExecute shapp "Rundll32.exe" "netplwiz.dll,UsersRunDll")  ;//用户帐户
  9.   (am-ShellExecute shapp "Rundll32.exe" "shell32.dll,Options_RunDLL 0")  ;//文件夹选项
  10.   (am-ShellExecute shapp "Rundll32.exe" "shell32.dll,Options_RunDLL 1")  ;//显示任务栏和开始菜单
  11.   (am-ShellExecute shapp "Rundll32.exe" "shell32.dll,Control_RunDLLAsUser")     ;//控制面版  
  
;;执行程序
  1.   (am-ShellExecute shapp "cmd.exe")
  2.   (setq root (am-namespace shapp "c:\\windows\\system32"))
  3.   (setq exec (am-parsename root "CMD.exe"))
  4.   (am-invokeverb exec)

;;收藏夹
  1.   (setq mark (vlax-create-object "Shell.UIHelper.1"))
  2.   (vlax-invoke mark 'AddChannel "http://www.mjtd.com/")
  3.   (vlax-invoke mark 'AddFavorite "http://www.mjtd.com" "MJTD")
  4.   (vlax-invoke mark 'AddDesktopComponent "d:\\1.jpg" "image")

;;下面用来获取某些特殊目录下的文件信息
  1.   (defun GetInfo(shapp folds / objs i obj name lst prop)
  2.     (setq objs (am-items (am-namespace shapp folds)))  ;这些常量可以智能查取
  3.     (setq i 0)
  4.     (repeat (ap-get-count objs)
  5.       (setq obj  (am-item objs i))
  6.       (setq name (ap-get-name obj))
  7.       (setq prop (am-ExtendedProperty obj "type"))
  8.       (setq lst  (cons (cons name prop) lst))
  9.       (setq i (1+ i))
  10.     )
  11.     (reverse lst)
  12.   )
  
;;例子
  
  1. (getInfo shapp ac-ssffonts)    ;获取系统中安装的字体
  2.   (getInfo shapp ac-ssfCONTROLS)    ;获取有哪些控制面板
  3.   (getInfo shapp ac-ssfMYPICTURES)             ;获取我的图片
  4.   (getInfo shapp ac-ssfDRIVES)                 ;获取系统的磁盘信息
  5.   (getInfo shapp ac-ssfnetwork)                ;网络
  6.   (getInfo shapp ac-ssfsystem)    ;系统文件夹信息
  7.   (getInfo shapp ac-ssfnetwork)               ;获得网上邻居
  8.   (getInfo shapp ac-ssfRecent)                ;获得最近打开
  9.   ;;下面用来获得你浏览器(Explore)打开的窗口
  10.   (defun GetWindows(shapp / i l lst obj winobj)
  11.     (vlax-invoke shapp 'windows)
  12.     (vlax-get (vlax-invoke shapp 'windows) 'count)
  13.     (setq winobj (vlax-invoke shapp 'windows))
  14.     (setq i 0)
  15.     (repeat (vlax-get winobj 'count)
  16.       (setq obj (vlax-invoke winobj 'item i))
  17.       (setq lst (list
  18.     (vlax-get obj 'toolbar)
  19.     (vlax-get obj 'StatusText)
  20.     (vlax-get obj 'FullName)
  21.     (vlax-get obj 'LocationURL)
  22.     (vlax-get obj 'Path)
  23.   )
  24.       )
  25.       (setq l (cons lst l))     
  26.       (setq i (1+ i))
  27.     )
  28.     (reverse l)
  29.   )
  30.   (GetWindows shapp)
  
;;清空指针
  1.   (vlax-release-object mark)
  2.   (vlax-release-object root)
  3.   (vlax-release-object file)
  4.   (vlax-release-object exec)
  5.   (vlax-release-object shapp)
  6.   (princ)


回复 支持 1 反对 0

使用道具 举报

zcsoft
发表于 2022-8-3 22:56 | 显示全部楼层
ActiveX技术功能真强大，学会此技术感觉写代码更轻松，但此技术得从简单的代码学起，一步步加深，不然消化不了。
回复 支持 反对

使用道具 举报

仲文玉
发表于 2011-1-10 19:33 | 显示全部楼层
支持，沙发来个
回复 支持 反对

使用道具 举报

highflybir
 楼主| 发表于 2011-1-10 19:35 | 显示全部楼层
本帖最后由 highflybir 于 2011-1-11 20:36 编辑

FSO对象
;;;filesystemObject
  1. (defun C:FSO(/ FSO PATH)
  2.   (setq path (strcat (getSpecialPath 1) "/scrrun.dll"))   scrrun.dll
  3.   (if (not fc-Alias)
  4.     (vlax-import-type-library
  5.       :tlb-filename                 path
  6.       :methods-prefix                 "fm-"
  7.       :properties-prefix         "fp-"
  8.       :constants-prefix         "fc-"
  9.     )
  10.   )
  11.   (setq fso (vlax-create-object "Scripting.FileSystemObject"))
  
  ;;显示目录下所有的目录
  1.   (defun showSubFolder (folder)
  2.     (vlax-for  subfolder  (fp-get-SubFolders folder)
  3.       (princ (strcat "\n" (fp-get-Path subfolder)))
  4.       (ShowSubFolder subFolder)
  5.     )
  6.   )
  ;;获取某个目录下所有的文件夹
  1.   (defun GetSubFolder (fso path / l)
  2.     (defun GetSubFolder1 (folder / p)
  3.       (vlax-for  subfolder (fp-get-SubFolders folder)
  4.         (setq p (fp-get-Path subfolder))
  5.         (setq l (cons p (GetSubFolder subFolder)))
  6.       )
  7.       l
  8.     )
  9.     (if (fm-folderExists fso path)
  10.       (reverse (getSunFolder1 (fm-getFolder fso path)))
  11.     )        
  12.   )

  14.   (showSubFolder (fm-GetFolder fso "C:\\Program Files"))
  15.   (getSubFolder (fm-GetFolder fso "C:\\Program Files"))
  
;;获取磁盘个数和详细情况
  1.   (defun GetNumOfDrives(fso / drives i)
  2.     (setq drives (vlax-get fso 'drives))
  3.     (setq i 0)
  4.     (vlax-for drive drives
  5.       (vlax-dump-object drive)
  6.       (setq i (1+ i))
  7.     )
  8.     (princ "\n共有磁盘个数:")
  9.     (princ i)
  10.     i
  11.   )
  12.   (GetNumOfDrives fso)

  ;;读取文本流
  1.   (defun ReadStream (path format / fso file str res size)
  2.     ;;path    the full name of a file
  3.     ;;iomode   1 ;; 1 = read, 2 = write, 8 = append
  4.     ;;format   0 ;; 0 = ascii, -1 = unicode, -2 = system default
  5.     (setq fso  (vlax-create-object "Scripting.FileSystemObject"))
  6.     (setq file (vlax-invoke fso  'getfile path))
  7.     (setq str  (vlax-invoke fso 'OpenTextFile path 1 format))
  8.     (setq size (vlax-get file 'Size))
  9.     (setq res  (vlax-invoke str 'read size))
  10.     (vlax-invoke str 'close)
  11.     (if str  (vlax-release-object str))
  12.     (if file (vlax-release-object file))
  13.     (if fso  (vlax-release-object fso))
  14.     res
  15.   )
  ;;写文本流
  1.   (defun WriteStrem (path text format / fso str file res)
  2.     (setq fso  (vlax-create-object "Scripting.FileSystemObject"))
  3.     (setq str  (vlax-invoke fso 'CreateTextFile path -1 format))
  4.     (setq file (vlax-invoke fso 'getFile path))
  5.     (vlax-invoke str 'Write text)
  6.     (vlax-invoke str 'close)
  7.     (setq res (vlax-get file 'size))
  8.     (if str  (vlax-release-object str))
  9.     (if file (vlax-release-object file))
  10.     (if fso  (vlax-release-object fso))
  11.     res
  12.   )
  13.   (writeStrem "C:\\test1.txt" (readStream "c:\\1.txt" -2) -2)

  15.   ;;RubbishCleaner
  16.   ;;详见我的帖子《CAD垃圾文件删除工具》
  17. )
回复 支持 反对

使用道具 举报

highflybir
 楼主| 发表于 2011-1-10 19:42 | 显示全部楼层
本帖最后由 highflybir 于 2011-1-11 20:33 编辑

接下来是其他的ActiveX 的用法

通用文件对话框对象
  1. ;;;通用文件对话框
  2. ;;;用来替代CAD的getfiled对话框，用以获得更多功能
  3. (defun c:FDLG(/ DLG PATH DLGOBJ FN FSOOBJ FT)
  4.   (setq path (strcat (GetSpecialPath 1) "/comdlg32.ocx"))
  5.   (if (not dc-cdlalloc)
  6.     (vlax-import-type-library
  7.       :tlb-filename  path
  8.       :methods-prefix  "dm-"
  9.       :properties-prefix "dp-"
  10.       :constants-prefix       "dc-"
  11.     )
  12.   )
  13.   (setq dlg (vlax-create-object "MSComDlg.CommonDialog"))  ;;UserAccounts.CommonDialog
  14.   (dp-put-MaxFileSize dlg 10000)
  15.   (dp-put-filter dlg "All Files (*.*)|*.*|Lisp Files(*.lsp)|*.lsp|DWG Files (*.dwg)|*.dwg");增加过滤类型
  16.   (dm-ShowOpen dlg)
  17.   (princ (strcat "\n你打开的文件是:\n" (dp-get-filename dlg)))

  19.   ;;另外一种方式
  20.   (setq path (strcat (GetSpecialPath 1) "/safrcdlg.dll"))  ;;safrcdlg.dll
  21.   (if (not Fdp-get-FileName)
  22.     (vlax-import-type-library
  23.       :tlb-filename  path
  24.       :methods-prefix  "Fdm-"
  25.       :properties-prefix "Fdp-"
  26.       :constants-prefix       "Fdc-"
  27.     )
  28.   )
  29.   ;;打开文件
  30.   (setq dlgobj (vlax-create-object "SAFRCFileDlg.FileOpen"))  ;;"SAFRCFileDlg.FileOpen"
  31.   (Fdp-put-FileName dlgobj "C:\\")
  32.   (Fdm-OpenFileOpenDlg dlgobj)
  33.   (princ "\n你打开的文件是:\n")
  34.   (princ (Fdp-get-FileName dlgobj))
  35.   (vlax-release-object dlgobj)
  36.   ;;保存文件
  37.   (setq dlgobj (vlax-create-object "SAFRCFileDlg.FileSave"))  ;;"SAFRCFileDlg.FileSave"
  38.   (setq FSOobj (vlax-create-object "Scripting.FileSystemObject"))
  39.   (Fdp-put-FileName dlgobj "test")
  40.   (Fdp-put-fileType dlgobj ".txt")
  41.   (if (Fdm-OpenFileSaveDlg dlgobj)
  42.     (progn
  43.       (setq FN (Fdp-get-FileName dlgobj))
  44.       (setq FT (Fdp-get-FileType dlgobj))
  45.       (princ (strcat "\n你要保存的文件是:\n" FN FT))
  46.       (vlax-invoke FSOobj 'CreateTextFile (strcat FN FT))
  47.     )
  48.   )
  49.   (vlax-release-object dlgobj)
  50.   (vlax-release-object FSOobj)
  51.   (princ)
  52. )
回复 支持 反对

使用道具 举报

highflybir
 楼主| 发表于 2011-1-10 19:44 | 显示全部楼层
本帖最后由 highflybir 于 2011-1-11 20:30 编辑

前段时间有人问到如何获取或者设置剪贴版，下面就是一个例子：
Form2.0对象
  1. ;;;利用form2.0设置和获取剪贴板
  2. (defun c:Form (/ BOX CTR FMO STR)
  3.   (setq path (strcat (GetSpecialPath 1) "/fm20.dll"))
  4.   (if (not FMc-fmActionCopy)
  5.     (vlax-import-type-library
  6.       :tlb-filename  path
  7.       :methods-prefix  "FMm-"
  8.       :properties-prefix "FMp-"
  9.       :constants-prefix       "FMc-"
  10.     )
  11.   )
  12.   ;;获取剪贴版数据
  13.   (setq fmo (vlax-create-object "Forms.form.1"))  ;Form
  14.   (setq ctr (FMP-GET-CONTROLs fmo))   ;控件
  15.   (setq box (fmm-add ctr "Forms.textbox.1"))   ;文本框
  16.   (Fmp-put-MultiLine box :vlax-true)
  17.   (if (= (FMp-get-CanPaste box) :vlax-true)   ;如能粘贴
  18.     (progn
  19.       (FMm-Paste box)     ;粘贴进去
  20.       (alert (fmp-get-text box))   ;显示文本
  21.     )
  22.   )
  23.   ;;设置剪贴版数据
  24.   (setq str "Hello,MJTD!\n我爱你，CAD!")
  25.   (Fmp-put-text box str)    ;设置剪贴板文本内容
  26.   (Fmp-put-SelStart box 0)
  27.   (Fmp-put-SelLength box (Fmp-get-textlength box))
  28.   (Fmm-copy box)     ;拷贝进去
  29.   ;;释放
  30.   (vlax-release-object box)
  31.   (vlax-release-object ctr)
  32.   (vlax-release-object fmo)
  33.   (princ)
  34. )

回复 支持 反对

使用道具 举报

highflybir
 楼主| 发表于 2011-1-10 19:50 | 显示全部楼层
本帖最后由 highflybir 于 2011-1-11 20:28 编辑

InternetExplorer.Application对象和word 对象

  1. ;;获得IE窗口大小
  2. (defun C:getscreenRes()
  3.   (setq IE (vlax-create-object "InternetExplorer.Application"))
  4.   (vlax-invoke IE 'navigate "about:blank")
  5.   (setq screen (vlax-get (vlax-get (vlax-get ie 'Document) 'parentWindow) 'screen))
  6.   (princ (vlax-get screen 'height))
  7.   (princ (vlax-get screen 'width))
  8.   (vlax-release-object IE)
  9. )
  10. ;;;访问剪贴板
  11. (defun C:GetPaste()
  12.   (setq IE (vlax-create-object "InternetExplorer.Application"))
  13.   (vlax-invoke IE 'navigate "about:blank")
  14.   (setq Clip (vlax-get (vlax-get (vlax-get ie 'Document) 'parentWindow) 'clipboardData))
  15.   (vlax-invoke clip 'setdata "text" "This is a test!")
  16.   (princ  (vlax-invoke clip 'GetData "text"))
  17.    (vlax-release-object IE)


  20.   ;;windows 7下用
  21.   (setq wsh (vlax-create-object "Wscript.Shell"))
  22.   (setq str "This is a test (by wscript.shll)")
  23.   (vlax-invoke wsh 'run
  24.     (strcat "CMD.exe /C echo " str " | clip")
  25.     0
  26.     :vlax-false
  27.   )
  28.   (vlax-release-object wsh)

  30.   ;;通过word设置剪贴板
  31.   (setq word (vlax-create-object "Word.Application"))
  32.   (setq doc (vlax-get word 'Documents))
  33.   (setq sel (vlax-get word 'Selection))
  34.   (vlax-invoke doc 'add)
  35.   (vlax-put sel 'text  "This is a test(by word)")
  36.   (vlax-invoke sel 'copy)
  37.   (vlax-invoke word 'quit 0)
  38.   (vlax-release-object word)

  40.   ;;通过word获取剪贴板
  41.   (setq word (vlax-create-object "Word.Application"))
  42.   (setq doc (vlax-get word 'Documents))
  43.   (setq sel (vlax-get word 'Selection))
  44.   (vlax-invoke doc 'add)
  45.   (vlax-invoke sel 'Paste)  ;word.Selection.PasteAndFormat(wdFormatPlainText)
  46.   (vlax-invoke sel 'wholeStory)
  47.   (princ "\n剪贴板的文字是:")
  48.   (princ (vlax-get sel 'text))
  49.   (vlax-release-object word)
  50. )

其实这两个东西有更多的运用，我这里只是仅仅举了几个个例子。

回复 支持 反对

使用道具 举报

highflybir
 楼主| 发表于 2011-1-10 19:55 | 显示全部楼层
本帖最后由 highflybir 于 2011-1-11 20:26 编辑

其他的对象的用法
Scriptlet.TypeLib对象

  1. ;;;生成GUID（全球唯一标志码）
  2. ;;;可以用来做为软件的加密
  3. (defun C:GUID (/ objSLTL str)
  4.   (setq objSLTL (vlax-create-object "Scriptlet.TypeLib"))
  5.   (setq str (vlax-get objSLTL 'GUID))
  6.   (vlax-release-object objSLTL)
  7.   str
  8. )

Shell.USER对象

  1. ;;;账户管理
  2. ;;;需要在管理员身份下运行
  3. ;;;window 7 和vista 可能无效
  4. (defun c:User(/ PATH NEWUSR USROBJ)
  5.   (setq path (strcat (GetSpecialPath 1) "/shgina.dll"))  
  6.   (if (Not Uc-ILEU_ALPHABETICAL)
  7.     (vlax-import-type-library
  8.       :tlb-filename   path
  9.       :methods-prefix   "Um-"
  10.       :properties-prefix  "Up-"
  11.       :constants-prefix  "Uc-"
  12.     )
  13.   )
  14.   ;;创建一个账户，设置密码和权限
  15.   ;;然后移除
  16.   (setq usrObj (vlax-create-object "Shell.users"))
  17.   (setq newusr (um-create usrobj "test"))
  18.   (up-put-setting newusr "AccountType" 3)
  19.   (Um-changePassword newusr "111222" "")
  20.   (um-remove usrObj "test")
  21.   (vlax-release-object usrobj)
  22.   (vlax-release-object newusr)
  23.   (princ)
  24. )
让你的软件发声：
SAPI.SpVoice对象
  1. ;;;语音相关

  3. (defun c:voice(/ objTTS)
  4.   (setq objTTS (vlax-create-object "SAPI.SpVoice"))
  5.   (vlax-invoke objTTS 'speak "Hello,明经通道欢迎你!")
  6.   (vlax-release-object objTTS)
  7.   (princ)
  8. )

回复 支持 反对

使用道具 举报

highflybir
 楼主| 发表于 2011-1-10 19:59 | 显示全部楼层
本帖最后由 highflybir 于 2011-1-12 23:59 编辑

其他的还有，WIA对象（用来图像处理）WMPlayer(媒体播放）,WinSock（网络通信）,ZIP（文件压缩及其解压缩）以及其他等等很多。以后将一一讲解。可见CAD的lisp语言不仅仅能画图，还一样可以做其他很多事情.
(其实，还有正则表达式等等，这些明总等已经讲的详细了)
这次讲的东西是主要的，呵呵，留以后补充吧。


Microsoft.XMLHTTP对象

;;获取本机的公网IP

  (setq path (strcat (getSpecialPath 1) "\\msxml6.dll"))
  (if (not xc-NODE_TEXT)
    (vlax-import-type-library
      :tlb-filename  path
      :methods-prefix "xm-"
      :properties-prefix "xp-"
      :constants-prefix "xc-"
    )
  )
  (setq http (vlax-create-object "Msxml2.XMLHTTP")) ;调用XMLHTTP对象
  (setq url " http://www.ip138.com/ip2city.asp")  ;赋予变量URL值
  (xm-open http "GET" url :vlax-false)   ;定义打开URL方式
  (xm-send http)
  
  
  (setq str (xp-get-responseText http))   ;获得网页文本
  (setq s1  (vl-string-position (ascii "[") str))
  (setq s2  (vl-string-position (ascii "]") str))
  (princ "\n你的IP地址是：")
  (princ (substr str (+ s1 2) (- s2 s1 1)))
  (vlax-release-object http)

WINSOCK对象
;;获取本机的内网IP
  (setq wsock (vlax-create-object "MSWinsock.Winsock"))
  (princ "\n本机的地址为:")
  (princ (vlax-get wsock 'LocalIP))
  (vlax-release-object wsock)

待续.....




回复 支持 反对

使用道具 举报

redcat
发表于 2011-1-10 20:52 | 显示全部楼层
楼主的知识和胸怀都是
回复 支持 反对

使用道具 举报

12345678910... 12下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码，在未取得本站及作者授权的情况下，不得用于商业用途

GMT+8, 2024-5-2 20:31 , Processed in 0.409235 second(s), 31 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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