1. ;;;=============================================================
    2. ;;; ActiveX和脚本技术及其应用                                   
    3. ;;; ------------------------------------------------------------
    4. ;;; 此文提到的程序，都通过验证。不排除某些特殊情况下不能通过。另
    5. ;;; 外，有些地方虽然是C:开头的函数，但是不建议运行整段程序，否则
    6. ;;; 可能无法通过。之所以列出来，仅仅为提供思路和举例说明。      
    7. ;;;=============================================================
    8. (vl-load-com)
    9. ;;;Get the system special path 用来获取计算机系统的特别路径
    10. (defun GetSpecialPath (n / fso path)
    11.   (setq fso  (vlax-create-object "Scripting.FileSystemObject"))
    12.   (setq path (vlax-get (vlax-invoke fso 'GetSpecialFolder n) 'path))
    13.   (vlax-release-object fso)
    14.   path 
    15. )
    16. ;;;两种方法有不同。
    17. (defun GetSpecialFolder (name / wsh spec folder)
    18.   (setq wsh  (vlax-create-object "wscript.shell"))
    19.   (setq Spec (vlax-get wsh 'SpecialFolders))
    20.   (setq folder (vlax-invoke spec 'item name))
    21.   (vlax-release-object spec)
    22.   (vlax-release-object wsh)
    23.   folder 
    24. )
    26. ;;;Get some special folders  用来获取计算机的所有特别路径
    27. (defun GetAllSpecialFolders (/ wsh spec count folders)
    28.   (setq wsh  (vlax-create-object "wscript.shell"))
    29.   (setq Spec (vlax-get wsh 'SpecialFolders))
    30.   (setq count (vlax-invoke spec 'count))
    31.   (repeat count
    32.     (setq count (1- count))
    33.     (setq folders (cons (vlax-invoke spec 'item count) folders))
    34.   )
    35.   (vlax-release-object spec)
    36.   (vlax-release-object wsh)
    37.   folders 
    38. )
    40. ;;;=============================================================
    41. ;;;import type library 获得输人类型库                
    42. ;;;=============================================================
    43. (defun C:GetLibrary (/ path)
    44.   (setq path (strcat (GetSpecialPath 1) "\\wshom.ocx"))        ;for Wscript.shell
    45.   (if (not wc-Alias)
    46.     (vlax-import-type-library
    47.       :tlb-filename         path
    48.       :methods-prefix         "wm-"
    49.       :properties-prefix     "wp-"
    50.       :constants-prefix     "wc-"
    51.     )
    52.   )
    53.   (setq path (strcat (GetSpecialPath 1) "\\msscript.ocx"))    ;for ScriptControl
    54.   (if (not sc-Connected)
    55.     (vlax-import-type-library
    56.       :tlb-filename         path
    57.       :methods-prefix         "sm-"
    58.       :properties-prefix     "sp-"
    59.       :constants-prefix     "sc-"
    60.     )
    61.   )
    62.   (setq path (strcat (getSpecialPath 1) "\\scrrun.dll"))    ;for Shell.application
    63.   (if (not fc-Alias)
    64.     (vlax-import-type-library
    65.       :tlb-filename         path
    66.       :methods-prefix         "fm-"
    67.       :properties-prefix     "fp-"
    68.       :constants-prefix     "fc-"
    69.     )
    70.   )
    71.  (setq path (strcat (getSpecialPath 1) "\\shell32.dll"))    ;for Shell.application
    72.   (if (not ac-ssfwindows)
    73.     (vlax-import-type-library
    74.       :tlb-filename  path
    75.       :methods-prefix "am-"
    76.       :properties-prefix "ap-"
    77.       :constants-prefix "ac-"
    78.     )
    79.   )
    81.   ;;(VL-REGISTRY-READ "HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Office\\14.0\\Word\\InstallRoot")
    82.   (if (not mswc-wd70)                         ; check for a WinWord constant
    83.     (vlax-import-type-library
    84.       :tlb-filename "C:\\Program Files\\Microsoft Office\\Office14\\msword.olb" ;依据自己的安装路径和版本
    85.       :methods-prefix "mswm-"
    86.       :properties-prefix "mswp-"
    87.       :constants-prefix "mswc-"
    88.     )
    89.   )
    90. )
    92. ;;;=============================================================
    93. ;;; 利用wscript发送键                                           
    94. ;;;=============================================================
    95. (defun c:sendkey ()
    96.   (setq wsh (vlax-create-object "WScript.Shell"))
    97.   ;;Send keys 
    98.   (wm-sendkeys wsh "C{ENTER}0,0{ENTER}100{ENTER}")          ;Draw a circle in CAD. 在CAD里面画一个圆
    99.   (WM-SENDKEYS wsh (chr 1))                              ;Ctrl + A
    100.   (WM-SENDKEYS wsh (chr 15))                              ;Ctrl + O
    101.   (WM-SENDKEYS wsh (chr 22))                    ;Ctrl + V 
    102.   ;; if your system can read Chinese,these will be interesting.
    103.   (WM-SENDKEYS wsh "赌")                    ;Open My computer 打开我的电脑
    104.   (WM-SENDKEYS wsh "品")                                        ;Open Calc.exe 打开计算器
    105.   (WM-SENDKEYS wsh "血")                    ;Open Search  打开搜索
    106.   (WM-SENDKEYS wsh "恋")                     ;Open Media Player 打开媒体播放器
    107.   (WM-SENDKEYS wsh "爽")                     ;Open homepage 打开主页
    108.   (vlax-release-object wsh)
    109.   (princ)
    110. )
    112. ;;;=============================================================
    113. ;;; 测试scriptcontrol,wscript.shell                             
    114. ;;;=============================================================
    115. (defun C:test1 (/ scr wsh DESKTOPPATH ENV I LINK OBJENV OBJPRO OBJVAR OBJWMI SPEC STR URL)
    116.   (C:GetLibrary)
    117.   ;;Create a scriptControl instance. 创建脚本对象
    118.   ;;(setq scr (vlax-create-object "MSScriptControl.ScriptControl.1"))
    119.   (setq scr (vlax-create-object "ScriptControl"))
    121.   ;;put its language as "VBS" 赋予脚本语言为vbs
    122.   (vlax-put Scr "language" "vbs")                
    123.   (sp-put-Language scr "VBS")                    ;the same as upper 两者方法相同
    125.   ;;Create a Wscript.shell 创建Wscript.shell对象
    126.   (setq wsh (vlax-create-object "WScript.Shell"))
    128.   ;;Pop up a simple box 简单的对话框
    129.   (wm-Popup wsh "Hello,World!")
    131.   ;;Input box 输入框
    132.   (vlax-invoke scr 'ExecuteStatement "str=InputBox(\"Input your string:\", \"Input Box\")")
    133.   (sm-ExecuteStatement scr "str=InputBox(\"Input your string:\", \"Input Box\")")
    134.   ;;Eval a WSH variale. 对脚本变量的求值
    135.   (vlax-invoke scr 'eval "str")                    ;get the string you input.
    136.   (princ (strcat "\n脚本中str的数值是:" (sm-eval scr "str")))
    138.   ;;Create a URL shortcut 创建一个快捷链接
    139.   (setq Spec (wp-get-SpecialFolders wsh))
    140.   (setq deskTopPath (wm-item spec "DeskTop"))
    141.   (setq url (wm-CreateShortcut wsh (strcat deskTopPath "\\MyTest.URL")))
    142.   (wp-put-TargetPath url "http://www.theswamp.org/")
    143.   (wm-save url)
    145.   ;;Create a shortcut and assign a shortcut key 创建快捷方式或者快捷键
    146.   (setq link (wm-CreateShortcut wsh (strcat DeskTopPath "\\MyTest.lnk")))
    147.   (wp-put-TargetPath link "http://www.theswamp.org/")
    148.   (wp-put-WindowStyle link 1)
    149.   (wp-put-Hotkey link "Ctrl+Alt+T")
    150.   (wp-put-IconLocation link "shell32.dll,14")
    151.   (wp-put-Description link "The desciption for Mytest")
    152.   (wp-put-WorkingDirectory link "c:\\")
    153.   (wm-save link)
    155.   ;;Run command 运行命令
    156.   (wm-run wsh "cmd.exe /C dir c:\\temp\\*.* /a /s >>c:\\1.txt")
    158.   ;;Get a WshEnvironment 获取系统环境变量
    159.   (Setq env (wp-get-Environment wsh "System"))
    161.   ;;Get the special path of system. 获取某些特殊路径
    162.   (alert (wp-get-item env "WINDIR"))
    163.   (alert (wm-ExpandEnvironmentStrings wsh "%windir%"))
    164.   (alert (wp-get-Item env "TMP"))
    165.   (alert (wp-get-Item env "TEMP"))
    167.   ;;Add or remove an Environment variable  添加或者移除环境变量
    168.   (alert "Add a test var to the system!")
    169.   (wp-put-item env "TestVar" "Windows Script Host")
    170.   (alert "Remove the test var from the system!")
    171.   (wm-remove env "TestVar")
    173.   ;;List the Environment variables 列表环境变量
    174.   (setq i 0)
    175.   (repeat (wm-count env)
    176.     (princ (wp-get-item env i))                            ;wouldn't display 不会显示
    177.     (setq i (1+ i))
    178.   )
    180.   ;;Registration table 
    181.   ;;Regread ,RegWrite,RegDelete 读写注册表
    182.   (vlax-invoke wsh 'RegRead "HKCU\\Software\\AutoDesk\\AutoCAD\\R16.2\\curver")    ;ensure your CAD is autocad 2006 根据自己的CAD版本确定
    184.   ;;Maybe you would like this way: 利用vbs的脚本来获取
    185.   (setq str
    186.      "Set WshShell = CreateObject(\"WScript.Shell\")
    188.      Msgbox \"Environment.item: \"& WshShell.Environment.item(\"WINDIR\")
    189.      Msgbox \"ExpandEnvironmentStrings: \"& WshShell.ExpandEnvironmentStrings(\"%windir%\")
    191.      set oEnv=WshShell.Environment(\"System\")
    193.      Msgbox \"Adding ( TestVar=Windows Script Host ) to the System type environment\"
    194.          oEnv(\"TestVar\") = \"Windows Script Host\"
    196.          Msgbox \"removing ( TestVar=Windows Script Host ) from the System type environment\"
    197.          oEnv.Remove \"TestVar\"
    199.      for each sitem in oEnv
    200.      strval=strval & sItem & vbcrlf
    201.      next
    202.      Msgbox \"System Environment:\" & vbcrlf & vbcrlf & strval
    203.      strval=\"\"'
    205.      set oEnv=WshShell.Environment(\"Process\")
    206.      for each sitem in oEnv
    207.      strval=strval & sItem & vbcrlf
    208.      next
    209.      Msgbox \"Process Environment:\" & vbcrlf & vbcrlf & strval
    210.      strval=\"\"
    212.      set oEnv=WshShell.Environment(\"User\")
    213.      for each sitem in oEnv
    214.      strval=strval & sItem & vbcrlf
    215.      next
    216.      Msgbox \"User Environment:\" & vbcrlf & vbcrlf & strval
    217.      strval=\"\"
    219.      set oEnv=WshShell.Environment(\"Volatile\")
    220.      for each sitem in oEnv
    221.      strval=strval & sItem & vbcrlf
    222.      next
    223.      Msgbox \"Volatile Environment:\" & vbcrlf & vbcrlf & strval
    224.      strval=\"\"
    226.      set oEnv = nothing
    227.      set WshShell = nothing
    228.      "
    229.   )
    230.   (vlax-invoke Scr 'ExecuteStatement str)
    232.   ;;Get some information from OS 获取操作系统信息
    233.   (setq str "Set mc=GetObject(\"Winmgmts:\")")
    234.   (SM-EXECUTESTATEMENT scr str)
    235.   (setq objWMI (vla-eval scr "mc"))
    237.   ;;another way  另一种方法
    238.   (setq objENv (vlax-invoke objWMI 'get "Win32_Environment"))
    239.   (setq objvar (vlax-invoke objenv 'SpawnInstance_))
    240.   (setq objPro (vlax-get objvar 'Properties_))
    242.   ;; get more usage 获取更多用法
    243.   (vlax-dump-object objvar T)
    244.   (vlax-for n objpro
    245.     (vlax-dump-object n T)
    246.   )
    248.   ;; 测试环境比变量的查询、增加和删除
    249.   (vlax-put (vlax-invoke objpro 'item "name") 'value "TestValue")
    250.   (vlax-put (vlax-invoke objpro 'item "UserName") 'value "System")
    251.   (vlax-put (vlax-invoke objpro 'item "VariableValue") 'value "This is a test")
    252.   (vlax-put objvar 'name "MyTest")
    253.   (vlax-put objvar 'UserName "System")
    254.   (vlax-put objvar 'VariableValue "This is a test")
    255.   (vlax-invoke objvar 'put_)
    256.   (vlax-for obj (vlax-invoke objWMI 'ExecQuery "Select * from Win32_Environment Where Name = 'Path'")
    257.     (princ (strcat "\nName is:" (vlax-get obj 'name)))
    258.     (princ (strcat "\nUser Name is:" (vlax-get obj 'username)))
    259.     (princ (strcat "\nVariable value is:" (vlax-get obj 'variablevalue)))
    260.   )
    262.   ;; 最终释放
    263.   (and ObjPro (vlax-release-object ObjPro))
    264.   (and objvar (vlax-release-object objvar))
    265.   (and objENv (vlax-release-object objENv))
    266.   (and objWMI (vlax-release-object objWMI))
    267.   (and scr (vlax-release-object scr))
    268.   (and wsh (vlax-release-object wsh))
    269.   (princ)
    270. )
    273. ;;;=============================================================
    274. ;;; 用WMI来获取系统软硬件等信息.                                
    275. ;;;=============================================================
    276. (defun C:Test2 (/ SVR WMI)
    277.   ;; ProcessorId 获取处理器ID的子程序
    278.   (defun C:CPUID (/ WMI SVR CPU s)
    279.     (setq WMI (vlax-create-object "WbemScripting.SWbemLocator"))
    280.     (setq SVR (VLAX-INVOKE WMI 'ConnectServer))
    281.     (setq    CPU (vlax-invoke SVR 'InstancesOf "Win32_Processor"))
    282.     (vlax-for item CPU
    283.       (setq s (cons (vlax-get item 'ProcessorId) s))
    284.     )
    285.     (vlax-release-object CPU)
    286.     (vlax-release-object SVR)
    287.     (vlax-release-object WMI)
    288.     (reverse s)
    289.   )
    290.   (defun CPUID(/ scr str objwmi objcpu)
    291.     (setq scr (vlax-create-object "ScriptControl"))
    292.     (vlax-put scr 'language "VBS")
    293.     (setq str "Set mc=GetObject(\"Winmgmts:\")")
    294.     (vlax-invoke scr 'EXECUTESTATEMENT str)
    295.     (setq objWMI (vla-eval scr "mc"))
    296.     (setq objCPU (vlax-invoke objWMI 'InstancesOF "Win32_Processor"))
    297.     (vlax-for obj objCPU
    298.       (alert (vlax-get obj 'ProcessorId))
    299.     )
    300.     (vlax-release-object objCPU)
    301.     (vlax-release-object objWMI)
    302.     (vlax-release-object scr)
    303.     (princ)
    304.   )
    305.   ;;可通过下面两种方式获得ISWbemServicesEx实例:(我已注释掉方式1)
    306.   ;;(setq str "Set mc=GetObject(\"Winmgmts:\")")
    307.   ;;(SM-EXECUTESTATEMENT scr str)
    308.   ;;(setq SVR (vla-eval scr "mc"))
    310.   (setq WMI (vlax-create-object "WbemScripting.SWbemLocator"))
    311.   (setq SVR (VLAX-INVOKE WMI 'ConnectServer))
    312.   ;;you can get more details  by these ways:
    313.   (foreach p (list
    314.            "Win32_ComputerSystem"
    315.            "Win32_Service"
    316.            "Win32_LogicalMemoryConfiguration"
    317.            "Win32_Process"
    318.            "Win32_Processor"
    319.            "Win32_OperatingSystem"
    320.            "Win32_WMISetting"
    321.            "__NAMESPACE"
    322.            "win32_baseboard"
    323.            "win32_videocontroller"
    324.            "win32_DiskDrive"
    325.            "win32_physicalMemory"
    326.            "Win32_Environment"
    327.            "Win32_ProcessStartTrace"
    328.            "Win32_PnpDevice"
    329.            "Win32_SoundDevice"
    330.            "Win32_ProductCheck"
    331.            "Win32_NetworkAdapter"
    332.            "Win32_CDROMDrive"
    333.            "Win32_DesktopMonitor"
    334.            "Win32_NetworkAdapterConfiguration"
    335.          )
    336.     (vlax-for n (vlax-invoke SVR 'InstancesOf p)
    337.       (alert (vlax-invoke n 'GetObjectText_))  
    338.     )
    339.   )
    341.   ;;Just collect some simple information:
    342.   ;;Get User name.用户名
    343.   (vlax-for n (vlax-invoke SVR 'InstancesOf "Win32_ComputerSystem")
    344.     (princ "\nUser name is:")
    345.     (princ (vlax-get n 'name))
    346.   )
    348.   ;;Get the running process 进程
    349.   (vlax-for n (vlax-invoke SVR 'InstancesOf "Win32_Process")
    350.     (princ (strcat "\n" (vlax-get n 'name)))
    351.   )
    353.   ;;Get the information of CPU 处理器
    354.   (vlax-for n (vlax-invoke SVR 'InstancesOf "Win32_Processor")
    355.     (princ (vlax-get n 'name))
    356.   )
    358.   ;;Get the Total of Computer System 计算机系统
    359.   (vlax-for n (vlax-invoke SVR 'InstancesOf  "Win32_ComputerSystem")
    360.     (princ (/ (read (vlax-get n 'TotalPhysicalMemory)) 1048576))
    361.     (princ "M")
    362.   )
    364.   ;;Get the information of physical memory 物理内存
    365.   (vlax-for n (vlax-invoke SVR 'InstancesOf  "Win32_PhysicalMemory")
    366.     (princ "\n")
    367.     (princ (vlax-get n 'Description))
    368.     (princ "\n")
    369.     (princ (vlax-get n 'DeviceLocator))
    370.     (princ "\n")
    371.     (princ (vlax-get n 'speed))
    372.   )
    374.   ;;Get the information of Video Controller 显卡
    375.   (vlax-for n (vlax-invoke SVR 'InstancesOf "Win32_VideoController")
    376.     (princ "\n")
    377.     (princ (vlax-get n 'Caption))
    378.     (princ "\n")
    379.     (princ (vlax-get n 'VideoModeDescription))
    380.   )
    382.   ;;Get the information of Disk drive 磁盘
    383.   (vlax-for n (vlax-invoke SVR 'InstancesOf "Win32_DiskDrive")
    384.     (princ "\nThe Caption is:")
    385.     (princ (vlax-get n 'Caption))
    386.     (princ "\nThe size is:")
    387.     (princ (/ (read (vlax-get n 'size)) 1073741824))
    388.     (princ "G")
    389.   )
    391.   ;;Get the information of Sound Device 声卡
    392.   (vlax-for n (vlax-invoke SVR 'InstancesOf "Win32_SoundDevice")
    393.     (princ "\nThe product Name is:")
    394.     (princ (vlax-get n 'ProductName))
    395.   )
    397.   ;;Network Adapter 网卡配置信息
    398.   (princ "\nThe Mac Address is: ")
    399.   (vlax-for obj (vlax-invoke SVR 'InstancesOF "Win32_NetworkAdapterConfiguration")
    400.     (if(/= (vlax-get obj 'IPEnabled) 0)
    401.       (princ (vlax-get obj 'MacAddress))
    402.     )
    403.   )
    405.   ;;Get the information of Network Adapter 网络适配器
    406.   (vlax-for n (vlax-invoke SVR 'InstancesOf "Win32_NetworkAdapter")
    407.     (princ "\nThe Description is:")
    408.     (princ (vlax-get n 'Description))
    409.     (princ "\nThe MAC address is")
    410.     (princ (vlax-get n 'MACAddress))
    411.   )
    413.   ;;Get the information of FloppyDrive --haha,do you have a floppy drive? 软驱
    414.   (vlax-for n (vlax-invoke SVR 'InstancesOf "Win32_FloppyDrive")
    415.     (princ "\nThe caption is:")
    416.     (princ (vlax-get n 'Caption))
    417.   )
    419.   ;;Get the information of CD/DVD ROM 光驱
    420.   (vlax-for n (vlax-invoke SVR 'InstancesOf "Win32_CDROMDrive")
    421.     (princ "\nThe Drive name is:")
    422.     (princ (vlax-get n 'Name))
    423.     (princ "\nThe description is:")
    424.     (princ (vlax-get n 'Description))       
    425.   )
    427.   ;;Get the information of Desktop Monitor 显示器
    428.   (vlax-for n (vlax-invoke SVR 'InstancesOf "Win32_DesktopMonitor")
    429.     (princ "\nScreen Width:")
    430.     (princ (vlax-get n 'ScreenWidth))
    431.     (princ "\nScreen Height:")
    432.     (princ (vlax-get n 'ScreenHeight))
    433.   )
    435.   ;;Printer 打印机
    436.   (vlax-for obj (vlax-invoke SVR 'InstancesOF "Win32_Printer")
    437.     (vlax-dump-object obj T)
    438.     (alert (vlax-get obj 'Name))
    439.     (vlax-get obj 'PaperSizesSupported)
    440.     (alert (vlax-invoke obj 'GetObjectText_))
    441.   )
    442.   (vlax-release-object SVR)
    443.   (vlax-release-object WMI)
    444.   (princ)
    445. )
    447. ;;;=============================================================
    448. ;;; Shell.Application的一些例子函数和应用            
    449. ;;; some small applications of Shell.application        
    450. ;;;=============================================================
    451. (defun C:test3 (/ *SHELL BIN EXEC FILE MARK OPFLAG PATH ROOT)
    452.   (setq path (strcat (getSpecialPath 1) "\\shell32.dll"))
    453.   (if (not ac-ssfwindows)
    454.     (vlax-import-type-library
    455.       :tlb-filename  path
    456.       :methods-prefix "am-"
    457.       :properties-prefix "ap-"
    458.       :constants-prefix "ac-"
    459.     )
    460.   )
    461.   (setq *SHELL (vlax-create-object "Shell.Application"))
    462.   (am-CascadeWindows *SHELL)                      ;Cascade Windows 层叠窗口
    463.   (am-ControlPanelItem *SHELL "inetcpl.cpl" )                ;Open a control panel(internet) 打开控制面板
    464.   (am-settime *SHELL)                         ;Open the time setting dialog 打开时间和日期设置对话框
    465.   (am-TrayProperties *SHELL)                    ;日期和时间 属性
    466.   (am-explore *SHELL "c:\\")                                    ;Explore C: 打开 C 盘
    467.   (am-FindComputer *SHELL)                                      ;Search a computer 搜索计算机
    468.   (am-findPrinter *SHELL "canno")                               ;Search a printer 搜索打印机
    469.   (am-GetSystemInformation *SHELL "ProcessorSpeed")             ;Get the processor speed(in windows 7 or vista) 处理器速度
    470.   (am-GetSystemInformation *SHELL "PhysicalMemoryInstalled")    ;the capacity of physical memory 物理内存容量
    471.   (am-GetSystemInformation *SHELL "IsOS_Professional")          ;Check the Operating system version is professional or not. 是否是专业版
    472.   (am-filerun *SHELL)                                           ;Open "Windows Run" 打开运行窗口
    473.   (am-ShutdownWindows *SHELL)                                   ;Shutdown windows 关机对话框
    474.   (am-findfiles *SHELL)                                         ;Searh files 搜索文件
    475.   (am-toggledesktop *SHELL)                                     ;toggle desktop 显示桌面
    476.   (am-IsServiceRunning *SHELL "Spooler")            ;check a service is running or not(e.g,spooler service) 检测某项服务(打印机)是否在运行
    477.   (am-WindowsSecurity *SHELL)                                   ;Windows Security Windows安全
    478.   (am-AddToRecent *SHELL "c:\\1.txt")                ;Add to recent 添加到最近打开文档
    479.   (am-namespace *SHELL "c:\\")                                  ;return a folder object 返回所打开的Folder对象
    480.   (am-BrowseForFolder *SHELL                    ;BrowseForFolder 选择文件夹对话框
    481.     (vla-get-hwnd (vlax-get-acad-object) )
    482.     "Select a folder"
    483.     64
    484.   )
    485.   (am-BrowseForFolder shapp 0 "我的电脑" 16 17)            ;打开文件浏览对话框，并获得文件夹对象
    486.   (am-open *SHELL "c:\\")                    ;Open a folder. 打开某个目录
    488.   ;;Here is an example,to get some details of a picture file.   获得图像的详细信息，包括分辨率等等
    489.   (defun GetInfoOfPic(*SHELL path name / info root file i l)
    490.     (setq root (am-namespace *SHELL path))
    491.     (setq file (am-ParseName root name))
    492.     (setq i 0)
    493.     (repeat 256
    494.       (setq info (am-GetDetailsOf root file i))
    495.       (if (/= info "")
    496.     (progn 
    497.           (princ (strcat "\nIndex " (itoa i) ": " info))
    498.       (setq l (cons info l))
    499.     )
    500.       )
    501.       (setq i (1+ i))
    502.     )
    503.     (reverse l)
    504.   )
    505.   (getInfoOfPic *SHELL "D:\\temp" "1.jpg")
    507.   ;; 下面是一个小小的程序，用来获得某个目录下的文件夹和文件名
    508.   ;; Here is a program to get a foler and its subdirectories and files name.
    509.   (defun BrowseFolder(*SHELL fp / root items count i item path name)
    510.     (setq root (am-namespace *SHELL fp))
    511.     (setq items (am-items root))
    512.     (setq count (ap-get-Count items))
    513.     (setq i 0)
    514.     (repeat count
    515.       (setq item (am-item items i))
    516.       (setq path (ap-get-path item))
    517.       (setq name (ap-get-name item))
    518.       (if (= (ap-get-IsFolder item) :vlax-true)            
    519.     (progn
    520.       (princ (strcat "\n---Folder:" path))
    521.       (BrowseFolder *SHELL path)
    522.     )
    523.     (princ (strcat "\nFile name:" name))
    524.       )
    525.       (setq i (1+ i))
    526.     )
    527.   )
    528.   (BrowseFolder *SHELL "C:\\Program Files (x86)\\AutoCAD 2006")    ;此处路径根据你的情况而定
    530.   ;;to Create a new foler 创建文件夹
    531.   (setq root (am-namespace *SHELL "d:\\"))
    532.   (am-NewFolder root "Test")
    534.   ;;to copy a file 拷贝文件
    535.   (setq file (am-ParseName root "1.jpg"))
    536.   (am-copyhere (am-namespace *SHELL "c:\\") file 16)
    538.   ;;to move a file (e.g,move a file to recyle bin) 移动一个文件
    539.   (setq opFlag 1108)                        ;FOF_ALLOWUNDO | FOF_SIMPLEPROGRESS | FOF_NOCONFIRMATION
    540.   (setq bin (am-namespace *SHELL 10))                ;Recyle bin 
    541.   (am-movehere bin "c:\\1.dwg" opFlag)                  ;move to recyle bin
    543.   ;;Get some special folder. 得到某些特殊文件夹
    544.   (am-NameSpace *SHELL "shell:PrintersFolder")
    545.   (am-NameSpace *SHELL "shell:personal")
    546.   (am-NameSpace *SHELL "shell:drivefolder")
    547.   ;;(am-ShowBrowserBar *SHELL "{C4EE31F3-4768-11D2-BE5C-00A0C9A83DA1}" :vlax-true);;???
    549.   ;;Verbs and File Associations  执行跟一个文件或者文件夹相关联的
    550.   (am-doit (am-item (am-verbs (ap-get-self root)) 0))
    551.   (am-doit (am-item (am-verbs file) 0))
    553.   ;;Open some control panel options 
    554.   (am-ShellExecute *SHELL "Explorer.exe" "::{20D04FE0-3AEA-1069-A2D8-08002B30309D}")    ;Open "My Computer" 打开我的电脑
    555.   (am-ShellExecute *SHELL "Rundll32.exe" "shell32.dll,Control_RunDLL netcpl.cpl,,1")    ;
    556.   (am-ShellExecute *SHELL "Rundll32.exe" "shell32.dll,Control_RunDLL sysdm.cpl,,2" )    ;Open "System Property" 系统属性
    557.   (am-ShellExecute *SHELL "Rundll32.exe" "shdocvw.dll,OpenURL %l")            ;Internet shortcut ,IE8,IE7? Internet 快捷方式
    558.   (am-ShellExecute *SHELL "Rundll32.exe" "msconf.dll,OpenConfLink")            ;SpeedDial
    559.   (am-ShellExecute *SHELL "Rundll32.exe" "zipfldr.dll,RouteTheCall")            ;Zip file 压缩文件夹shdocvw.dll,OpenURL
    560.   (am-ShellExecute *SHELL "Rundll32.exe" "netplwiz.dll,UsersRunDll")            ;user account control panel 用户帐户
    561.   (am-ShellExecute *SHELL "Rundll32.exe" "shell32.dll,Options_RunDLL 0")        ;Open Folder Options 文件夹选项
    562.   (am-ShellExecute *SHELL "Rundll32.exe" "shell32.dll,Options_RunDLL 1")        ;Open Taskbar 显示任务栏和开始菜单
    563.   (am-ShellExecute *SHELL "Rundll32.exe" "shell32.dll,Control_RunDLLAsUser")        ;Open Control panel 控制面版
    564.   (am-ShellExecute *SHELL "rundll32.exe" "kernel32.dll,Sleep 10000")
    565.   (am-ShellExecute *SHELL "rundll32.exe" "kernel32.dll GetVersion") 
    566.   (am-shellExecute *SHELL "Rundll32.exe" "user32.dll,Messagebox 0 hahah aaa 0")
    567.   (am-ShellExecute *SHELL "Rundll32.exe" "shell32.dll,SHCreateLocalServerRunDll {601ac3dc-786a-4eb0-bf40-ee3521e70bfb}");
    569.   ;;Execute shell command.
    570.   (am-ShellExecute *SHELL "cmd.exe")
    571.   (setq root (am-namespace *SHELL "c:\\windows\\system32"))
    572.   (setq exec (am-parsename root "CMD.exe"))
    573.   (am-invokeverb exec)
    575.   ;;Favorite,add to bookmark 加入到收藏夹
    576.   (setq mark (vlax-create-object "Shell.UIHelper.1"))
    577.   (vlax-invoke mark 'AddChannel "http://www.theswamp.org/")
    578.   (vlax-invoke mark 'AddFavorite "http://www.theswamp.org/" "Theswamp")
    579.   (vlax-invoke mark 'AddDesktopComponent "d:\\1.jpg" "image")
    581.   ;;Get information from a special path 获取某些特别路径
    582.   (defun GetInfo(*SHELL folds / objs i obj name lst prop)
    583.     (setq objs (am-items (am-namespace *SHELL folds)))      ;from ac-XXXXXX
    584.     (setq i 0)
    585.     (repeat (ap-get-count objs)
    586.       (setq obj  (am-item objs i))
    587.       (setq name (ap-get-name obj))
    588.       (setq prop (am-ExtendedProperty obj "type"))
    589.       (setq lst  (cons (cons name prop) lst))
    590.       (setq i (1+ i))
    591.     )
    592.     (reverse lst)
    593.   )
    595.   ;;some examples: 一些例子用来获取某些特殊目录下的文件信息
    596.   (getInfo *SHELL ac-ssffonts)                    ;Get the fonts installed.获取系统中安装的字体
    597.   (getInfo *SHELL ac-ssfCONTROLS)                 ;Get the control panles.获取有哪些控制面板
    598.   (getInfo *SHELL ac-ssfMYPICTURES)                       ;Get the pictures in "My Pictures" 获取我的图片
    599.   (getInfo *SHELL ac-ssfDRIVES)                           ;Get the Drivers in "My computer" 获取系统的磁盘信息
    600.   (getInfo *SHELL ac-ssfnetwork)                          ;Get the information of "network" 获得网上邻居
    601.   (getInfo *SHELL ac-ssfsystem)                    ;Get the files from system folder.系统文件夹信息
    602.   (getInfo *SHELL ac-ssfRecent)                          ;Get the Recent opened files 获得最近打开
    604.   ;;this function to get the windows that opened by "Explore"    
    605.   (defun GetWindows(*SHELL / i l lst obj winobj)
    606.     (vlax-invoke *SHELL 'windows)
    607.     (vlax-get (vlax-invoke *SHELL 'windows) 'count)
    608.     (setq winobj (vlax-invoke *SHELL 'windows))
    609.     (setq i 0)
    610.     (repeat (vlax-get winobj 'count)
    611.       (setq obj (vlax-invoke winobj 'item i))
    612.       (setq lst (list
    613.           (vlax-get obj 'toolbar)
    614.           (vlax-get obj 'StatusText)
    615.           (vlax-get obj 'FullName)
    616.           (vlax-get obj 'LocationURL)
    617.           (vlax-get obj 'Path)
    618.         )
    619.       )
    620.       (setq l (cons lst l))        
    621.       (setq i (1+ i))
    622.     )
    623.     (reverse l)
    624.   )
    625.   (GetWindows *SHELL)
    627.   ;;最后不要忘记释放
    628.   (vlax-release-object mark)
    629.   (vlax-release-object root)
    630.   (vlax-release-object file)
    631.   (vlax-release-object exec)
    632.   (vlax-release-object *SHELL)
    633.   (princ)
    634. )
    636. ;;;=============================================================
    637. ;;;Get filesystemObject                        
    638. ;;;=============================================================
    639. (defun c:test4 ( / FSO PATH)
    640.   (setq path (strcat (getSpecialPath 1) "\\scrrun.dll"))
    641.   (if (not fc-Alias)
    642.     (vlax-import-type-library
    643.       :tlb-filename         path
    644.       :methods-prefix         "fm-"
    645.       :properties-prefix     "fp-"
    646.       :constants-prefix     "fc-"
    647.     )
    648.   )
    649.   (setq fso (vlax-create-object "Scripting.FileSystemObject"))
    651.   ;;Print a foler and its subfolders
    652.   (defun showSubFolder (folder)
    653.     (vlax-for  subfolder  (fp-get-SubFolders folder)
    654.       (princ (strcat "\n" (fp-get-Path subfolder)))
    655.       (ShowSubFolder subFolder)
    656.     )
    657.   )
    658.   ;;Get a folder and all of its subfolders(recursively)
    659.   (defun GetSubFolder (fso path / l)
    660.     (defun GetSubFolder1 (folder / p)
    661.       (vlax-for subfolder (fp-get-SubFolders folder)
    662.         (setq p (fp-get-Path subfolder))
    663.         (setq l (cons p (GetSubFolder1 subFolder)))
    664.       )
    665.       l
    666.     )
    667.     (setq l (list path))
    668.     (if (fm-folderExists fso path)
    669.       (reverse (getSubFolder1 (fm-getFolder fso path)))
    670.     )    
    671.   )
    673.   (showSubFolder (fm-GetFolder fso "C:\\temp"))
    674.   (getSubFolder fso "C:\\temp")
    676.   (defun GetNumOfDrives(fso / drives i)
    677.     (setq drives (vlax-get fso 'drives))
    678.     (setq i 0)
    679.     (vlax-for drive drives
    680.       (vlax-dump-object drive)
    681.       (setq i (1+ i))
    682.     )
    683.     (princ "\nThe count of disks is: ")
    684.     (princ i)
    685.     i
    686.   )
    687.   (GetNumOfDrives fso)
    689.   ;; Read stream
    690.   (defun ReadStream (path format / fso file str res size)
    691.     ;;path    the full name of a file
    692.     ;;iomode   1 ;; 1 = read, 2 = write, 8 = append
    693.     ;;format   0 ;; 0 = ascii, -1 = unicode, -2 = system default
    694.     (setq fso  (vlax-create-object "Scripting.FileSystemObject"))
    695.     (setq file (vlax-invoke fso  'getfile path))
    696.     (setq str  (vlax-invoke fso 'OpenTextFile path 1 format))
    697.     (setq size (vlax-get file 'Size))
    698.     (setq res  (vlax-invoke str 'read size))
    699.     (vlax-invoke str 'close)
    700.     (if str  (vlax-release-object str))
    701.     (if file (vlax-release-object file))
    702.     (if fso  (vlax-release-object fso))
    703.     res
    704.   )
    705.   ;;Write stream
    706.   (defun WriteStream (path text format / fso str file res)
    707.     (setq fso  (vlax-create-object "Scripting.FileSystemObject"))
    708.     (setq str  (vlax-invoke fso 'CreateTextFile path -1 format))
    709.     (setq file (vlax-invoke fso 'getFile path))
    710.     (vlax-invoke str 'Write text)
    711.     (vlax-invoke str 'close)
    712.     (setq res (vlax-get file 'size))
    713.     (if str  (vlax-release-object str))
    714.     (if file (vlax-release-object file))
    715.     (if fso  (vlax-release-object fso))
    716.     res
    717.   )
    718.   (writeStrem "C:\\test1.txt" (readStream "c:\\1.txt" -2) -2)
    719.   (and fso (vlax-release-object fso))
    720.   (princ)
    721. )
    723. ;;;=============================================================
    724. ;;; Manage user account 账户管理                                
    725. ;;; need run as Administrator 需要以管理员身份运行此程序    
    726. ;;; maybe invalid in window 7 or vista 在vista以上版本可能无效    
    727. ;;;=============================================================
    728. (defun c:User(/ PATH NEWUSR USROBJ)
    729.   (setq path (strcat (GetSpecialPath 1) "\\shgina.dll"))     
    730.   (if (Not Uc-ILEU_ALPHABETICAL)
    731.     (vlax-import-type-library
    732.       :tlb-filename         path
    733.       :methods-prefix         "Um-"
    734.       :properties-prefix     "Up-"
    735.       :constants-prefix     "Uc-"
    736.     )
    737.   )
    739.   ;;add an account,and set password or something
    740.   ;;then remove this account.
    741.   (setq usrObj (vlax-create-object "Shell.users"))
    742.   (setq newusr (um-create usrobj "test"))
    743.   (up-put-setting newusr "AccountType" 3)
    744.   (Um-changePassword newusr "111222" "")
    745.   (um-remove usrObj "test")
    746.   (vlax-release-object usrobj)
    747.   (vlax-release-object newusr)
    748.   (princ)
    749. )
    751. ;;;=============================================================
    752. ;;;Common File Dialog  公用对话框(包括文件对话框，颜色对话框等) 
    753. ;;;=============================================================
    754. (defun c:FDLG(/ DLG PATH DLGOBJ FN FSOOBJ FT)
    755.   (setq path (strcat (GetSpecialPath 1) "\\comdlg32.ocx")) 
    756.   (if (not dc-cdlalloc)
    757.     (vlax-import-type-library
    758.       :tlb-filename        path
    759.       :methods-prefix        "dm-"
    760.       :properties-prefix    "dp-"
    761.       :constants-prefix             "dc-"
    762.     )
    763.   )
    764.   (setq dlg (vlax-create-object "MSComDlg.CommonDialog"))     ;UserAccounts.CommonDialog
    765.   (dp-put-MaxFileSize dlg 10000)
    766.   (dp-put-filter dlg "All Files (*.*)|*.*|Lisp Files(*.lsp)|*.lsp|DWG Files (*.dwg)|*.dwg")
    767.                                                                 ;put the file filter
    768.   (dm-ShowOpen dlg)
    769.   (princ (strcat "\nThe file you opened is:\n" (dp-get-filename dlg)))
    771.   ;;Another way
    772.   (setq path (strcat (GetSpecialPath 1) "\\safrcdlg.dll"))     ;safrcdlg.dll
    773.   (if (not Fdp-get-FileName)
    774.     (vlax-import-type-library
    775.       :tlb-filename        path
    776.       :methods-prefix        "Fdm-"
    777.       :properties-prefix    "Fdp-"
    778.       :constants-prefix             "Fdc-"
    779.     )
    780.   )
    782.   ;;just for open (simple)
    783.   (setq dlgobj (vlax-create-object "SAFRCFileDlg.FileOpen"))     ;"SAFRCFileDlg.FileOpen"
    784.   (Fdp-put-FileName dlgobj "C:\\")
    785.   (Fdm-OpenFileOpenDlg dlgobj)
    786.   (princ "\nThe file you opened is:\n") 
    787.   (princ (Fdp-get-FileName dlgobj))
    788.   (vlax-release-object dlgobj)
    790.   ;;Open for save
    791.   (setq dlgobj (vlax-create-object "SAFRCFileDlg.FileSave"))     ;"SAFRCFileDlg.FileSave"
    792.   (setq FSOobj (vlax-create-object "Scripting.FileSystemObject"))
    793.   (Fdp-put-FileName dlgobj "test")
    794.   (Fdp-put-fileType dlgobj ".txt")
    795.   (if (Fdm-OpenFileSaveDlg dlgobj)
    796.     (progn
    797.       (setq FN (Fdp-get-FileName dlgobj))
    798.       (setq FT (Fdp-get-FileType dlgobj))
    799.       (princ (strcat "\nThe file you will save:\n" FN FT)) 
    800.       (vlax-invoke FSOobj 'CreateTextFile (strcat FN FT))
    801.     )
    802.   )
    803.   (vlax-release-object dlgobj)
    804.   (vlax-release-object FSOobj)
    805.   (princ)
    806. )
    808. ;;;=============================================================
    809. ;;;Get or set clipboard by Form2.0 利用form2.0来设置或获取剪切板
    810. ;;;=============================================================
    811. (defun c:Form (/ BOX CTR FMO STR)
    812.   (setq path (strcat (GetSpecialPath 1) "\\FM20.dll"))
    813.   (if (not FMc-fmActionCopy)
    814.     (vlax-import-type-library
    815.       :tlb-filename        path
    816.       :methods-prefix        "FMm-"
    817.       :properties-prefix    "FMp-"
    818.       :constants-prefix             "FMc-"
    819.     )
    820.   )
    821.   ;;get text for clipboard
    822.   (setq fmo (vlax-create-object "Forms.form.1"))         ;Create a Form instance
    823.   (setq ctr (FMP-GET-CONTROLs fmo))                ;the controls of this from
    824.   (setq box (fmm-add ctr "Forms.textbox.1"))             ;add a textbox control
    825.   (Fmp-put-MultiLine box :vlax-true)
    826.   (if (= (FMp-get-CanPaste box) :vlax-true)             ;if can be pasted
    827.     (progn
    828.       (FMm-Paste box)                        ;paste into textbox
    829.       (alert (fmp-get-text box))                ;show the text
    830.     )
    831.   )
    832.   ;;set text for clipboard
    833.   (setq str "Hello,theswamp!\nI Love you!")
    834.   (Fmp-put-text box str)                    ;Set the text of clipboard
    835.   (Fmp-put-SelStart box 0)
    836.   (Fmp-put-SelLength box (Fmp-get-textlength box))
    837.   (Fmm-copy box)                        ;copy it into textbox
    838.   ;;release object
    839.   (vlax-release-object box)
    840.   (vlax-release-object ctr)
    841.   (vlax-release-object fmo)
    842.   (princ)
    843. )
    845. ;;;=============================================================
    846. ;;;Get or set clipboard by other way  剪切板的其他方式          
    847. ;;;=============================================================
    848. (defun C:Clipboard (/ CLIP DOC IE SEL STR WORD WSH)
    849.   ;; by InternetExplorer 用IE        
    850.   (setq IE (vlax-create-object "InternetExplorer.Application"))
    851.   (vlax-invoke IE 'navigate "about:blank")
    852.   (setq Clip (vlax-get (vlax-get (vlax-get ie 'Document) 'parentWindow) 'clipboardData))
    853.   (vlax-invoke clip 'setdata "text" "This is a test!")
    854.   (princ  (vlax-invoke clip 'GetData "text"))
    855.   (vlax-release-object IE)
    857.   ;;works in windows 7 用wscript
    858.   (setq wsh (vlax-create-object "Wscript.Shell"))
    859.   (setq str "This is a test (by wscript.shll)")
    860.   (vlax-invoke wsh 'run
    861.     (strcat "CMD.exe /C echo " str " | clip")
    862.     0
    863.     :vlax-false
    864.   )
    865.   (vlax-release-object wsh)
    867.   ;;by Microsoft office word 用office
    868.   ;;Set by Word.Application
    869.   (setq word (vlax-create-object "Word.Application"))
    870.   (setq doc (vlax-get word 'Documents))
    871.   (setq sel (vlax-get word 'Selection))
    872.   (vlax-invoke doc 'add)
    873.   (vlax-put sel 'text  "This is a test(by word)")
    874.   (vlax-invoke sel 'copy)
    875.   (vlax-invoke word 'quit 0)
    876.   (vlax-release-object word)
    877.   ;;Get by Word.Application
    878.   (setq word (vlax-create-object "Word.Application"))
    879.   (setq doc (vlax-get word 'Documents))
    880.   (setq sel (vlax-get word 'Selection))
    881.   (vlax-invoke doc 'add)
    882.   (vlax-invoke sel 'Paste)  ;word.Selection.PasteAndFormat(wdFormatPlainText)
    883.   (vlax-invoke sel 'wholeStory)
    884.   (princ "\nThe text in clipboard is:")
    885.   (princ (vlax-get sel 'text))
    886.   (vlax-release-object word)
    887. )
    889. ;;;=============================================================
    890. ;;; 获取局域网及公网地址和从网站获取信息                        
    891. ;;; Get your  (IP) (local IP and  internet IP)            
    892. ;;; An example shows how to Get your IP and get text from an URL
    893. ;;;=============================================================
    894. ;;;方式1
    895. (defun c:getIP()
    896.   (setq ws (vlax-create-object "MSWinsock.Winsock"))          ;winsock object
    897.   (princ "\nYour IP is:")
    898.   (princ (vlax-get ws 'LocalIP))                ;Local IP
    899.   (vlax-put ws 'Protocol 0)
    900.   (vlax-put ws 'RemoteHost "www.baidu.com")
    901.   (vlax-put ws 'RemotePort 80)
    902.   (vlax-invoke ws 'connect)
    903.   ;;(vlax-invoke ws 'connect "www.yhhe.net" 80)
    904.   (setq Url "http://www.baidu.com/img/baidu_logo.gif")
    905.   (setq Cmd (strcat "GET " url " HTTP/1.0\r\n\r\n"))
    906.   (vlax-invoke ws 'SendData cmd)
    907.   (vlax-get ws 'BytesReceived)
    908.   (setq data (vlax-make-variant ""))
    909.   (vlax-get ws 'state)
    910.   (vlax-invoke ws 'getdata data vlax-vbString)          ;???此处可能行不通
    911.   (vlax-invoke ws 'close)
    912.   (vlax-release-object ws)
    913.   (princ)
    914. )
    915. ;;;方式2
    916. (defun c:getIP1()
    917.   (setq ws (vlax-create-object "MSWinsock.Winsock"))
    918.   (princ "\n本机的地址为:")
    919.   (princ (vlax-get ws 'LocalIP))
    920.   (vlax-dump-object ws T)
    921.   (vlax-put ws 'Protocol 0)
    922.   (vlax-put ws 'RemoteHost "www.ecranesoft.com")
    923.   (vlax-put ws 'RemotePort 80)
    924.   (vlax-invoke ws 'connect)
    925.   ;;(vlax-invoke ws 'connect "www.yhhe.net" 80)
    926.   (setq Url "http://www.ecranesoft.com/ape/book/fap/big5/pl/comx/winsock.html")
    927.   (setq Cmd (strcat "GET " url " HTTP/1.0\r\n\r\n"))
    928.   (vlax-invoke ws 'SendData cmd)
    929.   (vlax-get ws 'BytesReceived)
    930.   (setq data (vlax-make-variant vlax-vbString))
    931.   (vlax-get ws 'state)
    932.   (vlax-invoke ws 'getdata data vlax-vbString)  ;;???
    933.   (vlax-invoke ws 'close)
    934.   (vlax-release-object ws)
    935.   (princ)
    936. )
    938. ;;;方式3
    939. (defun C:getIp2 (/ path http url web objXML file str s1 s2)
    940.   (setq path (strcat (getSpecialPath 1) "\\msxml6.dll"))
    941.   (if (not xc-NODE_TEXT)
    942.     (vlax-import-type-library
    943.       :tlb-filename  path
    944.       :methods-prefix "xm-"
    945.       :properties-prefix "xp-"
    946.       :constants-prefix "xc-"
    947.     )
    948.   )
    950.   (setq http (vlax-create-object "Msxml2.XMLHTTP"))        ;Microsoft.XMLHTTP or MSXML2.ServerXMLHTTP
    951.   (setq url "http://iframe.ip138.com/ic.asp")             ;the link of URL 链接地址
    952.   (xm-open http "GET" url :vlax-false)                ;the open method 打开方式
    953.   (xm-send http)
    955.   (command "delay" 2000)                    ;暂停两秒，等待从网站返回信息
    956.   (setq str (xp-get-responseText http))                ;get text from URL从地址中获取文本
    957.   (setq s1  (vl-string-position (ascii "[") str))
    958.   (setq s2  (vl-string-position (ascii "]") str))
    959.   (princ "\nYour IP Address is：")
    960.   (princ (substr str (+ s1 2) (- s2 s1 1)))
    961.   (vlax-release-object http)
    963.   ;;Get text from a Link
    964.   (setq web (getstring "\nPlease enter URL:"))
    965.   (setq objXML (vlax-create-object "MSXML2.ServerXMLHTTP"))
    966.   (xm-open objXML "GET" web :vlax-false)
    967.   (xm-send objXML)
    968.   (setq str (XP-GET-RESPONSETEXT objXML))
    970.   ;;(xp-get-responseXML http)
    971.   ;;(xp-get-responseStream http)
    972.   ;;(xp-get-responseBody http)
    973.   (setq file (vl-filename-mktemp "c:\\1.html"))
    974.   (setq file (open file "W"))
    975.   (princ str file)
    976.   (close file)
    977.   (vlax-release-object objXML)
    978.   (princ)
    979. )
    982. ;;;=============================================================
    983. ;;;Speak out your words. 让计算机开口说话，朗读文本之类         
    984. ;;;=============================================================
    985. (defun c:voice(/ objTTS)
    986.   (setq objTTS (vlax-create-object "SAPI.SpVoice"))
    987.   (vlax-invoke objTTS 'speak "Hello,Welcome to China!")
    988.   (vlax-release-object objTTS)
    989.   (princ)
    990. )
    992. ;;;=============================================================
    993. ;;Get the screen size of your IE window 获取屏幕分辨率          
    994. ;;;=============================================================
    995. (defun C:getscreenRes(/ IE screen)
    996.   (setq IE (vlax-create-object "InternetExplorer.Application"))
    997.   (vlax-invoke IE 'navigate "about:blank")
    998.   (setq screen (vlax-get (vlax-get (vlax-get ie 'Document) 'parentWindow) 'screen))
    999.   (princ (vlax-get screen 'height))
    1000.   (princ (vlax-get screen 'width))
    1001.   (vlax-release-object IE)
    1002.   (princ)
    1003. )
    1006. ;;;=============================================================
    1007. ;;; 利用ADOBE读写二进制文件                                     
    1008. ;;;=============================================================
    1009. (defun c:test (/ ARRAY BIN DAT DATA F L PATH S)
    1010.   ;;Read a Binary  file 
    1011.   (defun ReadBinary (FileName / stream arr)
    1012.     (setq stream (vlax-create-object "ADODB.Stream"))
    1013.     (vlax-put stream 'type 1)                         ;adTypeBinary
    1014.     (vlax-invoke stream 'open)                        ;adModeRead  =1 adModeWrite  =2 adModeReadWrite =3
    1015.     (vlax-invoke stream 'LoadFromFile filename)
    1016.     (setq Arr (vlax-invoke-method stream 'read (vlax-get stream 'SIZE)));read stream
    1017.     (vlax-invoke stream 'close)
    1018.     (vlax-release-object stream)
    1019.     (vlax-safearray->list (vlax-variant-value arr))            ;if a large size file ,it will take a long time in this step
    1020.   )
    1021.   ;;Write to a Binary  file from a text stream
    1022.   (defun WriteBinary (FileName Array / stream)
    1023.     (setq stream (vlax-create-object "ADODB.Stream"))
    1024.     (vlax-put stream 'type 1)                         ;adTypeBinary
    1025.     (vlax-invoke stream 'open)                        ;adModeRead  =1 adModeWrite  =2 adModeReadWrite =3
    1026.     (vlax-invoke-method stream 'Write array)                ;write stream
    1027.     (vlax-invoke stream 'saveToFile fileName 2)                ;save
    1028.     (vlax-invoke stream 'close)
    1029.     (vlax-release-object stream)
    1030.   )
    1032.   (setq path (getfiled "Please select a binary file:" "c:/" "" 8 ))     ;get file path
    1033.   (setq f (open "C:\\test.txt" "W"))
    1034.   (setq data (readBinary path))
    1035.   (princ data f)
    1036.   (close F)
    1038.   ;;(setq stream (vl-get-resource "test"))                              ;we can wrap this text file into .vlx file
    1039.   (setq f (open "C:\\test.txt" "R"))                                       ;open for read
    1040.   (setq l "")
    1041.   (while (setq s (read-line f))
    1042.     (setq l (strcat l s))
    1043.   )
    1044.   (setq array (read l))
    1045.   (close f)
    1047.   (setq dat (vlax-make-safearray 17 (cons 0 (1- (length array)))))         ;17 for unsigned char
    1048.   (vlax-safearray-fill dat array)
    1049.   (setq bin (vlax-make-variant dat))
    1050.   (writeBinary "C:\\test.jpg" bin)                    ;write binary file.
    1051. )
    1053. ;;;=============================================================
    1054. ;;; WIA图像控件的利用                                           
    1055. ;;;=============================================================
    1056. ;| 一下是VB的源码，可以参考
    1057. Sub WIA_ARGB()
    1058.     Dim Img        'As ImageFile
    1059.     Dim IP        'As ImageProcess
    1060.     Dim v        'As Vector
    1061.     Dim i        'As Long
    1062.     Set Img = CreateObject("WIA.ImageFile")
    1063.     Set IP = CreateObject("WIA.ImageProcess")
    1064.     Img.LoadFile r & "\1.jpg"
    1065.     Set v = Img.ARGBData
    1066.     For i = 1 To v.Count Step 300
    1067.         v(i) = &HFFFF00FF        'opaque pink (A=255,R=255,G=0,B=255)
    1068.     Next
    1069.     '使用指定的位元組更新影像位元組。
    1070.     IP.Filters.Add IP.FilterInfos("ARGB").FilterID
    1071.     Set IP.Filters(1).Properties("ARGBData") = v
    1072.     Set Img = IP.Apply(Img)
    1073.     Img.SaveFile r & "\2.jpg"
    1074.     UserForm1.Image1.Picture = LoadPicture(r & "\1.jpg")
    1075.     UserForm1.Image2.Picture = LoadPicture(r & "\2.jpg")
    1076.     Kill r & "\2.jpg"
    1077. End Sub
    1078. ;;|;
    1079. (defun c:img(/ path Img IPr vec cnt col old val fil i new)
    1080.   (setq path (strcat (getSpecialPath 1) "\\wiaaut.dll"))
    1081.   (if (not ic-actionEvent)
    1082.     (vlax-import-type-library
    1083.       :tlb-filename  path
    1084.       :methods-prefix "im-"
    1085.       :properties-prefix "ip-"
    1086.       :constants-prefix "ic-"
    1087.     )
    1088.   )
    1089.   (setq Img (vlax-create-object "WIA.ImageFile"))
    1090.   (setq IPr  (vlax-create-object "WIA.ImageProcess"))
    1091.   (im-loadfile Img "C:\\1.bmp")
    1092.   (setq vec (ip-get-ARGBData Img))
    1093.   (setq cnt (ip-get-count vec))
    1094.   (setq col (vlax-make-variant -2147418367))             ;-2147418368 &HFFFF00FF
    1095.                                   ;'opaque pink (A=255,R=255,G=0,B=255)
    1096.   (setq i 1)
    1097.   (repeat (/ cnt 3)
    1098.     (setq old (ip-get-item vec i))
    1099.     (setq val (vlax-variant-value old))
    1100.     (setq val (- val))
    1101.     (ip-put-item vec i val)                      ;4294967295
    1102.     (setq i (+ i 3))
    1103.   )
    1104.   (setq fil (ip-get-Filters IPr))
    1105.   (im-add fil (ip-get-filterID (ip-get-item (ip-get-filterinfos IPr) "ARGB")) 0)
    1106.   (ip-put-value (ip-get-item (ip-get-Properties (ip-get-item fil 1)) "ARGBData") vec)
    1107.   (setq new (im-apply  IPr Img))
    1108.   (im-savefile new "C:\\2.bmp")
    1110.   (vlax-release-object Img)
    1111.   (vlax-release-object IPr)
    1112.   (vlax-release-object vec)
    1113.   (vlax-release-object fil)
    1114.   (vlax-release-object new)
    1115. )
    1117. ;;;=============================================================
    1118. ;;; Scriptlet.TypeLib的利用                                     
    1119. ;;;=============================================================
    1120. ;;;Generate a GUID
    1121. (defun C:GUID (/ objSLTL str)
    1122.   (setq objSLTL (vlax-create-object "Scriptlet.TypeLib"))
    1123.   (setq str (vlax-get objSLTL 'GUID))
    1124.   (vlax-release-object objSLTL)
    1125.   str
    1126. )
    1128. ;;;=============================================================
    1129. ;;; XML的利用                                                   
    1130. ;;;=============================================================
    1131. (defun c:xml()
    1132.   (setq path (strcat (getSpecialPath 1) "\\msxml6.dll"))     ;;msxml3.dll
    1133.   (if (not xc-NODE_TEXT)
    1134.     (vlax-import-type-library
    1135.       :tlb-filename  path
    1136.       :methods-prefix "xm-"
    1137.       :properties-prefix "xp-"
    1138.       :constants-prefix "xc-"
    1139.     )
    1140.   )
    1142.   (setq path (strcat (getSpecialPath 1) "\\msadodc.ocx"))     ;;msadox.dll
    1143.   (if (not dc-ad3DBevel)
    1144.     (vlax-import-type-library
    1145.       :tlb-filename  path
    1146.       :methods-prefix "dm-"
    1147.       :properties-prefix "dp-"
    1148.       :constants-prefix "dc-"
    1149.     )
    1150.   )
    1151.   (findfile "msado15.dll")
    1152.   (if (not kc-adAddNew)
    1153.     (vlax-import-type-library
    1154.       :tlb-filename  "C:\\Program Files\\Common Files\\System\\ado\\msado15.dll"
    1155.       :methods-prefix "km-"
    1156.       :properties-prefix "kp-"
    1157.       :constants-prefix "kc-"
    1158.     )
    1159.   )
    1160. )
    1162. (defun c:xml()
    1163.   (setq wsMan (vlax-create-object "Wsman.Automation"))
    1164.   (setq xmlFile (vlax-create-object "MSxml.DOMDocument"))
    1165.   (setq session (vlax-invoke wsMan 'CreateSession))
    1166.   (setq response (vlax-invoke session 'Get "http://schemas.microsoft.com/wbem/wsman/1/wmi/root/cimv2/Win32_Service?Name=Spooler"))
    1167.   (vlax-invoke xmlFile 'LoadXML response)
    1168.   (vlax-invoke xmlfile 'save "C:/rawoutput.xml")
    1169.   (vlax-release-object session)
    1170.   (vlax-release-object xmlfile)
    1171.   (vlax-release-object wsMan)
    1172. )
    1174. ;;;=============================================================
    1175. ;;; 获取外网地址--正则表达式和ServerXMLHTTP的综合运用           
    1176. ;;;=============================================================
    1177. (defun C:GetIP (/ htt regexp text mathes address item0)
    1178.   (setq Http (vlax-create-object "Msxml2.ServerXMLHTTP"))
    1179.   (vlax-invoke-method http 'open "GET" "http://iframe.ip138.com/ic.asp")
    1180.   (vlax-invoke-method http 'send)
    1181.   (setq text (vlax-get-property http 'responseText))
    1183.   (setq RegExp (vlax-create-object "VBScript.RegExp"))
    1184.   (vlax-put-property  RegExp 'pattern "((?:(?:25[0-5]|2[0-4]\\d|[01]?\\d?\\d)\\.){3}(?:25[0-5]|2[0-4]\\d|[01]?\\d?\\d))")
    1185.   (vlax-put-property  RegExp 'IgnoreCase 1)
    1186.   (vlax-put-property  RegExp 'Global 1)
    1187.   (setq matches (vlax-invoke-method RegExp 'Execute text))
    1188.   (setq item0   (vlax-get-property matches 'item 0))
    1189.   (setq Address (vlax-get-property item0 'value))
    1190.   (vlax-release-object item0)
    1191.   (vlax-release-object matches)
    1192.   (vlax-release-object regexp)
    1193.   (vlax-release-object http)
    1194.   (alert (strcat "你的IP地址是:" address))
    1195.   (princ)
    1196. )
    1198. ;;;=============================================================
    1199. ;;; 其他控件的利用                                              
    1200. ;;;=============================================================
    1202. ;;; ADO Recordset对象用于容纳一个来自数据库表的记录集。         
    1203. ;;; 一个Recordset对象由记录和列（字段）组成。在 ADO 中，此对象是
    1204. ;;; 最重要且最常用于对数据库的数据进行操作的对象。              
    1205. (defun c:kk(/ rr)
    1206.   (setq rs (vlax-create-object "Adodb.recordset"))
    1207.   (vlax-dump-object rs T)
    1208.   (vlax-release-object rs)
    1209.   (princ)
    1210. )
    1212. ;;;  利用DOS控制台做些事情,譬如列举文件目录到某个文本文件，等等.
    1213. (defun C:Cout(/ wsh exe)
    1214.   (setq wsh (vlax-create-object "WScript.shell"))
    1215.   (setq exe (vlax-invoke wsh 'exec "ipconfig"))
    1216.   (wm-run wsh "cmd.exe /C dir c:\\temp\\*.* /a /s >>c:\\1.txt")
    1217.   (alert (vlax-invoke (vlax-get exe 'stdout) 'readAll))
    1218.   (setq exe (wm-exec wsh "cmd.exe /C dir c:\\temp\\*.* /a /s"))
    1219.   (princ (vlax-invoke (vlax-get exe 'stdout) 'readAll))
    1220.   (vlax-release-object exe)
    1221.   (vlax-release-object wsh)
    1222. )
    1224. ;;;  一些综合应用.
    1225. (defun c:test()
    1226.   (setq path (strcat (GetSpecialPath 1) "\\vbscript.dll"))    ;"\\Wscript.exe"
    1227.   (if (not RM-abs)
    1228.     (vlax-import-type-library
    1229.       :tlb-filename         path
    1230.       :methods-prefix         "Rm-"
    1231.       :properties-prefix     "Rp-"
    1232.       :constants-prefix     "Rc-"
    1233.     )
    1234.   )
    1235.   (setq regExp (vlax-create-object "Vbscript.RegExp"))
    1236.   (setq wsh (vlax-create-object "wscript.shell"))
    1237.   (setq scr (vlax-create-object "ScriptControl"))
    1238.   (vlax-put scr 'language "VBS")
    1239.   (vlax-make-variant 1)
    1240.   (vlax-create-object "vbscript.GlobalObj") 
    1241.   (rm-abs (vlax-make-variant 1) -1)
    1242.   (rm-inputbox  scr "Dim x As VBScript_Global.GlobalObj")
    1243.   (SM-EXECUTESTATEMENT scr "Function sss()
    1244.                             Dim x As new VBScript_Global.GlobalObj
    1245.                             end Function")
    1247.   (princ (readStream "C:\\delete.dcl" T))
    1248.   (vlax-release-object regExp)
    1249. )
    1251. ;;;FireWall等等控件均可测试。
    1252. (defun FHQ()
    1253.   ;;(vlax-create-object "ToolsObject.TelnetTool")
    1254.   ;;(vlax-create-object "RCBdyCtl.Setting")
    1255.   (setq fwObj (vlax-create-object "HNetCfg.FwMgr"))
    1256. )