For those of you that have a dcl file to include with a lisp offering,
this method eliminates the need for two files and assures it is placed
in the ACAD search path.
A subroutine is needed to create the dcl file when the main lisp is
run for the first time. That is what this routine does.
Run the Dcl2Lisp routine on the dcl file you want to include and it
will create a new file called YourName-dcl.lsp where "YourName" is
the name of the original dcl file. Then copy the contents of the new
lisp file into the main lisp routine.
Add a call to the new function like this ( create_dcl "YourName" )
If the dcl file exist the routine returns, If the file is not found
it creates the needed dcl file in the same directory where ACAD.PAT
if found, usually /SUPPORT/
If the needed dcl file is deleted by mistake the lisp routine will
create another one.
CAB
;;; Dcl2Lisp.lsp by Charles Alan Butler
;;; Copyright 2004
;;; by Precision Drafting & Design All Rights Reserved.
;;; Contact at TheSwamp.org
;;;
;;; Version 1.0 Beta April 24, 2004
;;; Version 1.1 Beta June 25, 2004
;;; Formatting Bug fix
;;; Version 1.2 Beta July 4, 2004
;;; Added code to detect a Revision flag & overwrite the DCl
;;; file if different
;;;
;;; DESCRIPTION
;;; This routine creates the function that will create a dcl file
;;; if the dcl file is not found. You select the original dcl file
;;; and this routine writes a new file containing the lisp routine
;;; needed to create the dcl file.
;;; I think that confused me! :)
;;; Creates the lisp file in the same directory as the dcl file
;;; was found. The Lisp file created will create the dcl file in
;;; the same directory as ACAD.PAT is located.
;;;
;;; Limitations : Unknown at this time
;;;
;;; Command Line Usage to create the lisp
;;; Command: Dcl2Lisp
;;;
;;; To call the new routine you may use something like this:
;;;
;|
;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;; Check the Dialog Box
(setq dclfile "<file name>.dcl")
(cond
((not (create_dcl dclfile)) ; check version
(alert (strcat "Cannot find " dclfile))
)
((< (setq dcl# (load_dialog dclfile)) 0) ; Error
(prompt (strcat "\nCannot load " dclfile "."))
)
((not (new_dialog "<your dcl name>" dcl#)) ; Error
(prompt (strcat "\nProblem with " dclfile "."))
)
;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
(t ; No DCL problems: ok to fire it up
;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;;
;; run your DCL routine now
;;
)
) ; end cond stmt
;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|;
;;;
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED
;;; WARRANTY. ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR
;;; PURPOSE AND OF MERCHANTABILITY ARE HEREBY DISCLAIMED.
;;; ;
;;; You are hereby granted permission to use, copy and modify this ;
;;; software without charge, provided you do so exclusively for ;
;;; your own use or for use by others in your organization in the ;
;;; performance of their normal duties, and provided further that ;
;;; the above copyright notice appears in all copies and both that ;
;;; copyright notice and the limited warranty and restricted rights ;
;;; notice below appear in all supporting documentation. ;
;;; You must contact me if you want to use it commercially ;
(defun c:Dcl2Lisp (/ files fn fname dlist ln newln x)
;; User pick DCL source file w/ path
(setq files (getfiled "Select the DCL source file:" "" "dcl" 0))
(if files
(progn
;; Create Destination file name "SourceName-dcl.lsp"
(setq fname (strcat
(substr files 1 (- (strlen files) 4)) "-dcl.lsp")
)
;; Create a Revision Flag Using current Date & Time
(setq tmp (rtos (getvar 'cdate) 2 4)
rvprefix "// Revision Control ")
(setq rvflag (strcat rvprefix
(substr tmp 5 2) "/" (substr tmp 7 2) "/"
(substr tmp 1 4) "@" (substr tmp 10 2) ":"
(substr tmp 12 2)
)
)
;; Create the detination file in same
;; directory as the DCL source file
(setq fn (open fname "w"))
;; Open the source file
(setq files (open files "r"))
;; Write header to destination file
(setq dlist
(list
";; ***************************************************"
";; create_dcl function to create a dcl support "
";; file if it does not exist "
";; Usage : (create_dcl \"file name\") "
";; Returns : T if successful else nil "
";; ***************************************************"
"(defun create_dcl (fname / acadfn dcl-rev-check)"
" ;;======================================="
" ;; check revision date Routine "
" ;;======================================="
" (defun dcl-rev-check (fn / rvdate ln lp)"
" ;; revision flag must match exactly and must"
" ;; begin with //"
(strcat " (setq rvflag \"" rvFlag "\" )" )
" (if (setq fn (findfile fn))"
" (progn ; check rev date"
" (setq lp 5) ; read 4 lines"
" (setq fn (open fn \"r\")) ; open file for reading"
" (while (> (setq lp (1- lp)) 0)"
" (setq ln (read-line fn)) ; get a line from file"
" (if (vl-string-search rvflag ln)"
" (setq lp 0)"
" )"
" )"
" (close fn) ; close the open file handle"
" (if (= lp -1)"
" nil ; no new dcl needed"
" t ; flag to create new file"
" )"
" )"
" t ; flag to create new file"
" )"
" )"
" (if (null(wcmatch (strcase fname) \"*`.DCL\"))"
" (setq fname (strcat fname \".DCL\"))"
" )"
" (if (dcl-rev-check fname)"
" ;; create dcl file in same directory as ACAD.PAT "
" (progn"
" (setq acadfn (findfile \"ACAD.PAT\")"
" fn (strcat (substr acadfn 1 (- (strlen acadfn) 8))fname)"
" fn (open fn \"w\")"
" )"
" (foreach x (list"
" \"// WARNING file will be recreated if you change the next line\""
" rvflag"
) ; end list
) ; end setq
;; Wright the Header
(foreach x dlist (princ x fn) (write-line "" fn))
;; Add DCL file to output file
;; Loop, reading source, writting to destination file
(while (setq ln (read-line files)) ; get a line from file
(cond
((or (vl-string-search rvprefix ln); found a revision flag
(vl-string-search "// WARNING file" ln); found Warning Line
)
(setq ln nil) ; delete it
) ; end cond
((vl-string-search "\"" ln); found a quote char
;; Add backslash to hide quotes
(setq ln (vl-string->list ln)
newln nil
)
(foreach x ln
(if (= x 34)(setq newln (cons 92 newln)))
(setq newln (cons x newln))
) ; end foreach
(setq ln (vl-list->string (reverse newln)))
) ; end cond
) ; end cond stmt
(if ln
(progn
;; add line to output file
(princ (strcat " \"" ln "\"") fn)
(write-line "" fn) ; add CR
)
)
) ; end while
;; Create the footer code in a list
(setq dlist
'(" ) ; endlist"
" (princ x fn)"
" (write-line \"\" fn)"
" ) ; end foreach"
" (close fn)"
" (setq acadfn nil)"
" (alert (strcat \"\\nDCL file created, please restart the routine\""
" \"\\n again if an error occures.\"))"
" t ; return True, file created"
" )"
" t ; return True, file found"
" )"
") ; end defun"
) ; end list
) ; end setq
;; Write footer to destination file
(foreach x dlist (princ x fn) (write-line "" fn))
;; Close source & Destination files
(close fn)
(close files)
(prompt (strcat "\nFile Created --> " fname))
) ; end progn
(prompt "\n***-- User Quit --***")
) ; endif FileS
(princ)
) ; end defun
(prompt "\n***-- Dcl2Lisp loaded, Enter Dcl2Lisp to run. --***")
(princ)
;; End Of File
