Jump to content

Recommended Posts

Posted

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.

Posted

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

Posted

Cool idea. :thumbsup:

 

 

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

Posted

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

Posted
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

Posted

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

Posted

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

Posted
You could've left my name on it lol :roll:

Fixed.

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

Posted

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

Posted

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

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

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.

Posted

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

Posted
I have no use for it either - but I get easily addicted to learning new things...
Ditto, but it's hard to justify coding for random stuff when at work.:P
Posted

;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 :D

Posted

...

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

 

LoL:lol:

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...