google.lsp
最后修改时间: 08/29/2024 23:10:35
;;;=============================================================================
;;;CAD的搜索和浏览
;;;=============================================================================
(defun C:Google (/ DCL_FILE DCL_ID FAVORITES SCOPES)
(setq Dcl_File (Write_Dcl)) ;创建临时对话框文件
(setq dcl_id (load_dialog Dcl_File)) ;装入对话框文件(因为是动态，所以不必检查dcl_file)
(vl-file-delete Dcl_File) ;删除临时对话框文件
;;开始对话框操作
(new_dialog "google" dcl_id) ;因为是动态对话框，所以可以不检查dcl_id
(setq scopes (GetSearchScopes))
(start_list "Scopes")
(mapcar 'add_list (mapcar 'car scopes)) ;初始化搜索引擎列表
(end_list)
(setq favorites (GetFavorites))
(start_list "Favorites")
(mapcar 'add_list (mapcar 'vl-filename-base favorites)) ;初始化收藏夹列表
(end_list)
(start_dialog) ;开始对话框
(unload_dialog dcl_id) ;卸载对话框
(princ)
)
;;;=============================================================================
;;;获取搜索引擎列表
;;;暂时根据IE来获得列表。以后考虑增加其他浏览器的搜索引擎
;;;=============================================================================
(defun GetSearchScopes (/ key subkey scopes default)
(setq key "HKEY_CURRENT_USER\\Software\\Microsoft\\Internet Explorer\\SearchScopes\\")
(if (setq Scopes (vl-registry-descendents key))
(progn
(setq default (vl-registry-read key "DefaultScope"))
(vl-remove
nil ;有可能会出现虚假的项
(mapcar
(function
(lambda (scope / subkey name url)
(setq subkey (strcat key scope))
(setq name (vl-registry-read subkey "DisplayName")) ;引擎名
(setq url (vl-registry-read subkey "URL")) ;引擎地址
(if (and name url)
(cons name url)
)
)
)
(cons default (vl-remove default scopes)) ;确保第一个是默认搜索引擎
)
)
)
(list
(cons "Google" "http://www.google.com.hk/search?hl=zh-CN&q={searchTerms}");对不起，谷歌跑到香港了!
(cons "百度" "http://www.baidu.com/s?wd={searchTerms}") ;google经常被GFW，用百度是无奈之举
)
)
)
;;;=============================================================================
;;;获取默认浏览器
;;;=============================================================================
(defun GetDefaultBrowser (/ browser)
(setq Browser (vl-registry-read "HKEY_CLASSES_ROOT\\HTTP\\shell\\open\\command"))
(and (= (type browser) 'list) (setq browser (cdr browser)))
(setq browser (substr (strcat (vl-filename-directory Browser) "\\" (vl-filename-base Browser) ".exe") 2))
)
;;;=============================================================================
;;;启动指定的搜索引擎，并搜索
;;;=============================================================================
(defun GoogleIt (Scopes / Index Keywords scope url browser scopeName)
(setq Index (read (get_tile "Scopes")))
(setq keywords (get_tile "Keywords"))
(setq scope (nth Index scopes))
(setq url (vl-string-subst (notrailspace (noleadspace keywords)) "{searchTerms}" (cdr scope)))
(setq Browser (GetDefaultBrowser))
(setq scopeName (car scope))
(cond
( (= scopeName "百度")
(startapp browser (strcat "http://www.baidu.com/s?wd=" keywords)) ;很无奈!不然的话，对中文关键字搜索会有问题哦?
)
(t
(startapp browser url)
)
)
;(DONE_DIALOG)
)
;;;=============================================================================
;;;收藏夹中的地址列表
;;;=============================================================================
(defun GetFavorites (/ key Favorites lst favoritesPath)
;;Get a folder and all of its subfolders(recursively)
(defun GetSubFolder (path / l fso s)
(defun GetSubFolder1 (folder / p files path)
(setq files (vlax-get folder 'files))
(setq path (vlax-get folder 'path))
(if (/= (substr path (strlen path)) "\\")
(setq path (strcat path "\\"))
)
(vlax-for f files
(if (= (vlax-get f 'type) "Internet 快捷方式")
(setq s (cons (strcat path (vlax-get f 'name)) s))
)
)
(vlax-for subfolder (vlax-get folder 'SubFolders)
(setq p (vlax-get subfolder 'Path))
(setq l (cons p (GetSubFolder1 subFolder)))
)
l
)
(setq fso (vlax-create-object "Scripting.FileSystemObject"))
(setq l (list path))
(if (vlax-invoke fso 'folderExists path)
(setq l (reverse (getSubFolder1 (vlax-invoke fso 'getFolder path))))
(setq l nil)
)
(vlax-release-object fso)
(reverse s)
)
(setq key "HKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Explorer\\Shell Folders\\")
(setq favoritesPath (vl-registry-read key "Favorites"))
(setq lst (GetSubFolder favoritesPath))
)
;;;=============================================================================
;;;浏览收藏夹列表的指定项
;;;=============================================================================
(defun GotoFavorite (index favorites)
(startapp (GetDefaultBrowser) (nth (read index) favorites))
)
;;;=============================================================================
;;;临时生成Dcl文件 返回文件名
;;;=============================================================================
(defun Write_Dcl (/ Dcl_File file str)
(setq Dcl_File (vl-filename-mktemp nil nil ".DCL"))
(setq file (open Dcl_File "W"))
(foreach str (DialogData)
(write-line str file)
)
(close file)
Dcl_File
)
;;;=============================================================================
;;;对话框文件
;;;=============================================================================
(defun DialogData ()
(list "google : dialog"
"{"
"label = \"百谷鸟 :-)\";"
": column"
"{"
": row"
"{"
": text"
"{"
"label = \"搜索引擎: \";"
"}"
": popup_list"
"{"
"key = \"Scopes\";"
"width = 13.2;"
"fixed_width = true;"
"action = \"(setq scope (nth (read $value) Scopes))\";"
"}"
": text"
"{"
"label = \"收藏夹: \";"
"}"
": popup_list"
"{"
"key = \"Favorites\";"
"width = 40;"
"fixed_width = true;"
"action = \"(GotoFavorite $value favorites)\";"
"}"
"}"
": spacer { width = 1; }"
": row"
"{"
": text"
"{"
"label = \"关键字: \";"
"}"
": edit_box"
"{"
"key = \"Keywords\";"
"width = 65;"
"fixed_width = true;"
"}"
"}"
": spacer { width = 1; }"
"}"
": row"
"{"
": button {"
"label = \"去搜吧!\";"
"fixed_width = true;"
"is_default = true;"
"key = \"google_it\";"
"mnemonic = \"G\";"
"action = \"(googleit scopes)\";"
"allow_accept = true;"
"}"
": spacer { width = 1; }"
": button {"
"label = \"完成\";"
"is_cancel = true;"
"fixed_width = true;"
"width = 6;"
"}"
"}"
": text"
"{"
"label = \"Highflybird 版权所有，用于商业将追究!\";"
"alignment = centered;"
"}"
;"errtile;"
"}"
)
)
;;;remove leading spaces
(defun noleadspace (target_string / s)
(if (setq s target_string)
(while (= (substr s 1 1) " ")
(setq s (substr s 2))
) ;_ end while
) ;_ end if
s
)
;;;remove trailing spaces
(defun notrailspace (target_string / s)
(if (setq s target_string)
(while (and (/= s "") (= (substr s (strlen s)) " "))
(setq s (substr s 1 (1- (strlen s))))
) ;_ end while
) ;_ end if
s
)
;;;convert spaces in the target string to the plus symbol
(defun space_to_plus (target_string / s counter)
(setq counter 1)
(setq s target_string)
(repeat (strlen s)
(if (= (substr s counter 1) " ")
(setq s
(strcat (substr s 1 (1- counter))
"+"
(substr s (1+ counter))
)
)
) ;_ end if
(setq counter (1+ counter))
) ;_ end repeat
s
)
;;;=============================================================================
;;;关闭所有的浏览器进程
;;;=============================================================================
(defun C:GB()
(defun Close_All_IExplore (EXENAME / SWbemLocator WQL Service IEProcesses isClosed)
(setq SWbemLocator (vlax-create-object "WbemScripting.SWbemLocator"))
(setq Service (vlax-invoke SWbemLocator 'ConnectServer))
(setq WQL (strcat "SELECT * FROM Win32_Process WHERE Name='" ExeName ".EXE'" ))
(setq IEProcesses (vlax-invoke Service 'ExecQuery WQL))
(vlax-for IE IEProcesses
(vlax-invoke IE 'Terminate)
)
(vlax-release-object IEProcesses)
(vlax-release-object Service)
(vlax-release-object SWbemLocator)
)
(VL-CATCH-ALL-APPLY
'mapcar
(list 'Close_All_IExplore
(list "IEXPLORE" "360se" "360chrome" "chrome" "opera" "firefox") ;还有什么浏览器自己添加吧！
)
)
(princ)
)
No comments:
Post a Comment