互联网新闻阅读器
大家好，作为与工作相关任务的概念证明，我制作了一个快速而肮脏的互联网新闻阅读器
当前设置为reddit。com（希望这不是中断ToA）。基本上，它创建了当前头版文章的列表
按ctrl键并单击文本以跟随链接。
(defun c:reddit( / http regex url results title match i)
(setq results (list))
(setq url "http://www.reddit.com")
;xmlHTTP Object------
;Create xmlHTTP object
(setq http (vlax-create-object "MSXML2.XMLHTTP"))
;invoke open connection
(vlax-invoke-method http 'open "GET" (strcat url "/") :vlax-true)
;Attempt to estatblish connection
(if (vl-catch-all-error-p(vl-catch-all-apply 'vlax-invoke (list http 'send)))
;On fail
(princ "\nfail")
;On successful connect
(while (not (eq (vlax-get http 'readystate) 4))
;capture events
(vla-eval (vlax-get-acad-object) "DoEvents")
)
)
;Get response text
(setq text (vlax-get-property http 'responsetext))
;REGEX OBJECT -------
;Create regexp
(setq regex (vlax-create-object "vbscript.regexp"))
;Set regex properties
(vlax-put-property regex 'global :vlax-true)
(vlax-put-property regex 'IgnoreCase :vlax-true)
(vlax-put-property regex 'multiline :vlax-true)
;Compile regex pattern
(vlax-put-property regex 'pattern "<a (class=\"title \" target="_blank" href=\"[^>]*\")+ >(.*?)(</a>)+?") ; Article link pattern
;Carry out match
(setq matches (vlax-invoke-method regex 'execute text))
;With every match
(setq i -1)
(while(< (setq i (1+ i)) (vlax-get-property matches 'count))
;Get result
(setq match(vlax-get-property(vlax-get-property matches 'item i) 'value))
;Get hyperlink title
(vlax-put-property regex 'pattern ">(.*?)<")
(setq title (vlax-get-property
(vlax-get-property
(vlax-invoke-method regex 'execute match) 'item 0) 'value))
(setq title (substr title 2 (-(strlen title) 2)))
;Get hyperlink path
(vlax-put-property regex 'pattern "href=\"([^>\"]*)(\"+)")
(setq hlink (vlax-get-property
(vlax-get-property
(vlax-invoke-method regex 'execute match) 'item 0) 'value))
(setq hlink (substr hlink 7 (-(strlen hlink) 7)))
(if(= (substr hlink 1 1) "/")
(setq hlink (strcat url hlink))
)
(setq results (append results(list (list title hlink))))
)
(createLinks results)
(vlax-release-object regex)
(vlax-release-object http)
)
(defun createLinks(results / )
(setq mspace (vla-get-modelspace
(vla-get-activedocument
(vlax-get-acad-object))))
(setq i 0)
(setq y -300.0)
(while (< (setq i (1+ i)) (length results))
(setq text (vla-addtext mspace
(car (nth i results))
(vlax-3d-point 0.0 (* y i) 0.0) 200.0))
(setq hlinks (vla-get-hyperlinks text))
(vla-add hlinks (cadr (nth i results)))
)
)
快速使用李的方法。。。
可悲的是，似乎你必须根据你想要阅读的RSS做一些准备工作。
(defun c:news ( / *error* spc url Data RSS Items )
;; © Lee Mac~07.06.10
(defun *error* ( msg )
(and Doc (not (vlax-object-released-p Doc)) (vlax-release-object Doc))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(princ)
)
(setq spc
(if
(or
(eq AcModelSpace
(vla-get-ActiveSpace
(setq doc
(vla-get-ActiveDocument
(vlax-get-acad-object)
)
)
)
)
(eq :vlax-true (vla-get-MSpace doc))
)
(vla-get-ModelSpace doc)
(vla-get-PaperSpace doc)
)
)
(setq url "http://newsrss.bbc.co.uk/rss/newsonline_uk_edition/front_page/rss.xml")
(if (setq Data (VK_ReadXML url))
(progn
(setq RSS (caddr (car (caddr (caddr Data)))))
(setq Items (RemoveTilFoo (lambda ( x ) (eq "item" (strcase (car x) t))) RSS))
(if (and (setq Items (mapcar 'caddr Items))
(setq Items (SubList Items 0 10))
(setq Items
(mapcar
(function
(lambda ( x )
(list (caddr (car x)) (caddr (caddr x)))
)
)
Items
)
)
)
(
(lambda ( i )
(foreach x Items
(setq tx
(AddText spc (strcat (chr 149) "" (car x))
(polar '(0. 0. 0.)
(/ (* 3 pi) 2.) (* 1.5 (setq i (1+ i)) (getvar 'TextSize))
)
(getvar 'TextSize)
)
)
(vla-put-color tx acYellow)
(vla-Add (vla-get-Hyperlinks tx) (cadr x))
)
(vla-ZoomExtents (vlax-get-acad-object))
)
-1
)
)
)
)
)
(defun AddText ( space str pt hgt )
(vla-AddText space str (vlax-3D-point pt) hgt)
)
(defun RemoveTilFoo ( foo lst )
;; © Lee Mac~07.06.10
(while (and lst (not (foo (car lst))))
(setq lst (cdr lst))
)
lst
)
(defun SubList ( lst start len )
;; © Lee Mac~07.06.10
(if lst
(if (< 0 start)
(SubList (cdr lst) (1- start) len)
(if (< 0 len)
(cons (car lst)
(SubList (cdr lst) start (1- len))
)
)
)
)
)
;; .....................................................................;;
;; -- VovKa's XML Functions -- ;;
;; .....................................................................;;
(defun vk_XMLGetAttributes (Node / Attributes Attribute OutList)
(if (setq Attributes (vlax-get Node "attributes"))
(progn (while (setq Attribute (vlax-invoke Attributes "nextNode"))
(setq OutList (cons (cons (vlax-get Attribute "nodeName")
(vlax-get Attribute "nodeValue")
)
OutList
)
)
(vlax-release-object Attribute)
)
(vlax-release-object Attributes)
(reverse OutList)
)
)
)
;;;(vk_XMLGetAttributes Node)
(defun vk_XMLGetchildNodes (Node /)
(if Node
(if (= (vlax-get Node "nodeType") 3)
(vlax-get Node "nodeValue")
(append (list
(list (vlax-get Node "nodeName")
(vk_XMLGetAttributes Node)
(vk_XMLGetchildNodes (vlax-get Node "firstChild"))
)
)
(vk_XMLGetchildNodes (vlax-get Node "nextSibling"))
)
)
)
)
;;;(vk_XMLGetchildNodes Node)
(defun vk_ReadXML (FileName / Doc OutList *error*)
(if (and FileName
;;; (setq FileName (findfile FileName))
(setq Doc (vlax-create-object "MSXML.DOMDocument"))
(not (vlax-put Doc "async" 0))
(if (= (vlax-invoke Doc "load" FileName) -1)
t
(prompt
(strcat "\nError: "
(vlax-get (vlax-get Doc "parseError") "reason")
)
)
)
(= (vlax-get Doc "readyState") 4)
)
(setq OutList (vk_XMLGetchildNodes (vlax-get Doc "firstChild")))
)
(and Doc (vlax-release-object Doc))
(gc)
OutList
)
;;;(vk_ReadXML (getfiled "" "" "xml" 16)) 你本可以在上面留下我的名字的哈哈 固定的
我希望你不要认为我在要求任何所有权。 别担心 遗憾的是，你不能以一种通用的方式轻松地去掉你想要的两段文字。 是的，我写这篇文章的时候在想，一定有更好的方法 我肯定有，如果我用过这样的东西，我可能会考虑尝试一下。我只想展示一个不使用文本的示例（这就是我使用大部分代码的原因）。我很乐意继续使用谷歌阅读器。 我也没有用-但我很容易沉迷于学习新事物。。。 同上，但很难证明在工作时为随机的东西编码是合理的。
页:
[1]
2