回望南山
记忆痕迹可以鲜明, 回望往事如数家珍——
posts - 177,  comments - 54,  trackbacks - 0

Now we can set up a set of routines to access the FileSystemObject, ask it for the Drives, squeeze out every drive (not literally - you can build a beer-can holder from the CD drive on your own spare time) and read information on each.
Oh by the way, remember the WScript.Network object we accessed before? Why not include those pieces of information along with the drives:

(defun getDiskInfo (/ driveList)
;; first access the WScript.Network and find some
;; useful information
(cond ((setq wscript (vlax-create-object "WScript.Network"))
(setq pcname (vlax-get-property wscript "ComputerName")
pcdom  (vlax-get-property wscript "UserDomain")
pcuser (vlax-get-property wscript "UserName")
)
;; won't need wscript anymore, so release it
(vlax-release-object wscript)
;; then access the FileSystemObject and proceed if succesfull
(cond ((setq fso (vlax-create-object "Scripting.FilesystemObject"))
;; access the Drives collection
(setq drives (vlax-get-property fso 'Drives))
;; walk thru each drive while collecting information and
;; save each piece of information in a list
(vlax-for n drives
(setq driveList (cons (driveInfo n) driveList))
)
;; release objects in reversed sequence of creation
(vlax-release-object drives)
(vlax-release-object fso)
)
)
)
)
(list pcName pcDom pcUser driveList)
)
(defun driveInfo (driveObj / getProp)
;; each object given to this function represent one disk drive
;; first it checks if the property listed at the end of mapcar
;; is available. If so, it attempts to read the property, well
;; aware that it may fails - so we have to catch all errors on
;; the way. All properties that are not available is given a
;; value of nil
(mapcar
(function
(lambda (driveProp)
(cond ((vlax-property-available-p driveObj driveProp)
(if (not (vl-catch-all-error-p
(setq getProp (vl-catch-all-apply
'vlax-get-property
(list driveObj driveProp)
)
)
)
)
getProp
)
)
)
)
)
'(DriveLetter     Path       RootFolder  DriveType  FileSystem
VolumeName      ShareName  IsReady     TotalSize  FreeSpace
AvailableSpace
)
)
)

Running getDiskInfo should print out a list similar to this:

( "DOGA-B243060" "NATMUS" "smd"
(D D: #<VLA-OBJECT IFolder 0158f6b0> 2 NTFS   :vlax-true
#<variant 3 2138540032> #<variant 3 6432768> #<variant 3 6432768>)
(C C: #<VLA-OBJECT IFolder 09558648> 2 NTFS   :vlax-true #<variant 5 6983262208>
#<variant 3 2117730304> #<variant 3 2117730304>)
(A A: nil 1 nil nil  :vlax-false nil nil nil))

Here only three drives are shown (you may have more or less). The properties are in the sequence given by the list in defun driveInfo: DriveLetter, Path, RootFolder etc…
As can be seen from the output, the drive A: was not ready at the time of access, so almost all properties come out as nil. We have to take that into account when translating the values.
First let's build a routine to show a dialog box and get it ready before translating the values. We'll define it as a command because this will call all the other routines (including the translation routine that will follow next). For the DCL setup, look below this routine.

(defun C:DiskInfo ()
;; PUTINFO is a subroutine that will be called each
;; time a disk drive is selected in "drives" list_box
(defun putInfo (sublst)
(set_tile "drivetxt"
(apply
'strcat
(mapcar (function (lambda (prop val)
(strcat "\n" prop "\t" val))
)
'("Drive letter:   "         "Path:           "
"Root folder:    "         "Drive type:     "
"File system:    "         "Volume name:    "
"Shared name:    "         "Ready:          "
"Total space:    "         "Free space:     "
"Available space:"
)
sublst
)
)
)
)
;; get the driveList, translate the values to strings
;; and load the dialog file.
;; remember that the raw info holds three values from
;; WScript.Network in the first 3 places, so do a little
;; turning over to get at the last item which holds all
;; our drives in sublists
(setq info     (getdiskInfo)
diskInfo (mapcar 'VBTranslate (reverse (car (reverse info))))
dcl_id   (load_dialog "diskinfo.dcl")
)
;; here we just want to make sure that diskInfo holds only strings
;; so we apply a TYPE function to each element and checks if they
;; are all of type STR.
;; also, we won't proceed unless a new dialog can be loaded.
(cond
((and diskInfo
(apply '= (apply 'append
(mapcar (function (lambda (v) (mapcar 'type v)))
diskinfo)
)
)
(new_dialog "diskInfo" dcl_id)
)
;; setup a list with drive letters - they are the second item
;; in each sublist for each drive
(setq drives (mapcar '(lambda (n) (nth 1 n)) diskInfo))
;; fill out the drive letters
(start_list "drives")
(mapcar 'add_list drives)
(end_list)
;; fill out the information from WScript.Network
(mapcar 'set_tile '("pcname" "pcdom" "pcuser") info)
;; set action when clicking in list_box with drive letter
(action_tile "drives" "(putInfo (nth (atoi $value) diskInfo))")
;; run the show
(start_dialog)
)
)
(princ)
)
// Dialog contents for use with diskinfo.lsp
// diskinfo.dcl
diskInfo : dialog {
label = "DiskInfo";
width = 42;
: boxed_row {
label = "PC info";
: column {
: text { label = "PC name"; }
: text { label = "Domain"; }
: text { label = "User name"; }
}
: column {
: text { key = "pcname"; label = ""; }
: text { key = "pcdom"; label = ""; }
: text { key = "pcuser"; label = ""; }
}
}
: boxed_row {
label = "Drive info";
: column {
: list_box {
key = "drives";
label = "Drives";
}
}
}
: boxed_row {
label = "Details";
: text {
label = "";
key = "drivetxt";
fixed_height = true;
width = 42;
height = 13;
}
}
ok_button;
}

Now, to the last routine: to translate all values. It could look like this:

(defun VBTranslate (lst / tmp)
;; given a sublist from getDiskInfo, this routine will run
;; thru each item and attempt to translate it to a string
(mapcar (function
(lambda (n)
;; no need to run through this if n is a string
(if (= (type n) 'STR)
n
(cond
;; if n is nil then simply write a hyphen
((not n) "-")
;; if n is variant then get variant type. Because
;; some variant types are not supported, e.g.
;; OLEColor variant type 19, we'll check for valid
;; result.
((= (type n) 'VARIANT)
(if (not (vl-catch-all-error-p
(setq tmp (vl-catch-all-apply
'vlax-variant-value
(list n)
)
)
)
)
;; if the variant value of n is a number, we
;; have got a number of bytes on disk, so show
;; it in Kbytes and Gigabytes.
(if (numberp tmp)
(strcat (rtos (/ tmp 1024.0) 2 0)
" Kb ("
(rtos (/ tmp 1.07374e+009) 2 2)
" Gb)"
)
tmp
)
;; otherwise variant type is not supported
"Type not supported"
)
)
;; this can only be the iFolder object in FSO, so
;; we won't bother to check if Path is a valid
;; property. If the iFolder is not accessible, it
;; will already have been set to nil in
;; defun DRIVEINFO
((= (type n) 'VLA-OBJECT)
;; in FSO this is iFolder
(vlax-get-property n 'Path)
)
;; convert true/false to Yes/No clear text
((= n :vlax-true) "Yes")
((= n :vlax-false) "No")
;; this will most certainly hold the disk type value,
;; so look up it's enum value and convert to clear text
;; if, for some obscure reason, n is not an enum, just
;; convert number to text
((numberp n)
;; check if number is an integer
(cond ((zerop (rem n 1))
(nth n
'("Unknown"       "Removable"
"Fixed"         "Network drive"
"CD-ROM"        "RAM disk"
)
)
)
(T (rtos n))
)
)
;; n is nothing of the above - just return whatever
;; it evaluates to as a string
(T (vl-princ-to-string n))
)
)
)
)
lst
)
)

If no typos or any other error occurred during this séance, we should get a nice (well, me thinks it's very pretty) dialog like this:

Click away and enjoy. Ohh, and correct those nasty bugs that most certainly hid themselves while writing this. Don't know how? Have a look around the site and you are bound to find a tutor on debugging.

posted on 2008-03-29 20:45 深藏记忆 阅读(272) 评论(0)  编辑  收藏 所属分类: 舶来备忘转载Vlisp

飘过是缘,相识最真

订阅到抓虾
google reader
gougou


点击这里给我发消息


<2008年3月>
2425262728291
2345678
9101112131415
16171819202122
23242526272829
303112345

常用链接

留言簿(5)

随笔分类

随笔档案

文章分类

文章档案

相册

收藏夹

八面来息

天天充电

同行者

积分与排名

  • 积分 - 59540
  • 排名 - 62

最新评论

阅读排行榜

评论排行榜