Internet news reader

Hi Folks,

As proof of concept for a work related task I put together a quick and dirty internet news reader

Currently set for reddit.com (Hope this isn't break ToA). Basically It creates a list of the current front page articles

press ctrl + click on text to follow link.

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

Any feedback would be great

Cheers.

Nice idea Ollie!

I haven't used the XMLHttpRequest Object before, but upon reading up on its documentation - it looks quite useful.

I haven't got VBA on my system as yet, so the call to DoEvents would fail - but I can see the coding intent - nice ideas.

Lee

Cool idea.

Lee, I've lost my links for the VBScript info, would you be so kind as to share?

Ollie, I would be inclined to add an error handler to the function, to release the XML and RegEx Objects should anything go wrong

Everything you could want and more...

Thank you

Ollie, I would be inclined to add an error handler to the function, to release the XML and RegEx Objects should anything go wrong

100% agree

Ollie, I would be inclined to add an error handler to the function, to release the XML and RegEx Objects should anything go wrong

I agree Lee. This was originally only meant as a proof of concept but now that I've had a bit of a play with it I reckon it's necessary to expand

Hi Ollie,

You inspired me to create a news reader of my own - using the UK BBC News feed

My thanks to VovKa for use of his XML functions

Coding isn't too pretty though

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

Quickie using Lee's methods...

Sadly, it seems you have to do a bit of legwork based on which RSS you want to read.

(defun c:RSS (/ url Data RSS Items link)
 [color=Red];; © Lee Mac  ~  07.06.10 (modified by Alan J. Thompson)[/color]
 (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
                     )
              )
              (setq link (dos_popupmenu (mapcar 'car Items)))
         )
       (command "_.browser" (cadr (nth link Items)))
     )
   )
 )
 (princ)
)



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

You could've left my name on it lol

You could've left my name on it lol

Fixed.

I hope you don't think I was claiming any kind of ownership.

No worries

Shame you couldn't easily strip out the two pieces of text one wants in a generic manner.

Yeah, I was thinking when I was writing it that there must be a better way to do it

Yeah, I was thinking when I was writing it that there must be a better way to do it

I'm sure there is and if I had a use for something like this, I might consider making an attempt. I only wanted to show an example of not using text (which is why I used the bulk of your code). I'll happily stick with the Google reader.

I have no use for it either - but I get easily addicted to learning new things...

I have no use for it either - but I get easily addicted to learning new things...

;Lee Mac 7.6.10 
;Space declaration statement

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

Nice touch Lee; few things are as elegant as well planned lisp

Thanks Ollie

...

Nice touch Lee; few things are as elegant as well planned lisp

LoL:lol: