ollie Posted June 7, 2010 Share Posted June 7, 2010 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. Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted June 7, 2010 Share Posted June 7, 2010 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 Quote Link to comment Share on other sites More sharing options...
alanjt Posted June 7, 2010 Share Posted June 7, 2010 Cool idea. Lee, I've lost my links for the VBScript info, would you be so kind as to share? Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted June 7, 2010 Share Posted June 7, 2010 Everything you could want and more... Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted June 7, 2010 Share Posted June 7, 2010 Ollie, I would be inclined to add an error handler to the function, to release the XML and RegEx Objects should anything go wrong Quote Link to comment Share on other sites More sharing options...
alanjt Posted June 7, 2010 Share Posted June 7, 2010 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 Quote Link to comment Share on other sites More sharing options...
ollie Posted June 7, 2010 Author Share Posted June 7, 2010 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 Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted June 7, 2010 Share Posted June 7, 2010 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)) Quote Link to comment Share on other sites More sharing options...
alanjt Posted June 7, 2010 Share Posted June 7, 2010 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)) Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted June 7, 2010 Share Posted June 7, 2010 You could've left my name on it lol Quote Link to comment Share on other sites More sharing options...
alanjt Posted June 7, 2010 Share Posted June 7, 2010 You could've left my name on it lol Fixed. I hope you don't think I was claiming any kind of ownership. Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted June 7, 2010 Share Posted June 7, 2010 No worries Quote Link to comment Share on other sites More sharing options...
alanjt Posted June 7, 2010 Share Posted June 7, 2010 Shame you couldn't easily strip out the two pieces of text one wants in a generic manner. Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted June 7, 2010 Share Posted June 7, 2010 Yeah, I was thinking when I was writing it that there must be a better way to do it Quote Link to comment Share on other sites More sharing options...
alanjt Posted June 7, 2010 Share Posted June 7, 2010 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. Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted June 7, 2010 Share Posted June 7, 2010 I have no use for it either - but I get easily addicted to learning new things... Quote Link to comment Share on other sites More sharing options...
alanjt Posted June 7, 2010 Share Posted June 7, 2010 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. Quote Link to comment Share on other sites More sharing options...
ollie Posted June 8, 2010 Author Share Posted June 8, 2010 ;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 Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted June 8, 2010 Share Posted June 8, 2010 Thanks Ollie Quote Link to comment Share on other sites More sharing options...
alanjt Posted June 8, 2010 Share Posted June 8, 2010 ... Nice touch Lee; few things are as elegant as well planned lisp LoL:lol: Quote Link to comment Share on other sites More sharing options...
Recommended Posts
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.