[编程申请]：请高手帮看看这段程序哪有错,2004不能使用这程序

ZHJ0034

拜托,帮看看为什么2004不能加载..

(defun C:HHH ( / uu g g1 tm1 pt1 pt2 x y x1 y1)
(command "osnap" "int")
(COMMAND "COLOR" 5 \r)
  (setq g(open "YB.DAT" "r"))
  (setq YB(read(read-line g)))
  (close g)         
  (setq tm1 "TM= ")
  (setq g1(open "APH" "a"))

(setq aa (getstring "\n   # = ? "))
(setq pt1 (getpoint "\n   GH = ? "))
(print aa g1)(princ " H= " g1)
(setq y0 (cadr pt1))
(while (not (null pt1))
(setq pt1 (getpoint"\n    H = ? "))

(if (not (null pt1))  (progn
                      (setq x (car pt1)) (setq y (cadr pt1))
                      (setq hh(- y0 y)) (setq hh(/ hh yb))

                      (setq uu (rtos hh 2 1))
                      (princ uu g1) (princ " " g1)
                      (SETQ X1(- X 1.4)) (SETQ Y1(+ Y 0.1))
        (setq x2(- x 3.4)) (setq pt3(list x2 y1))
                      (SETQ PT2(LIST X1 Y1))
          (command "text" "r" pt2 0.7 0 uu \r)
                      (setq tm (getint"\n TM = ? "))
(setq aa(itoa tm))
(setq tm1 (strcat TM1 aa " "))  
          (command "text" "r" pt3 0.7 0 aa \r)
))
)
(princ tm1 g1)
(close g1)
(setq g1 1))
;
;
;

xyp1964

不知用途且文件不全，无法测试：

2. [FONT=courier new](defun C:HHH (/ uu g g1 tm1 pt1 pt2 x y x1 y1)
   
3.   (command "osnap" "int")
   
4.   (COMMAND "COLOR" 5)
   
5.   (setq        g  (open "YB.DAT" "r")
   
6.         YB (read (read-line g))
   
7.   )
   
8.   (close g)
   
9.   (setq        tm1 "TM= "
   
10.         g1  (open "APH" "a")
    
11.         aa  (getstring "\n # = ? ")
    
12.         pt1 (getpoint "\n GH = ? ")
    
13.   )
    
14.   (print aa g1)
    
15.   (princ " H= " g1)
    
16.   (setq y0 (cadr pt1))
    
17.   (while (setq pt1 (getpoint "\n H = ? "))
    
18.     (if        pt1
    
19.       (progn
    
20.         (setq x         (car pt1)
    
21.               y         (cadr pt1)
    
22.               hh (- y0 y)
    
23.               hh (/ hh yb)
    
24.               uu (rtos hh 2 1)
    
25.         )
    
26.         (princ uu g1)
    
27.         (princ " " g1)
    
28.         (SETQ X1  (- X 1.4)
    
29.               Y1  (+ Y 0.1)
    
30.               x2  (- x 3.4)
    
31.               pt3 (list x2 y1)
    
32.               PT2 (LIST X1 Y1)
    
33.         )
    
34.         (command "text" "r" pt2 0.7 0 uu)
    
35.         (setq tm  (getint "\n TM = ? ")
    
36.               aa  (itoa tm)
    
37.               tm1 (strcat TM1 aa " ")
    
38.         )
    
39.         (command "text" "r" pt3 0.7 0 aa)
    
40.       )
    
41.     )
    
42.   )
    
43.   (princ tm1 g1)
    
44.   (close g1)
    
45.   (princ)
    
46. )[/FONT]

[FONT=courier new](defun C:HHH (/ uu g g1 tm1 pt1 pt2 x y x1 y1)<br />   (command "osnap" "int")<br />   (COMMAND "COLOR" 5)<br />   (setq        g  (open "YB.DAT" "r")<br />         YB (read (read-line g))<br />   )<br />   (close g)<br />   (setq        tm1 "TM= "<br />         g1  (open "APH" "a")<br />         aa  (getstring "\n # = ? ")<br />         pt1 (getpoint "\n GH = ? ")<br />   )<br />   (print aa g1)<br />   (princ " H= " g1)<br />   (setq y0 (cadr pt1))<br />   (while (setq pt1 (getpoint "\n H = ? "))<br />     (if        pt1<br />       (progn<br />         (setq x         (car pt1)<br />               y         (cadr pt1)<br />               hh (- y0 y)<br />               hh (/ hh yb)<br />               uu (rtos hh 2 1)<br />         )<br />         (princ uu g1)<br />         (princ " " g1)<br />         (SETQ X1  (- X 1.4)<br />               Y1  (+ Y 0.1)<br />               x2  (- x 3.4)<br />               pt3 (list x2 y1)<br />               PT2 (LIST X1 Y1)<br />         )<br />         (command "text" "r" pt2 0.7 0 uu)<br />         (setq tm  (getint "\n TM = ? ")<br />               aa  (itoa tm)<br />               tm1 (strcat TM1 aa " ")<br />         )<br />         (command "text" "r" pt3 0.7 0 aa)<br />       )<br />     )<br />   )<br />   (princ tm1 g1)<br />   (close g1)<br />   (princ)<br /> )[/FONT]

ZHJ0034

小弟是搞地质勘察工作的，经常需要作地质勘察方面的图，上次发的程序的确不全，这次发全的。。
这程序是在R11版下开发出来专门用来做工程地质剖面土的，现在也只能在R11版下使用，很不方便。想在2004下使用该程序。。
全的如下。。其中命令“FC”主要是在勘探孔上，在需要分层的地方自动生成1条分层直线。
第2步命令“HHH”就是首先输入孔号，确定孔的起始点，然后在点击“FC”分层直线，而自动生成分层的深度，然后提示下手动输入当前土层代码。。最后以上的操作生成APH文件（土层的分层深度，土层代码）都会写入该文件。
（注：因为要节约空间，图都是缩小5倍作的）
(defun C:FC ( / pt1 pt2 x y xe)
(SETQ PT1 (LIST 0 0))
(COMMAND "OSNAP" "OFF")
(while (not (null pt1))
(setq pt1 (getpoint"\n fencehng point "))
    (setq x (car pt1)) (setq y (cadr pt1)) (setq xe(+ x 4.0))
    (setq pt2 (list xe y))
    (command "line" pt1 pt2 \r)               
))

(defun C:HHH ( / uu g g1 tm1 pt1 pt2 x y x1 y1)
(command "osnap" "int")
(COMMAND "COLOR" 5 \r)
  (setq g(open "YB.DAT" "r"))
  (setq YB(read(read-line g)))
  (close g)         
  (setq tm1 "TM= ")
  (setq g1(open "APH" "a"))

(setq aa (getstring "\n   # = ? "))
(setq pt1 (getpoint "\n   GH = ? "))
(print aa g1)(princ " H= " g1)
(setq y0 (cadr pt1))
(while (not (null pt1))
(setq pt1 (getpoint"\n    H = ? "))

(if (not (null pt1))  (progn
                      (setq x (car pt1)) (setq y (cadr pt1))
                      (setq hh(- y0 y)) (setq hh(/ hh yb))

                      (setq uu (rtos hh 2 1))
                      (princ uu g1) (princ " " g1)
                      (SETQ X1(- X 1.4)) (SETQ Y1(+ Y 0.1))
        (setq x2(- x 3.4)) (setq pt3(list x2 y1))
                      (SETQ PT2(LIST X1 Y1))
          (command "text" "r" pt2 0.7 0 uu \r)
                      (setq tm (getint"\n TM = ? "))
(setq aa(itoa tm))
(setq tm1 (strcat TM1 aa " "))  
          (command "text" "r" pt3 0.7 0 aa \r)
))
)
(princ tm1 g1)
(close g1)
(setq g1 1))
;
;

上传图1张

xyp1964

把YB.DAT文件和dwg图发上来！

ZHJ0034

斑竹的话令小弟茅塞顿开,
YB.DAT文件是在做草图时生成的图形水平和垂直比例的文件(比如我用,垂直与水平比例都用1:100。那YB。DAT用写字版打开如下
2.00 2.00
看了斑竹的话，我在图形所在的目录下新建YB。DAT文件，里面输入2.00 2.00保存，就能在2004里加载使用。。
非常感谢斑竹的指点，
还有，本想上传1张图，不得其法。望斑竹告之，
小弟工作中所作工程地质剖面土（因程序是在R11版下开发的）只能在纯DOS下操作，效率很低，一直希望能改进到窗口下操作，希望有机会请斑竹多指教。。