【越飞越高讲堂1】ActiveX 和脚本技术在CAD的运用
本帖最后由 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。
本帖大多数用的是前者。
首先用了一个函数，为后面的程序做准备。
;;;获得系统工作路径
(defun GetSpecialPath (n / fso path)
(setq fso(vlax-create-object "Scripting.FileSystemObject"))
(setq path (vlax-get (vlax-invoke fso 'GetSpecialFolder n) 'path))
(vlax-release-object fso)
path
)
脚本技术中有几个很重要的东西: WScipt.Shell对象，FileSystemObject对象，Shell.Application对象，WMI，以及
ScriptControl对象。这几个对象我不再介绍了。
脚本宿主对象
setq path (strcat (GetSpecialPath 1) "/wshom.ocx")) ;;
(if (not wc-Alias)
(vlax-import-type-library
:tlb-filename path
:methods-prefix "wm-"
:properties-prefix"wp-"
:constants-prefix"wc-"
)
)
(setq wsh (vlax-create-object "WScript.shell"))
脚本本身
(setq path (strcat (GetSpecialPath 1) "/msscript.ocx"))
(if (not sc-Connected)
(vlax-import-type-library
:tlb-filename path
:methods-prefix "sm-"
:properties-prefix"sp-"
:constants-prefix"sc-"
)
)
(setq scr (vlax-create-object "ScriptControl"))
文件系统对象
(setq path (strcat (getSpecialPath 1) "/scrrun.dll"))
(if (not fc-Alias)
(vlax-import-type-library
:tlb-filename path
:methods-prefix "fm-"
:properties-prefix"fp-"
:constants-prefix"fc-"
)
)
(setq fso (vlax-create-object "Scripting.FileSystemObject"))
Shell对象
(setq path (strcat (getSpecialPath 1) "/shell32.dll"))
(if (not ac-ssfwindows)
(vlax-import-type-library
:tlb-filenamepath
:methods-prefix "am-"
:properties-prefix "ap-"
:constants-prefix "ac-"
)
)
(setq sha (vlax-create-object "shell.application"))
下面我一一介绍它们的用法。
WSH对象，ScriptControl对象和WMI
;;简单的欢迎
(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释放它。
本帖最后由 highflybird 于 2011-7-27 21:12 编辑
ADODB.Stream
展示如何打包二进制文件和读写二进制文件。
(defun c:test ()
;;Read a Binaryfile
(defun ReadBinary (FileName / stream arr)
(setq stream (vlax-create-object "ADODB.Stream"))
(vlax-put stream 'type 1) ;adTypeBinary
(vlax-invoke stream 'open) ;adModeRead=1 adModeWrite=2 adModeReadWrite =3
(vlax-invoke stream 'LoadFromFile filename)
(setq Arr (vlax-invoke-method stream 'read (vlax-get stream 'SIZE)));read stream
(vlax-invoke stream 'close)
(vlax-release-object stream)
(vlax-safearray->list (vlax-variant-value arr)) ;if a large size file ,it will take a long time in this step
)
;;Write to a Binaryfile from a text stream
(defun WriteBinary (FileName Array / stream)
(setq stream (vlax-create-object "ADODB.Stream"))
(vlax-put stream 'type 1) ;adTypeBinary
(vlax-invoke stream 'open) ;adModeRead=1 adModeWrite=2 adModeReadWrite =3
(vlax-invoke-method stream 'Write array) ;write stream
(vlax-invoke stream 'saveToFile fileName 2) ;save
(vlax-invoke stream 'close)
(vlax-release-object stream)
)
(setq path (getfiled "Please select a binary file:" "c:/" "" 8 )) ;get file path
(setq f (open "C:\\test.txt" "W"))
(setq data (readBinary path))
(princ data f)
(close F)
;;(setq stream (vl-get-resource "test")) ;we can wrap this text file into .vlx file
(setq f (open "C:\\test.txt" "R")) ;open for read
(setq l "")
(while (setq s (read-line f))
(setq l (strcat l s))
)
(setq array (read l))
(close f)
(setq dat (vlax-make-safearray 17 (cons 0 (1- (length array))))) ;17 for unsigned char
(vlax-safearray-fill dat array)
(setq bin (vlax-make-variant dat))
(writeBinary "C:\\test.jpg" bin) ;write binary file.
)
本帖最后由 highflybir 于 2011-1-11 20:49 编辑
回复 highflybir 的帖子
Shell.Application篇
;;;windows shell
(setq path (strcat (getSpecialPath 1) "/shell32.dll"))
(if (not ac-ssfwindows)
(vlax-import-type-library
:tlb-filenamepath
:methods-prefix "am-"
:properties-prefix "ap-"
:constants-prefix "ac-"
)
)
(setq shapp (vlax-create-object "shell.application"))
以下种种用法：
(am-CascadeWindows shapp)
;层叠窗口
(am-ControlPanelItem shapp "inetcpl.cpl" )
;打开控制面板(internet)
(am-settime shapp)
;打开时间和日期设置对话框
(am-TrayProperties shapp)
;日期和时间 属性
(am-explore shapp "c:\\")
;打开 C 盘
(am-FindComputer shapp)
;搜索计算机
(am-findPrinter shapp "canno")
;搜索打印机
(am-GetSystemInformation shapp "ProcessorSpeed")
;处理器速度:运行windows 7 和vista
(am-GetSystemInformation shapp "PhysicalMemoryInstalled")
;物理内存容量
(am-GetSystemInformation shapp "IsOS_Professional")
;是否是专业版
(am-filerun shapp)
;打开运行窗口
(am-ShutdownWindows shapp)
;关机对话框
(am-findfiles shapp)
;搜索文件
(am-toggledesktop shapp)
;显示桌面
(am-IsServiceRunning shapp "Spooler")
;检测某项服务(打印机)是否在运行
(am-WindowsSecurity shapp)
;Windows安全
(am-AddToRecent shapp "c:\\1.txt")
;添加到最近打开文档
(am-namespace shapp "c:\\")
;返回所打开的Folder对象
;选择文件夹对话框
(am-BrowseForFolder shapp
(vla-get-hwnd (vlax-get-acad-object) )
"Select a folder"
64
)
(am-BrowseForFolder shapp 0 "我的电脑" 16 17)
;打开文件浏览对话框，并获得文件夹对象
(am-open shapp "c:\\")
;打开某个目录
;;获得图像的详细信息，包括分辨率等等
(defun GetInfoOfPic(shapp path name / info root file i l)
(setq root (am-namespace shapp path))
(setq file (am-ParseName root name))
(setq i 0)
(repeat 256
(setq info (am-GetDetailsOf root file i))
(if (/= info "")
(progn
(princ (strcat "\nIndex " (itoa i) ": " info))
(setq l (cons info l))
)
)
(setq i (1+ i))
)
(reverse l)
)
(getInfoOfPic shapp "D:\\" "1.jpg")
;;下面是一个小小的程序，用来获得某个目录下的文件夹和文件名
(defun BrowseFolder(shapp fp / root items count i item path name)
(setq root (am-namespace shapp fp))
(setq items (am-items root))
(setq count (ap-get-Count items))
(setq i 0)
(repeat count
(setq item (am-item items i))
(setq path (ap-get-path item))
(setq name (ap-get-name item))
(if (= (ap-get-IsFolder item) :vlax-true) ;zip 也是folder??呵呵
(progn
(princ (strcat "\n---Folder:" path))
(BrowseFolder shapp path)
)
(princ (strcat "\nFile name:" name))
)
(setq i (1+ i))
)
)
(BrowseFolder shapp "C:\\Program Files\\AutoCAD 2006")
;;创建一个新的文件夹(移动MoveHere，拷贝copyhere，等)
(setq root (am-namespace shapp "d:\\"))
(am-NewFolder root "Test")
(setq file (am-ParseName root "1.jpg"))
(am-copyhere (am-namespace shapp "c:\\") file 16)
(am-movehere (am-namespace shapp "c:\\") file 0)
;;得到某些特殊文件夹
(am-NameSpace shapp "shell:PrintersFolder")
(am-NameSpace shapp "shell:personal")
(am-NameSpace shapp "shell:drivefolder")
;;(am-ShowBrowserBar shapp "{C4EE31F3-4768-11D2-BE5C-00A0C9A83DA1}" :vlax-true);;???
;;执行跟一个文件或者文件夹相关联的
(am-doit (am-item (am-verbs (ap-get-self root)) 0))
(am-doit (am-item (am-verbs file) 0))
;;调出控制面版选项
(am-ShellExecute shapp "Explorer.exe" "::{20D04FE0-3AEA-1069-A2D8-08002B30309D}");//打开我的电脑
(am-ShellExecute shapp "Rundll32.exe" "shell32.dll,Control_RunDLL sysdm.cpl,,2" )
(am-ShellExecute shapp "Rundll32.exe" "shell32.dll,Control_RunDLL netcpl.cpl,,1")
(am-ShellExecute shapp "Rundll32.exe" "shell32.dll,SHCreateLocalServerRunDll {601ac3dc-786a-4eb0-bf40-ee3521e70bfb}");
(am-ShellExecute shapp "Rundll32.exe" "shdocvw.dll,OpenURL") ;//Internet 快捷方式 要IE8,IE7?
(am-ShellExecute shapp "Rundll32.exe" "msconf.dll,OpenConfLink");//SpeedDial
(am-ShellExecute shapp "Rundll32.exe" "zipfldr.dll,RouteTheCall");//压缩文件夹shdocvw.dll,OpenURL
(am-ShellExecute shapp "Rundll32.exe" "netplwiz.dll,UsersRunDll");//用户帐户
(am-ShellExecute shapp "Rundll32.exe" "shell32.dll,Options_RunDLL 0");//文件夹选项
(am-ShellExecute shapp "Rundll32.exe" "shell32.dll,Options_RunDLL 1");//显示任务栏和开始菜单
(am-ShellExecute shapp "Rundll32.exe" "shell32.dll,Control_RunDLLAsUser") ;//控制面版
;;执行程序
(am-ShellExecute shapp "cmd.exe")
(setq root (am-namespace shapp "c:\\windows\\system32"))
(setq exec (am-parsename root "CMD.exe"))
(am-invokeverb exec)
;;收藏夹
(setq mark (vlax-create-object "Shell.UIHelper.1"))
(vlax-invoke mark 'AddChannel "http://www.mjtd.com/")
(vlax-invoke mark 'AddFavorite "http://www.mjtd.com" "MJTD")
(vlax-invoke mark 'AddDesktopComponent "d:\\1.jpg" "image")
;;下面用来获取某些特殊目录下的文件信息
(defun GetInfo(shapp folds / objs i obj name lst prop)
(setq objs (am-items (am-namespace shapp folds)));这些常量可以智能查取
(setq i 0)
(repeat (ap-get-count objs)
(setq obj(am-item objs i))
(setq name (ap-get-name obj))
(setq prop (am-ExtendedProperty obj "type"))
(setq lst(cons (cons name prop) lst))
(setq i (1+ i))
)
(reverse lst)
)
;;例子
(getInfo shapp ac-ssffonts) ;获取系统中安装的字体
(getInfo shapp ac-ssfCONTROLS) ;获取有哪些控制面板
(getInfo shapp ac-ssfMYPICTURES) ;获取我的图片
(getInfo shapp ac-ssfDRIVES) ;获取系统的磁盘信息
(getInfo shapp ac-ssfnetwork) ;网络
(getInfo shapp ac-ssfsystem) ;系统文件夹信息
(getInfo shapp ac-ssfnetwork) ;获得网上邻居
(getInfo shapp ac-ssfRecent) ;获得最近打开
;;下面用来获得你浏览器(Explore)打开的窗口
(defun GetWindows(shapp / i l lst obj winobj)
(vlax-invoke shapp 'windows)
(vlax-get (vlax-invoke shapp 'windows) 'count)
(setq winobj (vlax-invoke shapp 'windows))
(setq i 0)
(repeat (vlax-get winobj 'count)
(setq obj (vlax-invoke winobj 'item i))
(setq lst (list
(vlax-get obj 'toolbar)
(vlax-get obj 'StatusText)
(vlax-get obj 'FullName)
(vlax-get obj 'LocationURL)
(vlax-get obj 'Path)
)
)
(setq l (cons lst l))
(setq i (1+ i))
)
(reverse l)
)
(GetWindows shapp)
;;清空指针
(vlax-release-object mark)
(vlax-release-object root)
(vlax-release-object file)
(vlax-release-object exec)
(vlax-release-object shapp)
(princ)
ActiveX技术功能真强大，学会此技术感觉写代码更轻松，但此技术得从简单的代码学起，一步步加深，不然消化不了。 支持，沙发来个 本帖最后由 highflybir 于 2011-1-11 20:36 编辑
FSO对象
;;;filesystemObject
(defun C:FSO(/ FSO PATH)
(setq path (strcat (getSpecialPath 1) "/scrrun.dll")) scrrun.dll
(if (not fc-Alias)
(vlax-import-type-library
:tlb-filename path
:methods-prefix "fm-"
:properties-prefix "fp-"
:constants-prefix "fc-"
)
)
(setq fso (vlax-create-object "Scripting.FileSystemObject"))
;;显示目录下所有的目录
(defun showSubFolder (folder)
(vlax-forsubfolder(fp-get-SubFolders folder)
(princ (strcat "\n" (fp-get-Path subfolder)))
(ShowSubFolder subFolder)
)
)
;;获取某个目录下所有的文件夹
(defun GetSubFolder (fso path / l)
(defun GetSubFolder1 (folder / p)
(vlax-forsubfolder (fp-get-SubFolders folder)
(setq p (fp-get-Path subfolder))
(setq l (cons p (GetSubFolder subFolder)))
)
l
)
(if (fm-folderExists fso path)
(reverse (getSunFolder1 (fm-getFolder fso path)))
)
)
(showSubFolder (fm-GetFolder fso "C:\\Program Files"))
(getSubFolder (fm-GetFolder fso "C:\\Program Files"))
;;获取磁盘个数和详细情况
(defun GetNumOfDrives(fso / drives i)
(setq drives (vlax-get fso 'drives))
(setq i 0)
(vlax-for drive drives
(vlax-dump-object drive)
(setq i (1+ i))
)
(princ "\n共有磁盘个数:")
(princ i)
i
)
(GetNumOfDrives fso)
;;读取文本流
(defun ReadStream (path format / fso file str res size)
;;path the full name of a file
;;iomode 1 ;; 1 = read, 2 = write, 8 = append
;;format 0 ;; 0 = ascii, -1 = unicode, -2 = system default
(setq fso(vlax-create-object "Scripting.FileSystemObject"))
(setq file (vlax-invoke fso'getfile path))
(setq str(vlax-invoke fso 'OpenTextFile path 1 format))
(setq size (vlax-get file 'Size))
(setq res(vlax-invoke str 'read size))
(vlax-invoke str 'close)
(if str(vlax-release-object str))
(if file (vlax-release-object file))
(if fso(vlax-release-object fso))
res
)
;;写文本流
(defun WriteStrem (path text format / fso str file res)
(setq fso(vlax-create-object "Scripting.FileSystemObject"))
(setq str(vlax-invoke fso 'CreateTextFile path -1 format))
(setq file (vlax-invoke fso 'getFile path))
(vlax-invoke str 'Write text)
(vlax-invoke str 'close)
(setq res (vlax-get file 'size))
(if str(vlax-release-object str))
(if file (vlax-release-object file))
(if fso(vlax-release-object fso))
res
)
(writeStrem "C:\\test1.txt" (readStream "c:\\1.txt" -2) -2)
;;RubbishCleaner
;;详见我的帖子《CAD垃圾文件删除工具》
)
本帖最后由 highflybir 于 2011-1-11 20:33 编辑
接下来是其他的ActiveX 的用法
通用文件对话框对象
;;;通用文件对话框
;;;用来替代CAD的getfiled对话框，用以获得更多功能
(defun c:FDLG(/ DLG PATH DLGOBJ FN FSOOBJ FT)
(setq path (strcat (GetSpecialPath 1) "/comdlg32.ocx"))
(if (not dc-cdlalloc)
(vlax-import-type-library
:tlb-filenamepath
:methods-prefix"dm-"
:properties-prefix "dp-"
:constants-prefix "dc-"
)
)
(setq dlg (vlax-create-object "MSComDlg.CommonDialog"));;UserAccounts.CommonDialog
(dp-put-MaxFileSize dlg 10000)
(dp-put-filter dlg "All Files (*.*)|*.*|Lisp Files(*.lsp)|*.lsp|DWG Files (*.dwg)|*.dwg");增加过滤类型
(dm-ShowOpen dlg)
(princ (strcat "\n你打开的文件是:\n" (dp-get-filename dlg)))
;;另外一种方式
(setq path (strcat (GetSpecialPath 1) "/safrcdlg.dll"));;safrcdlg.dll
(if (not Fdp-get-FileName)
(vlax-import-type-library
:tlb-filenamepath
:methods-prefix"Fdm-"
:properties-prefix "Fdp-"
:constants-prefix "Fdc-"
)
)
;;打开文件
(setq dlgobj (vlax-create-object "SAFRCFileDlg.FileOpen"));;"SAFRCFileDlg.FileOpen"
(Fdp-put-FileName dlgobj "C:\\")
(Fdm-OpenFileOpenDlg dlgobj)
(princ "\n你打开的文件是:\n")
(princ (Fdp-get-FileName dlgobj))
(vlax-release-object dlgobj)
;;保存文件
(setq dlgobj (vlax-create-object "SAFRCFileDlg.FileSave"));;"SAFRCFileDlg.FileSave"
(setq FSOobj (vlax-create-object "Scripting.FileSystemObject"))
(Fdp-put-FileName dlgobj "test")
(Fdp-put-fileType dlgobj ".txt")
(if (Fdm-OpenFileSaveDlg dlgobj)
(progn
(setq FN (Fdp-get-FileName dlgobj))
(setq FT (Fdp-get-FileType dlgobj))
(princ (strcat "\n你要保存的文件是:\n" FN FT))
(vlax-invoke FSOobj 'CreateTextFile (strcat FN FT))
)
)
(vlax-release-object dlgobj)
(vlax-release-object FSOobj)
(princ)
)
本帖最后由 highflybir 于 2011-1-11 20:30 编辑
前段时间有人问到如何获取或者设置剪贴版，下面就是一个例子：
Form2.0对象
;;;利用form2.0设置和获取剪贴板
(defun c:Form (/ BOX CTR FMO STR)
(setq path (strcat (GetSpecialPath 1) "/fm20.dll"))
(if (not FMc-fmActionCopy)
(vlax-import-type-library
:tlb-filenamepath
:methods-prefix"FMm-"
:properties-prefix "FMp-"
:constants-prefix "FMc-"
)
)
;;获取剪贴版数据
(setq fmo (vlax-create-object "Forms.form.1"));Form
(setq ctr (FMP-GET-CONTROLs fmo)) ;控件
(setq box (fmm-add ctr "Forms.textbox.1")) ;文本框
(Fmp-put-MultiLine box :vlax-true)
(if (= (FMp-get-CanPaste box) :vlax-true) ;如能粘贴
(progn
(FMm-Paste box) ;粘贴进去
(alert (fmp-get-text box)) ;显示文本
)
)
;;设置剪贴版数据
(setq str "Hello,MJTD!\n我爱你，CAD!")
(Fmp-put-text box str) ;设置剪贴板文本内容
(Fmp-put-SelStart box 0)
(Fmp-put-SelLength box (Fmp-get-textlength box))
(Fmm-copy box) ;拷贝进去
;;释放
(vlax-release-object box)
(vlax-release-object ctr)
(vlax-release-object fmo)
(princ)
)
本帖最后由 highflybir 于 2011-1-11 20:28 编辑
InternetExplorer.Application对象和word 对象
;;获得IE窗口大小
(defun C:getscreenRes()
(setq IE (vlax-create-object "InternetExplorer.Application"))
(vlax-invoke IE 'navigate "about:blank")
(setq screen (vlax-get (vlax-get (vlax-get ie 'Document) 'parentWindow) 'screen))
(princ (vlax-get screen 'height))
(princ (vlax-get screen 'width))
(vlax-release-object IE)
)
;;;访问剪贴板
(defun C:GetPaste()
(setq IE (vlax-create-object "InternetExplorer.Application"))
(vlax-invoke IE 'navigate "about:blank")
(setq Clip (vlax-get (vlax-get (vlax-get ie 'Document) 'parentWindow) 'clipboardData))
(vlax-invoke clip 'setdata "text" "This is a test!")
(princ(vlax-invoke clip 'GetData "text"))
(vlax-release-object IE)
;;windows 7下用
(setq wsh (vlax-create-object "Wscript.Shell"))
(setq str "This is a test (by wscript.shll)")
(vlax-invoke wsh 'run
(strcat "CMD.exe /C echo " str " | clip")
0
:vlax-false
)
(vlax-release-object wsh)
;;通过word设置剪贴板
(setq word (vlax-create-object "Word.Application"))
(setq doc (vlax-get word 'Documents))
(setq sel (vlax-get word 'Selection))
(vlax-invoke doc 'add)
(vlax-put sel 'text"This is a test(by word)")
(vlax-invoke sel 'copy)
(vlax-invoke word 'quit 0)
(vlax-release-object word)
;;通过word获取剪贴板
(setq word (vlax-create-object "Word.Application"))
(setq doc (vlax-get word 'Documents))
(setq sel (vlax-get word 'Selection))
(vlax-invoke doc 'add)
(vlax-invoke sel 'Paste);word.Selection.PasteAndFormat(wdFormatPlainText)
(vlax-invoke sel 'wholeStory)
(princ "\n剪贴板的文字是:")
(princ (vlax-get sel 'text))
(vlax-release-object word)
)
其实这两个东西有更多的运用，我这里只是仅仅举了几个个例子。
本帖最后由 highflybir 于 2011-1-11 20:26 编辑
其他的对象的用法
Scriptlet.TypeLib对象
;;;生成GUID（全球唯一标志码）
;;;可以用来做为软件的加密
(defun C:GUID (/ objSLTL str)
(setq objSLTL (vlax-create-object "Scriptlet.TypeLib"))
(setq str (vlax-get objSLTL 'GUID))
(vlax-release-object objSLTL)
str
)
Shell.USER对象
;;;账户管理
;;;需要在管理员身份下运行
;;;window 7 和vista 可能无效
(defun c:User(/ PATH NEWUSR USROBJ)
(setq path (strcat (GetSpecialPath 1) "/shgina.dll"))
(if (Not Uc-ILEU_ALPHABETICAL)
(vlax-import-type-library
:tlb-filename path
:methods-prefix "Um-"
:properties-prefix"Up-"
:constants-prefix"Uc-"
)
)
;;创建一个账户，设置密码和权限
;;然后移除
(setq usrObj (vlax-create-object "Shell.users"))
(setq newusr (um-create usrobj "test"))
(up-put-setting newusr "AccountType" 3)
(Um-changePassword newusr "111222" "")
(um-remove usrObj "test")
(vlax-release-object usrobj)
(vlax-release-object newusr)
(princ)
)
让你的软件发声：
SAPI.SpVoice对象
;;;语音相关
(defun c:voice(/ objTTS)
(setq objTTS (vlax-create-object "SAPI.SpVoice"))
(vlax-invoke objTTS 'speak "Hello,明经通道欢迎你!")
(vlax-release-object objTTS)
(princ)
)
本帖最后由 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-filenamepath
: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)
待续.....
楼主的知识和胸怀都是