[编程交流] 互联网新闻阅读器

(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 [i]
   (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)))
 )
)

(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))