GeoGIS

برنامه ای برای ایجاد هاشور سریع در نرم افزارهای اتودسک

ارسال توسط راستگو در تاریخ ۲۹ - اردیبهشت - ۱۳۹۳

در زیر برنامه‌ای بسیار کوچک برای ایجاد هاشور (Hatch) در سند نرم افزارهای اتودسک(اتوکد، لنددسکتاپ، سیویل تری دی)، قرار داده شده است. پس از نصب این فایل بسیار کوچک، کاربر می‌تواند به دو روش اقدام به ایجاد هاشور نماید:

۱- انتخاب حرف c چنانچه یک محدوده بسته برای ایجاد هاشور وجود داشته باشد، و کلیک در درون محدوده بسته.

۲- انتخاب حرف b چنانچه یک محدوده بسته وجود ندارد و می خواهید با ماوس یک محدوده بسته برای ایجاد هاشور معرفی کنید، و کلیک در درون محدوده بسته.

نکته : در این برنامه امکان معرفی زاویه خطوط هاشور و لایه ترسیم هاشور وجود دارد.

دوستانی که نحوه‌ی فراخوانی فایل‌های لیسپ (LISP) را در نرم‌افزار‌های اتودسک نمی‌دانند، برای رفتن به صفحه آموزش فراخوانی فایل‌های لیسپ (LISP) در نرم‌افزار‌های اتودسک اینجا کلیک کنند.

برای دستیابی به موارد بالا، ابتدا کدهای زیر را در یک فایل متن (مانند نوتپد “Notpad”، ورد “Word” و …) کپی کرده و در نهایت پسوند فایل را به lsp. تغییر دهید.

					;-=================================-;
					;-        Create quick Hatch       -;
					;-      (Option Hatch Angle)       -;
					;-   Tested on AutoCAD 2002-2014   -;
					;-           Written by            -;
					;-        Ebrahim Rastgou          -;
					;-         WWW.GeoGIS.ir           -;
					;-           05-02-14              -;
					;-=================================-;
(defun c:htc (/ *error*)
  (defun *error* (msg)
    (cond
      ((or (not msg)
	   (member msg
		   '("console break"
		     "function cancelled"
		     "quit / exit abort"
		    )
	   )
       )
      )
      ((princ (strcat "\nError: " msg)))
    )
    (cond (osm (setvar "osmode" osm)))
    (cond (clyr (setvar "clayer" clyr)))
    (cond (ccol (setvar "cecolor" ccol)))
    (cond (cpat (setvar "hpname" cpat)))
    (cond (hpas (setvar "hpassoc" hpas)))
    (cond (hang (setvar "hpang" hang)))
    (princ)
  )
    (while
		  (not
		    (mlml
		      (list (setq
			      Boundary-Closest (strcase
				   (getstring
				     nil
				     "\nSpecify boundary method introduced=> Boundary Create/Closest [b/c]: "
				   )
				 )
			    )
		      )
		      (list "B" "Boundary" "C" "Closest")
		    )
		  )			;  end not
		) ;_  end while

  ;; main part

  (setvar "cmdecho" 0)				  ; disable command line echo
  (setq osm (getvar "osmode"))			  ;store osnap settings
  (setq clyr (getvar "clayer"))			  ;store current layer
  (setq ccol (getvar "cecolor"))		  ; store current layer color
  (setq cpat (getvar "hpname"))                       ; store the hatch pattern
  (setq hpas (getvar "hpassoc"))                      ; store the hatch associativity
  (setq hang (getvar "hpang"))                          ; store the hatch angle
  (setvar "hpname" "ANSI31")                           ; set hatch pattern to ANSI31
  (setvar "hpassoc" 1)                                      ; set associativity

  (layer_set "hatch" "8" "Bylayer")	  ;create or set layer "hatch" current,
						  ;if this would not created before, then create them
						  ; 8 - is color index of this layer, change to you suit
  (setvar "osmode" 0)
  (setvar "cecolor" "bylayer")
  (setq ang (getreal "\nSpecify the hatch angle: "))
  (setvar "hpang" ang)						  ; specify a hatch angle
  (cond
    ((mlml (list Boundary-Closest) (list "B" "Boundary"))
     (setq pts (defpoints))			  ; get points
     (command "pline")
     (apply 'command pts)				  ; pass the point list in to command
     (command "c") ; add polyline
     (setq ip (getpoint "\nPick internal point: "))
     (command "-hatch" ip "")		  ; add hatch
     (*error* nil)
     )				  ; >>> this error trapping function means the following:
    ((mlml (list Boundary-Closest) (list "C" "Closest"))
     (setq ip (getpoint "\nPick internal point: "))
     (command "-hatch" ip "")		  ; add hatch
     (*error* nil)
     )
    )
;;;(setvar "cmdecho" 1); restore cmecho variable
;;;(setvar "osmode" osm); restore osnap settings 
;;;(setvar "clayer" clyr); restore current layer variable
;;;(setvar "cecolor" ccol); restore current layer color variable
;;;(setvar "hpname" cpat); restore default hatch pattern variable
;;;(setvar "hpassoc" hpas); restore default hatch associativity variable
  (princ)
)
(princ "\nStart with HTE to draw hatch")
(princ)
;--------------------------------------------------------------
(defun mlml (inSMLChar inSMLStri / returnVarMS toCheck chkWith)
  (setq returnVarMS nil)
  (if (and (= (type inSMLChar) 'LIST)
	   (= (type inSMLStri) 'LIST)
      )
    (progn
      (foreach toCheck inSMLStri
	(foreach chkWith inSMLChar
	  (if (eq toCheck chkWith)
	    (setq returnVarMS T)
	  )
	)
      )
    )					;/progn
  )
  returnVarMS
)
 ;; local function, return list of points, specified on screen
 ;Specify boundary method introduced: Create Boundary/Closest [b/c]: 
 ;
  (defun defpoints ()
    (setq lst nil)
    (setq loop T)
    (setq pt  (getpoint "\nDigitize a first point :")
	  lst (cons pt lst)
    )
    (while
      (setq pt
	     (getpoint "\nPick a next point or press Enter to end loop :"
		       pt
	     )
      )
       (if (null pt)
	 (setq loop nil)
       )
       (setq lst (cons pt lst))
    )
    (reverse lst)
  )
  ;; local function, to create layer
  (defun layer_set (lyr col ltp)
    (setvar "cmdecho" 0)
    (if	(tblsearch "layer" lyr)
      (command "._-layer" "t" lyr "u" lyr "on" lyr "s" lyr "")
      (command "._-layer" "m" lyr "c" col lyr "lt" ltp lyr "")
    )
  )

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

;-=================================-;

;- Create quick Hatch -;

;- (Option Hatch Angle) -;

;- Tested on AutoCAD 2002-2014 -;

;- Written by -;

;- Ebrahim Rastgou -;

;- WWW.GeoGIS.ir -;

;- 05-02-14 -;

;-=================================-;

(defun c:htc (/ *error*)

(defun *error* (msg)

(cond

((or (not msg)

(member msg

'("console break"

"function cancelled"

"quit / exit abort"

)

((princ (strcat "\nError: " msg)))

)

(cond (osm (setvar "osmode" osm)))

(cond (clyr (setvar "clayer" clyr)))

(cond (ccol (setvar "cecolor" ccol)))

(cond (cpat (setvar "hpname" cpat)))

(cond (hpas (setvar "hpassoc" hpas)))

(cond (hang (setvar "hpang" hang)))

(princ)

)

(while

(not

(mlml

(list (setq

Boundary-Closest (strcase

(getstring

nil

"\nSpecify boundary method introduced=> Boundary Create/Closest [b/c]: "

)

(list "B" "Boundary" "C" "Closest")

)

) ; end not

) ;_ end while

;; main part

(setvar "cmdecho" 0) ; disable command line echo

(setq osm (getvar "osmode")) ;store osnap settings

(setq clyr (getvar "clayer")) ;store current layer

(setq ccol (getvar "cecolor")) ; store current layer color

(setq cpat (getvar "hpname")) ; store the hatch pattern

(setq hpas (getvar "hpassoc")) ; store the hatch associativity

(setq hang (getvar "hpang")) ; store the hatch angle

(setvar "hpname" "ANSI31") ; set hatch pattern to ANSI31

(setvar "hpassoc" 1) ; set associativity

(layer_set "hatch" "8" "Bylayer") ;create or set layer "hatch" current,

;if this would not created before, then create them

; 8 - is color index of this layer, change to you suit

(setvar "osmode" 0)

(setvar "cecolor" "bylayer")

(setq ang (getreal "\nSpecify the hatch angle: "))

(setvar "hpang" ang) ; specify a hatch angle

(cond

((mlml (list Boundary-Closest) (list "B" "Boundary"))

(setq pts (defpoints)) ; get points

(command "pline")

(apply 'command pts) ; pass the point list in to command

(command "c") ; add polyline

(setq ip (getpoint "\nPick internal point: "))

(command "-hatch" ip "") ; add hatch

(*error* nil)

) ; >>> this error trapping function means the following:

((mlml (list Boundary-Closest) (list "C" "Closest"))

(setq ip (getpoint "\nPick internal point: "))

(command "-hatch" ip "") ; add hatch

(*error* nil)

)

;;;(setvar "cmdecho" 1); restore cmecho variable

;;;(setvar "osmode" osm); restore osnap settings

;;;(setvar "clayer" clyr); restore current layer variable

;;;(setvar "cecolor" ccol); restore current layer color variable

;;;(setvar "hpname" cpat); restore default hatch pattern variable

;;;(setvar "hpassoc" hpas); restore default hatch associativity variable

(princ)

)

(princ "\nStart with HTE to draw hatch")

(princ)

;--------------------------------------------------------------

(defun mlml (inSMLChar inSMLStri / returnVarMS toCheck chkWith)

(setq returnVarMS nil)

(if (and (= (type inSMLChar) 'LIST)

(= (type inSMLStri) 'LIST)

)

(progn

(foreach toCheck inSMLStri

(foreach chkWith inSMLChar

(if (eq toCheck chkWith)

(setq returnVarMS T)

)

) ;/progn

)

returnVarMS

)

;; local function, return list of points, specified on screen

;Specify boundary method introduced: Create Boundary/Closest [b/c]:

;

(defun defpoints ()

(setq lst nil)

(setq loop T)

(setq pt (getpoint "\nDigitize a first point :")

lst (cons pt lst)

)

(while

(setq pt

(getpoint "\nPick a next point or press Enter to end loop :"

)

(if (null pt)

(setq loop nil)

)

(setq lst (cons pt lst))

)

(reverse lst)

)

;; local function, to create layer

(defun layer_set (lyr col ltp)

(setvar "cmdecho" 0)

(if (tblsearch "layer" lyr)

(command "._-layer" "t" lyr "u" lyr "on" lyr "s" lyr "")

(command "._-layer" "m" lyr "c" col lyr "lt" ltp lyr "")

)

دوستانی که تمایل به کپی کردن کد برنامه را ندارند می‌توانند فایل لیسپ (LISP) برنامه بالا را از پیوندهای زیر دریافت نمایند.

برای اجرای این برنامه پس از دریافت و بارگذاری برنامه روی نرم افزار اتودسک خود، کافیست در خط فرمان نام اجرای برنامه که در خط تعریف برنامه (defun) نوشته شده است و اینتر کنند. نامه این برنامه برای اجرا htc است.

نکته : جزوات و اطلاعات این سایت به روز خواهند شد پس در زمان دانلود، به تاریخ انتشار آن توجه فرمایید.

حجم داده : ۲۳ کیلوبایت

تاریخ انتشار : ۹۳/۰۲/۲۹

دانلود : دانلود از لینک مستقیم