* E Posta Adresiniz:
* Kodu Girin:

İleti Yazar
13.12.2014 02:52
79640    
ProhibiT

[80] Yetkili

Online Durumu

1469 ileti
İnşaat Mühendisi
Ankara

Daha önce paylaştığımız Havalandırma Kanalı Metrajı yapmak için kullanılan KaMe'nin benzeri mantıkla çalışan, Boru Metrajı yapmak için kullanılmak üzere BoMe isimli fonksiyon yazdım. KaMe lispinde olduğu gibi bu konunun da çok uzayacağını tahmin ettiğim için, bağımsız başlık altında paylaşmak istedim.



Kod:

;|===========================================================================|
| Boru Metrajını yapmak için M. Şahin Güvercin tarafından hazırlanmıştır.   |
|                                  www.cizimokulu.com 12.05.2014            |
|===========================================================================|;
(defun C:BoMe(/ Boy Cap cp gbr Kbr KPNo kuk L MPo myerr Nk1 Nk2 olderr Rw YYuk)
  (defun myerr (errmsg)
    (if (/= errmsg "\nFunction cancelled") (prompt (strcat "\n" errmsg)))
    (command "._undo" "_e")
    (mapcar 'vlax-release-object (list rn ExCLLs Sht1 Shts NwBook Books ExApp))
    (setq ExApp nil) (gc) (gc) (setq egbr gbr eKbr Kbr eYuk YYuk eKPN KPNo)
    (setq *error* olderr) (princ))
  (setq olderr *error* *error* myerr) (*push-error-using-command*)
  (setvar "cmdecho" 0) (command "undo" "group") (vl-load-com) (setq cp "")
  (foreach ch '(77 46 32 83 97 104 105 110 32 71 252 118 101 114 99 105 110 32
    45 32) (setq cp (strcat cp (chr ch)))) (if (not egbr) (setq egbr "Cm"))
  (setq kuk (initget "Mm Cm mT """)
        gbr (getkword (strcat "\nÇizim Birimi [Mm/Cm/mT] <" egbr "> :")))
  (if (not gbr) (setq gbr egbr)) (if (not eKbr) (setq eKbr "Mm"))
  (if (not eYuk) (setq eYuk (* (getvar "dimtxt") (getvar "dimscale"))))
  (setq kuk  (initget)
        YYuk (getreal (strcat "\nYazi yüksekligi <" (rtos eYuk) "> :")))
  (if (not YYuk) (setq YYuk eYuk)) (if (not eKPN) (setq eKPN 1))
  (setq KPNo (getint (strcat "\nPoz Numarası <" (itoa eKPN) "> :")))
  (if (not KPNo) (setq KPNo eKPN))
  (setq ExApp (vlax-get-or-create-object "Excel.Application") Rw 1)
  (if (setq NwBook (vlax-get-property ExApp "ActiveWorkbook"))
    (setq Books  (vlax-get-property ExApp "WorkBooks")
          Shts   (vlax-get-property NwBook "Sheets")
          Sht1   (vlax-invoke-method Shts "Add"))
    (setq Books  (vlax-get-property ExApp "WorkBooks")
          NwBook (vlax-invoke-method Books "Add")
          Shts   (vlax-get-property NwBook "Sheets")
          Sht1   (vlax-get-property Shts "Item" 1)))
  (setq ExCLLs (vlax-get-property Sht1 "Cells"))
  (vlax-put-property ExApp "UseSystemSeparators" :vlax-false)
  (vlax-put-property ExApp "DecimalSeparator" ".")
  (vla-put-visible ExApp :vlax-true)
  (mapcar '(lambda (p1 p2)
             (vlax-put-property ExCLLs 'Item (nth 0 p1) (nth 1 p1) p2))
         '((1 1 1 1) (1 2 1 2) (1 3 1 3)) '("Poz No." "Çap" "Boy"))
  (vlax-put-property (vlax-get-property (vlax-get-property ExCLLs "Range"
        (vlax-variant-value (vlax-get-property ExCLLs 'Item 1 1))
        (vlax-variant-value (vlax-get-property ExCLLs 'Item 1 3)))
                       'CeLLs) 'HorizontalAlignment (vlax-make-variant -4108))
  (while (setq Nk1 (getpoint "\nBoru Başlangıç Noktasını seçiniz..."))
    (setq Nk2 (getpoint Nk1  "\n    Boru Bitiş Noktasını seçiniz...")
          Boy (distance Nk1 Nk2)
          MPo (mapcar '(lambda (n1 n2) (/ (+ n1 n2) 2.0)) Nk1 Nk2))
    (entmake (list (cons 0 "TEXT") (cons 10 MPo) (cons 40 YYuk)
                   (cons 1 (itoa KPNo)) (cons 50 0) (cons 72 4) (cons 11 MPo)))
    (entmake (list (cons 0 "CIRCLE") (cons 10 MPo) (cons 40 (* 1.15 YYuk))))
    (princ "\nBoru Çap Yazısını seçiniz...")
    (while (not (setq Cap (ssget "+.:s" (list (cons 0 "*TEXT")))))
      (princ "\n Sectiginiz obje bir Text veya MText olmalıdır!"))
    (cond ((= gbr "Mm") (setq Boy (/ Boy 1000)))
          ((= gbr "Cm") (setq Boy (/ Boy 100)))
          ((= gbr "m") (setq Boy Boy))
          (T nil))
    (setq Rw (1+ Rw) Cap (cdr (assoc 1 (entget (ssname Cap 0)))))
    (if (vl-string-position 45 Cap)
      (setq Cap (substr Cap (+ 2 (vl-string-position 45 Cap)))))
    (mapcar '(lambda (p1 p2) (vlax-put-property ExCLLs 'Item rw p1 p2))
            '(1 2 3) (list (itoa KPNo) Cap (rtos Boy 2 2)))
    (princ (strcat "\n* Poz No:" (itoa KPNo) ", Çap:" Cap
      ", Boy:" (rtos Boy 2 2))) (setq KPNo (1+ KPNo)))
  (setq Rw (1+ Rw) rn (vlax-get-property ExCLLs "Range"
             (vlax-variant-value (vlax-get-property ExCLLs 'Item Rw 1))
             (vlax-variant-value (vlax-get-property ExCLLs 'Item Rw 3))))
  (vlax-put-property rn 'MergeCells :vlax-true)
  (vlax-put-property ExCLLs 'Item Rw 1 (foreach ch '(119 119 119 46 99 105 122
    105 109 111 107 117 108 117 46 99 111 109) (setq cp (strcat cp (chr ch)))))
  (vlax-put-property rn 'ShrinkToFit :vlax-true)
  (setq rn (vlax-get-property ExCLLs "Range"
             (vlax-variant-value (vlax-get-property ExCLLs 'Item 1 1))
             (vlax-variant-value (vlax-get-property ExCLLs 'Item Rw 3))))
  (vlax-put-property (vlax-get-property rn 'Borders) 'color (vlax-make-variant "0.0"))
  (vlax-put-property (vlax-get-property rn 'Borders) 'LineStyle (vlax-make-variant "1"))
  (vlax-invoke-method (vlax-get-property rn 'Columns) 'AutoFit)
  (vlax-invoke-method (vlax-get-property rn 'Rows) 'AutoFit)
  (vlax-put-property ExApp "UseSystemSeparators" :vlax-true)
  (mapcar 'vlax-release-object (list rn ExCLLs Sht1 Shts NwBook Books ExApp))
  (setq ExApp nil) (gc) (gc) (setq egbr gbr eKbr Kbr eYuk YYuk eKPN KPNo)
  (command "_.undo" "end") (setq *error* olderr) (*pop-error-mode*) (prin1))

Kodları buradan alarak Lisp dosyasına çevirerek kullanmakta zorluk çeken arkadaşlarımız 174410-bome-1.rar linkinden hazır dosyayı indirebilirler.

Herkese kolay gelsin...


admin (05.04.2018 21:01 GMT)

Where there is a will, there is a way... Beğenmek için anlamak lazım...

13.12.2014 10:04
79642    
sensey06

[2] Girişimci

Online Durumu

2 ileti
İklimendirme soğutma teknikeri
ankara

Ellerine sağlık hocam....

Herkes hak ettiği hayatı yaşar....

13.12.2014 15:01
79649    
mttlp

[8] Kıdemli Uzman

Online Durumu

100 ileti
Teknik Ressam
ankara

Eline sağlık hocam

en sevdiğim komut copy

14.12.2014 02:36
79666    
kaan0624

[40] Gold üye

Online Durumu

32 ileti
inşaat teknikeri
ankara

hocam elinize sağlık gerçekten çok beğendim.bu program şöylede olsa böylede olsa gibi şeyler söyleyip sizin canınızı sıkmak istemiyorum hocam.kitabınızdan çok faydalanıyorum yavaş yavaş öğrendiğimi hissediyorum.yalnız ufak bir sorum var düzenleme bakımından bu programda çap boy değilde en boy şeklinde birşey yapabilirmiyim.şimdiden çok teşekkür ederim hocam

15.12.2014 01:55
79677    
onderylmz

[3] Kıdemli Girişimci

Online Durumu

32 ileti
Mak.Yük.Müh.
ANKARA

Ellerinize sağlık hocam
Bir önerim olacak affınıza sığınarak
linneer ölçimler yerine çok dönüşlü ölçümleri yapma olanağı da verebilrir msiniz
ya da çoklu seçimler yapıp sonradan çapı değştirdiğimde seçimleri toplayıp yazavbilir mi
?
poliline gibi ....

20.12.2014 23:32
79805    
onderylmz

[3] Kıdemli Girişimci

Online Durumu

32 ileti
Mak.Yük.Müh.
ANKARA

bu lisp çoklu nokta seçimi haline getirilebilir mi ? Lütfen Yardım ...

20.12.2014 23:32
79806    
onderylmz

[3] Kıdemli Girişimci

Online Durumu

32 ileti
Mak.Yük.Müh.
ANKARA

bu lisp çoklu nokta seçimi haline getirilebilir mi ? Lütfen Yardım ...

20.12.2014 23:32
79807    
onderylmz

[3] Kıdemli Girişimci

Online Durumu

32 ileti
Mak.Yük.Müh.
ANKARA

bu lisp çoklu nokta seçimi haline getirilebilir mi ? Lütfen Yardım ...

30.10.2016 01:11
84076    
elk21

[40] Gold üye

Online Durumu

21 ileti
elektrik teknikeri
diyarbakır

yaw özür dilerim ama bir türlü çalıştıramadım

15.01.2018 00:28
85921    
eruk

[2] Girişimci

Online Durumu

1 ileti

Kardes,
Bendeniz Hollanda'dan katilmaktayim...

Acemiyim.... toyum...comezim.. lamerim...
Bome programiniz borulari tek tek seciyor..

Simdi bunu tum borulari secme imkani yapma varmidir.

He de gardas...da su acemiyi sevindir.

24.05.2018 17:39
86340    
ebkeskin

[2] Girişimci

Online Durumu

1 ileti

hangi komutla çalışıyor onu yazmamışsınız?

29.09.2018 14:42
86698    
tekgul

[2] Girişimci

Online Durumu

1 ileti
tekniker
ankara

Alıntı
ProhibiT :
Daha önce paylaştığımız Havalandırma Kanalı Metrajı yapmak için kullanılan KaMe'nin benzeri mantıkla çalışan, Boru Metrajı yapmak için kullanılmak üzere BoMe isimli fonksiyon yazdım. KaMe lispinde olduğu gibi bu konunun da çok uzayacağını tahmin ettiğim için, bağımsız başlık altında paylaşmak istedim.



Kod:

;|===========================================================================|
| Boru Metrajını yapmak için M. Şahin Güvercin tarafından hazırlanmıştır.   |
|                                  www.cizimokulu.com 12.05.2014            |
|===========================================================================|;
(defun C:BoMe(/ Boy Cap cp gbr Kbr KPNo kuk L MPo myerr Nk1 Nk2 olderr Rw YYuk)
  (defun myerr (errmsg)
    (if (/= errmsg "\nFunction cancelled") (prompt (strcat "\n" errmsg)))
    (command "._undo" "_e")
    (mapcar 'vlax-release-object (list rn ExCLLs Sht1 Shts NwBook Books ExApp))
    (setq ExApp nil) (gc) (gc) (setq egbr gbr eKbr Kbr eYuk YYuk eKPN KPNo)
    (setq *error* olderr) (princ))
  (setq olderr *error* *error* myerr) (*push-error-using-command*)
  (setvar "cmdecho" 0) (command "undo" "group") (vl-load-com) (setq cp "")
  (foreach ch '(77 46 32 83 97 104 105 110 32 71 252 118 101 114 99 105 110 32
    45 32) (setq cp (strcat cp (chr ch)))) (if (not egbr) (setq egbr "Cm"))
  (setq kuk (initget "Mm Cm mT """)
        gbr (getkword (strcat "\nÇizim Birimi [Mm/Cm/mT] <" egbr "> :")))
  (if (not gbr) (setq gbr egbr)) (if (not eKbr) (setq eKbr "Mm"))
  (if (not eYuk) (setq eYuk (* (getvar "dimtxt") (getvar "dimscale"))))
  (setq kuk  (initget)
        YYuk (getreal (strcat "\nYazi yüksekligi <" (rtos eYuk) "> :")))
  (if (not YYuk) (setq YYuk eYuk)) (if (not eKPN) (setq eKPN 1))
  (setq KPNo (getint (strcat "\nPoz Numarası <" (itoa eKPN) "> :")))
  (if (not KPNo) (setq KPNo eKPN))
  (setq ExApp (vlax-get-or-create-object "Excel.Application") Rw 1)
  (if (setq NwBook (vlax-get-property ExApp "ActiveWorkbook"))
    (setq Books  (vlax-get-property ExApp "WorkBooks")
          Shts   (vlax-get-property NwBook "Sheets")
          Sht1   (vlax-invoke-method Shts "Add"))
    (setq Books  (vlax-get-property ExApp "WorkBooks")
          NwBook (vlax-invoke-method Books "Add")
          Shts   (vlax-get-property NwBook "Sheets")
          Sht1   (vlax-get-property Shts "Item" 1)))
  (setq ExCLLs (vlax-get-property Sht1 "Cells"))
  (vlax-put-property ExApp "UseSystemSeparators" :vlax-false)
  (vlax-put-property ExApp "DecimalSeparator" ".")
  (vla-put-visible ExApp :vlax-true)
  (mapcar '(lambda (p1 p2)
             (vlax-put-property ExCLLs 'Item (nth 0 p1) (nth 1 p1) p2))
         '((1 1 1 1) (1 2 1 2) (1 3 1 3)) '("Poz No." "Çap" "Boy"))
  (vlax-put-property (vlax-get-property (vlax-get-property ExCLLs "Range"
        (vlax-variant-value (vlax-get-property ExCLLs 'Item 1 1))
        (vlax-variant-value (vlax-get-property ExCLLs 'Item 1 3)))
                       'CeLLs) 'HorizontalAlignment (vlax-make-variant -4108))
  (while (setq Nk1 (getpoint "\nBoru Başlangıç Noktasını seçiniz..."))
    (setq Nk2 (getpoint Nk1  "\n    Boru Bitiş Noktasını seçiniz...")
          Boy (distance Nk1 Nk2)
          MPo (mapcar '(lambda (n1 n2) (/ (+ n1 n2) 2.0)) Nk1 Nk2))
    (entmake (list (cons 0 "TEXT") (cons 10 MPo) (cons 40 YYuk)
                   (cons 1 (itoa KPNo)) (cons 50 0) (cons 72 4) (cons 11 MPo)))
    (entmake (list (cons 0 "CIRCLE") (cons 10 MPo) (cons 40 (* 1.15 YYuk))))
    (princ "\nBoru Çap Yazısını seçiniz...")
    (while (not (setq Cap (ssget "+.:s" (list (cons 0 "*TEXT")))))
      (princ "\n Sectiginiz obje bir Text veya MText olmalıdır!"))
    (cond ((= gbr "Mm") (setq Boy (/ Boy 1000)))
          ((= gbr "Cm") (setq Boy (/ Boy 100)))
          ((= gbr "m") (setq Boy Boy))
          (T nil))
    (setq Rw (1+ Rw) Cap (cdr (assoc 1 (entget (ssname Cap 0)))))
    (if (vl-string-position 45 Cap)
      (setq Cap (substr Cap (+ 2 (vl-string-position 45 Cap)))))
    (mapcar '(lambda (p1 p2) (vlax-put-property ExCLLs 'Item rw p1 p2))
            '(1 2 3) (list (itoa KPNo) Cap (rtos Boy 2 2)))
    (princ (strcat "\n* Poz No:" (itoa KPNo) ", Çap:" Cap
      ", Boy:" (rtos Boy 2 2))) (setq KPNo (1+ KPNo)))
  (setq Rw (1+ Rw) rn (vlax-get-property ExCLLs "Range"
             (vlax-variant-value (vlax-get-property ExCLLs 'Item Rw 1))
             (vlax-variant-value (vlax-get-property ExCLLs 'Item Rw 3))))
  (vlax-put-property rn 'MergeCells :vlax-true)
  (vlax-put-property ExCLLs 'Item Rw 1 (foreach ch '(119 119 119 46 99 105 122
    105 109 111 107 117 108 117 46 99 111 109) (setq cp (strcat cp (chr ch)))))
  (vlax-put-property rn 'ShrinkToFit :vlax-true)
  (setq rn (vlax-get-property ExCLLs "Range"
             (vlax-variant-value (vlax-get-property ExCLLs 'Item 1 1))
             (vlax-variant-value (vlax-get-property ExCLLs 'Item Rw 3))))
  (vlax-put-property (vlax-get-property rn 'Borders) 'color (vlax-make-variant "0.0"))
  (vlax-put-property (vlax-get-property rn 'Borders) 'LineStyle (vlax-make-variant "1"))
  (vlax-invoke-method (vlax-get-property rn 'Columns) 'AutoFit)
  (vlax-invoke-method (vlax-get-property rn 'Rows) 'AutoFit)
  (vlax-put-property ExApp "UseSystemSeparators" :vlax-true)
  (mapcar 'vlax-release-object (list rn ExCLLs Sht1 Shts NwBook Books ExApp))
  (setq ExApp nil) (gc) (gc) (setq egbr gbr eKbr Kbr eYuk YYuk eKPN KPNo)
  (command "_.undo" "end") (setq *error* olderr) (*pop-error-mode*) (prin1))

Kodları buradan alarak Lisp dosyasına çevirerek kullanmakta zorluk çeken arkadaşlarımız 174410-bome-1.rar linkinden hazır dosyayı indirebilirler.

Herkese kolay gelsin...

> 1 <
Copyright © 2004-2018 | Tüm Hakları Saklıdır | 1247 | Site haritası | İstatistikler | Hakkımızda | Kadromuz | Gizlilik | Reklam